1 package SQL::Translator::Parser::Sybase;
5 SQL::Translator::Parser::Sybase - parser for Sybase
9 use SQL::Translator::Parser::Sybase;
13 Mostly parses the output of "dbschema.pl," a Perl script freely
14 available from http://www.midsomer.org. The parsing is not complete,
15 however, and you would probably have much better luck using the
16 DBI-Sybase parser included with SQL::Translator.
23 our ( $DEBUG, $GRAMMAR, @EXPORT_OK );
24 our $VERSION = '1.59';
25 $DEBUG = 0 unless defined $DEBUG;
28 use Parse::RecDescent;
30 use base qw(Exporter);
32 @EXPORT_OK = qw(parse);
41 my ( %tables, @table_comments, $table_order );
44 startrule : statement(s) eofile { \%tables }
48 statement : create_table
62 { @table_comments = () }
64 setuser : /setuser/i NAME GO
66 if : /if/i object_not_null begin if_command end GO
72 object_not_null : /object_id/i '(' ident ')' /is not null/i
74 print : /\s*/ /print/i /.*/
82 grant : /grant/i /[^\n]*/
84 exec : exec_statement(s) GO
86 exec_statement : /exec/i /[^\n]+/
88 comment : comment_start comment_middle comment_end
90 my $comment = $item[2];
91 $comment =~ s/^\s*|\s*$//mg;
92 $comment =~ s/^\**\s*//mg;
93 push @table_comments, $comment;
96 comment_start : /^\s*\/\*/
98 comment_end : /\s*\*\//
100 comment_middle : m{([^*]+|\*(?!/))*}
105 create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) GO
107 my $table_owner = $item[3]{'owner'};
108 my $table_name = $item[3]{'name'};
110 if ( @table_comments ) {
111 $tables{ $table_name }{'comments'} = [ @table_comments ];
112 @table_comments = ();
115 $tables{ $table_name }{'order'} = ++$table_order;
116 $tables{ $table_name }{'name'} = $table_name;
117 $tables{ $table_name }{'owner'} = $table_owner;
118 $tables{ $table_name }{'system'} = $item[7];
121 for my $def ( @{ $item[5] } ) {
122 if ( $def->{'supertype'} eq 'field' ) {
123 my $field_name = $def->{'name'};
124 $tables{ $table_name }{'fields'}{ $field_name } =
125 { %$def, order => $i };
128 if ( $def->{'is_primary_key'} ) {
129 push @{ $tables{ $table_name }{'constraints'} }, {
130 type => 'primary_key',
131 fields => [ $field_name ],
135 elsif ( $def->{'supertype'} eq 'constraint' ) {
136 push @{ $tables{ $table_name }{'constraints'} }, $def;
139 push @{ $tables{ $table_name }{'indices'} }, $def;
144 create_constraint : /create/i constraint
146 @table_comments = ();
147 push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
150 create_index : /create/i index
152 @table_comments = ();
153 push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
156 create_procedure : /create/i /procedure/i procedure_body GO
158 @table_comments = ();
161 procedure_body : not_go(s)
163 not_go : /((?!go).)*/
171 field : field_name data_type nullable(?)
174 supertype => 'field',
175 name => $item{'field_name'},
176 data_type => $item{'data_type'}{'type'},
177 size => $item{'data_type'}{'size'},
178 nullable => $item[3][0],
179 # default => $item{'default_val'}[0],
180 # is_auto_inc => $item{'auto_inc'}[0],
181 # is_primary_key => $item{'primary_key'}[0],
185 constraint : primary_key_constraint
194 data_type : WORD field_size(?)
202 lock : /lock/i /datarows/i
206 field_size : '(' num_range ')' { $item{'num_range'} }
208 num_range : DIGITS ',' DIGITS
209 { $return = $item[1].','.$item[3] }
211 { $return = $item[1] }
214 nullable : /not/i /null/i
219 default_val : /default/i /(?:')?[\w\d.-]*(?:')?/
220 { $item[2]=~s/'//g; $return=$item[2] }
222 auto_inc : /auto_increment/i { 1 }
224 primary_key_constraint : /primary/i /key/i index_name(?) parens_field_list
227 supertype => 'constraint',
228 name => $item{'index_name'}[0],
229 type => 'primary_key',
234 unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list
237 supertype => 'constraint',
239 clustered => $item[2][0],
241 table => $item[5][0],
246 clustered : /clustered/i
253 on_table : /on/i table_name
254 { $return = $item[2] }
256 on_system : /on/i /system/i
259 index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list
262 supertype => 'index',
264 clustered => $item[1][0],
266 table => $item[4][0],
271 parens_field_list : '(' field_name(s /,/) ')'
274 ident : QUOTE(?) WORD '.' WORD QUOTE(?)
275 { $return = { owner => $item[2], name => $item[4] } }
277 { $return = { name => $item[2] } }
281 NAME : QUOTE(?) /\w+/ QUOTE(?)
295 my ( $translator, $data ) = @_;
296 my $parser = Parse::RecDescent->new($GRAMMAR);
298 local $::RD_TRACE = $translator->trace ? 1 : undef;
299 local $DEBUG = $translator->debug;
301 unless (defined $parser) {
302 return $translator->error("Error instantiating Parse::RecDescent ".
303 "instance: Bad grammer");
306 my $result = $parser->startrule($data);
307 return $translator->error( "Parse failed." ) unless defined $result;
308 warn Dumper( $result ) if $DEBUG;
310 my $schema = $translator->schema;
312 $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
315 for my $table_name ( @tables ) {
316 my $tdata = $result->{ $table_name };
317 my $table = $schema->add_table( name => $tdata->{'name'} )
318 or die "Can't create table '$table_name': ", $schema->error;
320 $table->comments( $tdata->{'comments'} );
323 $tdata->{'fields'}->{$a}->{'order'}
325 $tdata->{'fields'}->{$b}->{'order'}
326 } keys %{ $tdata->{'fields'} };
328 for my $fname ( @fields ) {
329 my $fdata = $tdata->{'fields'}{ $fname };
330 my $field = $table->add_field(
331 name => $fdata->{'name'},
332 data_type => $fdata->{'data_type'},
333 size => $fdata->{'size'},
334 default_value => $fdata->{'default'},
335 is_auto_increment => $fdata->{'is_auto_inc'},
336 is_nullable => $fdata->{'nullable'},
337 comments => $fdata->{'comments'},
338 ) or die $table->error;
340 $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
342 for my $qual ( qw[ binary unsigned zerofill list ] ) {
343 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
344 next if ref $val eq 'ARRAY' && !@$val;
345 $field->extra( $qual, $val );
349 if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
350 my %extra = $field->extra;
352 for my $len ( map { length } @{ $extra{'list'} || [] } ) {
353 $longest = $len if $len > $longest;
355 $field->size( $longest ) if $longest;
358 for my $cdata ( @{ $fdata->{'constraints'} } ) {
359 next unless $cdata->{'type'} eq 'foreign_key';
360 $cdata->{'fields'} ||= [ $field->name ];
361 push @{ $tdata->{'constraints'} }, $cdata;
365 for my $idata ( @{ $tdata->{'indices'} || [] } ) {
366 my $index = $table->add_index(
367 name => $idata->{'name'},
368 type => uc $idata->{'type'},
369 fields => $idata->{'fields'},
370 ) or die $table->error;
373 for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
374 my $constraint = $table->add_constraint(
375 name => $cdata->{'name'},
376 type => $cdata->{'type'},
377 fields => $cdata->{'fields'},
378 reference_table => $cdata->{'reference_table'},
379 reference_fields => $cdata->{'reference_fields'},
380 match_type => $cdata->{'match_type'} || '',
381 on_delete => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
382 on_update => $cdata->{'on_update'} || $cdata->{'on_update_do'},
383 ) or die $table->error;
392 # -------------------------------------------------------------------
393 # Every hero becomes a bore at last.
394 # Ralph Waldo Emerson
395 # -------------------------------------------------------------------
401 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
405 SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.