1 package SQL::Translator::Parser::SQLServer;
5 SQL::Translator::Parser::SQLServer - parser for SQL Server
9 use SQL::Translator::Parser::SQLServer;
13 Adapted from Parser::Sybase and mostly parses the output of
14 Producer::SQLServer. The parsing is by no means complete and
15 should probably be considered a work in progress.
22 our ( $DEBUG ,$GRAMMAR, @EXPORT_OK );
23 our $VERSION = '1.59';
24 $DEBUG = 0 unless defined $DEBUG;
27 use Parse::RecDescent;
29 use base qw(Exporter);
31 @EXPORT_OK = qw(parse);
40 my ( %tables, @table_comments, $table_order, %procedures, $proc_order, %views, $view_order );
44 my @up_to_N_lines = split (/\n/, $_[1], $max_lines + 1);
45 die sprintf ("Unable to parse line %d:\n%s\n",
47 join "\n", (map { "'$_'" } @up_to_N_lines[0..$max_lines - 1 ]), @up_to_N_lines > $max_lines ? '...' : ()
53 startrule : statement(s) eofile
57 procedures => \%procedures,
64 statement : create_table
78 | /^\Z/ | { _err ($thisline, $text) }
81 { @table_comments = () }
83 setuser : /setuser/i NAME GO
85 if : /if/i object_not_null begin if_command end GO
91 object_not_null : /object_id/i '(' ident ')' /is not null/i
93 field_not_null : /where/i field_name /is \s+ not \s+ null/ix
95 print : /\s*/ /print/i /.*/
103 grant : /grant/i /[^\n]*/
105 exec : exec_statement(s) GO
107 exec_statement : /exec/i /[^\n]+/
109 comment : /^\s*(?:#|-{2}).*\n/
111 my $comment = $item[1];
112 $comment =~ s/^\s*(#|--)\s*//;
113 $comment =~ s/\s*$//;
115 push @table_comments, $comment;
118 comment : comment_start comment_middle comment_end
120 my $comment = $item[2];
121 $comment =~ s/^\s*|\s*$//mg;
122 $comment =~ s/^\**\s*//mg;
123 push @table_comments, $comment;
126 comment_start : m#^\s*\/\*#
128 comment_end : m#\s*\*\/#
130 comment_middle : m{([^*]+|\*(?!/))*}
132 drop : if_exists(?) /drop/i tbl_drop END_STATEMENT
134 tbl_drop : /table/i ident
136 if_exists : /if exists/i '(' /select/i 'name' /from/i 'sysobjects' /[^\)]+/ ')'
141 create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) END_STATEMENT
143 my $table_owner = $item[3]{'owner'};
144 my $table_name = $item[3]{'name'};
146 if ( @table_comments ) {
147 $tables{ $table_name }{'comments'} = [ @table_comments ];
148 @table_comments = ();
151 $tables{ $table_name }{'order'} = ++$table_order;
152 $tables{ $table_name }{'name'} = $table_name;
153 $tables{ $table_name }{'owner'} = $table_owner;
154 $tables{ $table_name }{'system'} = $item[7];
157 for my $def ( @{ $item[5] } ) {
158 if ( $def->{'supertype'} eq 'field' ) {
159 my $field_name = $def->{'name'};
160 $tables{ $table_name }{'fields'}{ $field_name } =
161 { %$def, order => $i };
164 if ( $def->{'is_primary_key'} ) {
165 push @{ $tables{ $table_name }{'constraints'} }, {
166 type => 'primary_key',
167 fields => [ $field_name ],
171 elsif ( $def->{'supertype'} eq 'constraint' ) {
172 push @{ $tables{ $table_name }{'constraints'} }, $def;
175 push @{ $tables{ $table_name }{'indices'} }, $def;
180 disable_constraints : if_exists(?) /alter/i /table/i ident /nocheck/i /constraint/i /all/i END_STATEMENT
182 # this is for the normal case
183 create_constraint : /create/i constraint END_STATEMENT
185 @table_comments = ();
186 push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
189 # and this is for the BEGIN/END case
190 create_constraint : /create/i constraint
192 @table_comments = ();
193 push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
197 create_constraint : /alter/i /table/i ident /add/i foreign_key_constraint END_STATEMENT
199 push @{ $tables{ $item[3]{name} }{constraints} }, $item[5];
203 create_index : /create/i index
205 @table_comments = ();
206 push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
209 create_procedure : /create/i PROCEDURE WORD not_go GO
211 @table_comments = ();
212 my $proc_name = $item[3];
214 my $sql = "$item[1] $item[2] $proc_name $item[4]";
216 $procedures{ $proc_name }{'order'} = ++$proc_order;
217 $procedures{ $proc_name }{'name'} = $proc_name;
218 $procedures{ $proc_name }{'owner'} = $owner;
219 $procedures{ $proc_name }{'sql'} = $sql;
222 create_procedure : /create/i PROCEDURE '[' WORD '].' WORD not_go GO
224 @table_comments = ();
225 my $proc_name = $item[6];
226 my $owner = $item[4];
227 my $sql = "$item[1] $item[2] [$owner].$proc_name $item[7]";
229 $procedures{ $proc_name }{'order'} = ++$proc_order;
230 $procedures{ $proc_name }{'name'} = $proc_name;
231 $procedures{ $proc_name }{'owner'} = $owner;
232 $procedures{ $proc_name }{'sql'} = $sql;
235 PROCEDURE : /procedure/i
238 create_view : /create/i /view/i WORD not_go GO
240 @table_comments = ();
241 my $view_name = $item[3];
242 my $sql = "$item[1] $item[2] $item[3] $item[4]";
244 $views{ $view_name }{'order'} = ++$view_order;
245 $views{ $view_name }{'name'} = $view_name;
246 $views{ $view_name }{'sql'} = $sql;
249 not_go : /((?!\bgo\b).)*/is
251 create_def : constraint
257 field : field_name data_type field_qualifier(s?)
259 my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
260 my $nullable = defined $qualifiers{'nullable'}
261 ? $qualifiers{'nullable'} : 1;
263 supertype => 'field',
264 name => $item{'field_name'},
265 data_type => $item{'data_type'}{'type'},
266 size => $item{'data_type'}{'size'},
267 nullable => $nullable,
268 default => $qualifiers{'default_val'},
269 is_auto_inc => $qualifiers{'is_auto_inc'},
270 # is_primary_key => $item{'primary_key'}[0],
274 field_qualifier : nullable
277 nullable => $item{'nullable'},
281 field_qualifier : default_val
284 default_val => $item{'default_val'},
288 field_qualifier : auto_inc
291 is_auto_inc => $item{'auto_inc'},
295 constraint : primary_key_constraint
296 | foreign_key_constraint
300 { $return = $item[1] }
302 { $return = $item[2] }
305 { $return = $item[1] }
307 { $return = $item[2] }
310 { $return = $item[1] }
312 { $return = $item[2] }
314 data_type : WORD field_size(?)
322 lock : /lock/i /datarows/i
326 field_size : '(' num_range ')' { $item{'num_range'} }
328 num_range : DIGITS ',' DIGITS
329 { $return = $item[1].','.$item[3] }
331 { $return = $item[1] }
334 nullable : /not/i /null/i
339 default_val : /default/i /null/i
341 | /default/i /'[^']*'/
342 { $item[2]=~ s/'//g; $return = $item[2] }
344 { $return = $item[2] }
346 auto_inc : /identity/i { 1 }
348 primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list
351 supertype => 'constraint',
353 type => 'primary_key',
358 foreign_key_constraint : /constraint/i index_name(?) /foreign/i /key/i parens_field_list /references/i table_name parens_field_list(?) on_delete(?) on_update(?)
361 supertype => 'constraint',
363 type => 'foreign_key',
365 reference_table => $item[7],
366 reference_fields => $item[8][0],
367 on_delete => $item[9][0],
368 on_update => $item[10][0],
372 unique_constraint : /constraint/i index_name(?) /unique/i parens_field_list
375 supertype => 'constraint',
382 unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list field_not_null(?)
385 supertype => 'constraint',
387 clustered => $item[2][0],
389 table => $item[5][0],
394 on_delete : /on delete/i reference_option
397 on_update : /on update/i reference_option
400 reference_option: /cascade/i
405 clustered : /clustered/i
412 on_table : /on/i table_name
413 { $return = $item[2] }
415 on_system : /on/i /system/i
418 index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list END_STATEMENT
421 supertype => 'index',
423 clustered => $item[1][0],
425 table => $item[4][0],
430 parens_field_list : '(' field_name(s /,/) ')'
433 ident : QUOTE WORD '.' WORD QUOTE | LQUOTE WORD '.' WORD RQUOTE
434 { $return = { owner => $item[2], name => $item[4] } }
435 | LQUOTE WORD RQUOTE '.' LQUOTE WORD RQUOTE
436 { $return = { owner => $item[2], name => $item[6] } }
438 { $return = { name => $item[2] } }
440 { $return = { owner => $item[1], name => $item[3] } }
442 { $return = { name => $item[1] } }
449 NAME : QUOTE(?) /\w+/ QUOTE(?)
467 my ( $translator, $data ) = @_;
468 my $parser = Parse::RecDescent->new($GRAMMAR);
470 local $::RD_TRACE = $translator->trace ? 1 : undef;
471 local $DEBUG = $translator->debug;
473 unless (defined $parser) {
474 return $translator->error("Error instantiating Parse::RecDescent ".
475 "instance: Bad grammer");
478 my $result = $parser->startrule($data);
479 return $translator->error( "Parse failed." ) unless defined $result;
480 warn Dumper( $result ) if $DEBUG;
482 my $schema = $translator->schema;
484 $result->{tables}->{ $a }->{'order'} <=> $result->{tables}->{ $b }->{'order'}
485 } keys %{ $result->{tables} };
487 for my $table_name ( @tables ) {
488 my $tdata = $result->{tables}->{ $table_name };
489 my $table = $schema->add_table( name => $tdata->{'name'} )
490 or die "Can't create table '$table_name': ", $schema->error;
492 $table->comments( $tdata->{'comments'} );
495 $tdata->{'fields'}->{$a}->{'order'}
497 $tdata->{'fields'}->{$b}->{'order'}
498 } keys %{ $tdata->{'fields'} };
500 for my $fname ( @fields ) {
501 my $fdata = $tdata->{'fields'}{ $fname };
502 my $field = $table->add_field(
503 name => $fdata->{'name'},
504 data_type => $fdata->{'data_type'},
505 size => $fdata->{'size'},
506 default_value => $fdata->{'default'},
507 is_auto_increment => $fdata->{'is_auto_inc'},
508 is_nullable => $fdata->{'nullable'},
509 comments => $fdata->{'comments'},
510 ) or die $table->error;
512 $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
514 for my $qual ( qw[ binary unsigned zerofill list ] ) {
515 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
516 next if ref $val eq 'ARRAY' && !@$val;
517 $field->extra( $qual, $val );
521 if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
522 my %extra = $field->extra;
524 for my $len ( map { length } @{ $extra{'list'} || [] } ) {
525 $longest = $len if $len > $longest;
527 $field->size( $longest ) if $longest;
530 for my $cdata ( @{ $fdata->{'constraints'} } ) {
531 next unless $cdata->{'type'} eq 'foreign_key';
532 $cdata->{'fields'} ||= [ $field->name ];
533 push @{ $tdata->{'constraints'} }, $cdata;
537 for my $idata ( @{ $tdata->{'indices'} || [] } ) {
538 my $index = $table->add_index(
539 name => $idata->{'name'},
540 type => uc $idata->{'type'},
541 fields => $idata->{'fields'},
542 ) or die $table->error;
545 for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
546 my $constraint = $table->add_constraint(
547 name => $cdata->{'name'},
548 type => $cdata->{'type'},
549 fields => $cdata->{'fields'},
550 reference_table => $cdata->{'reference_table'},
551 reference_fields => $cdata->{'reference_fields'},
552 match_type => $cdata->{'match_type'} || '',
553 on_delete => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
554 on_update => $cdata->{'on_update'} || $cdata->{'on_update_do'},
555 ) or die $table->error;
559 my @procedures = sort {
560 $result->{procedures}->{ $a }->{'order'} <=> $result->{procedures}->{ $b }->{'order'}
561 } keys %{ $result->{procedures} };
562 for my $proc_name (@procedures) {
563 $schema->add_procedure(
565 owner => $result->{procedures}->{$proc_name}->{owner},
566 sql => $result->{procedures}->{$proc_name}->{sql},
571 $result->{views}->{ $a }->{'order'} <=> $result->{views}->{ $b }->{'order'}
572 } keys %{ $result->{views} };
573 for my $view_name (keys %{ $result->{views} }) {
576 sql => $result->{views}->{$view_name}->{sql},
585 # -------------------------------------------------------------------
586 # Every hero becomes a bore at last.
587 # Ralph Waldo Emerson
588 # -------------------------------------------------------------------
594 Chris Hilton E<lt>chris@dctank.comE<gt> - Bulk of code from
595 Sybase parser, I just tweaked it for SQLServer. Thanks.
599 SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.