1package SQL::Translator::Parser::SQLServer; 2 3=head1 NAME 4 5SQL::Translator::Parser::SQLServer - parser for SQL Server 6 7=head1 SYNOPSIS 8 9 use SQL::Translator::Parser::SQLServer; 10 11=head1 DESCRIPTION 12 13Adapted from Parser::Sybase and mostly parses the output of 14Producer::SQLServer. The parsing is by no means complete and 15should probably be considered a work in progress. 16 17=cut 18 19use strict; 20use warnings; 21 22our $VERSION = '1.62'; 23 24our $DEBUG; 25$DEBUG = 0 unless defined $DEBUG; 26 27use Data::Dumper; 28use SQL::Translator::Utils qw/ddl_parser_instance/; 29 30use base qw(Exporter); 31our @EXPORT_OK = qw(parse); 32 33our $GRAMMAR = <<'END_OF_GRAMMAR'; 34 35{ 36 my ( %tables, @table_comments, $table_order, %procedures, $proc_order, %views, $view_order ); 37 38 sub _err { 39 my $max_lines = 5; 40 my @up_to_N_lines = split (/\n/, $_[1], $max_lines + 1); 41 die sprintf ("Unable to parse line %d:\n%s\n", 42 $_[0], 43 join "\n", (map { "'$_'" } @up_to_N_lines[0..$max_lines - 1 ]), @up_to_N_lines > $max_lines ? '...' : () 44 ); 45 } 46 47} 48 49startrule : statement(s) eofile 50 { 51 return { 52 tables => \%tables, 53 procedures => \%procedures, 54 views => \%views, 55 } 56 } 57 58eofile : /^\Z/ 59 60statement : create_table 61 | create_procedure 62 | create_view 63 | create_index 64 | create_constraint 65 | comment 66 | disable_constraints 67 | drop 68 | use 69 | setuser 70 | if 71 | print 72 | grant 73 | exec 74 | /^\Z/ | { _err ($thisline, $text) } 75 76use : /use/i NAME GO 77 { @table_comments = () } 78 79setuser : /setuser/i USERNAME GO 80 81if : /if/i object_not_null begin if_command end GO 82 83if_command : grant 84 | create_index 85 | create_constraint 86 87object_not_null : /object_id/i '(' SQSTRING ')' /is not null/i 88 89field_not_null : /where/i field_name /is \s+ not \s+ null/ix 90 91print : /\s*/ /print/i /.*/ 92 93else : /else/i /.*/ 94 95begin : /begin/i 96 97end : /end/i 98 99grant : /grant/i /[^\n]*/ 100 101exec : exec_statement(s) GO 102 103exec_statement : /exec/i /[^\n]+/ 104 105comment : /^\s*(?:#|-{2}).*\n/ 106 { 107 my $comment = $item[1]; 108 $comment =~ s/^\s*(#|--)\s*//; 109 $comment =~ s/\s*$//; 110 $return = $comment; 111 push @table_comments, $comment; 112 } 113 114comment : comment_start comment_middle comment_end 115 { 116 my $comment = $item[2]; 117 $comment =~ s/^\s*|\s*$//mg; 118 $comment =~ s/^\**\s*//mg; 119 push @table_comments, $comment; 120 } 121 122comment_start : m#^\s*\/\*# 123 124comment_end : m#\s*\*\/# 125 126comment_middle : m{([^*]+|\*(?!/))*} 127 128drop : if_exists(?) /drop/i tbl_drop END_STATEMENT 129 130tbl_drop : /table/i ident 131 132if_exists : /if exists/i '(' /select/i 'name' /from/i 'sysobjects' /[^\)]+/ ')' 133 134# 135# Create table. 136# 137create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) END_STATEMENT 138 { 139 my $table_owner = $item[3]{'owner'}; 140 my $table_name = $item[3]{'name'}; 141 142 if ( @table_comments ) { 143 $tables{ $table_name }{'comments'} = [ @table_comments ]; 144 @table_comments = (); 145 } 146 147 $tables{ $table_name }{'order'} = ++$table_order; 148 $tables{ $table_name }{'name'} = $table_name; 149 $tables{ $table_name }{'owner'} = $table_owner; 150 $tables{ $table_name }{'system'} = $item[7]; 151 152 my $i = 0; 153 for my $def ( @{ $item[5] } ) { 154 if ( $def->{'supertype'} eq 'field' ) { 155 my $field_name = $def->{'name'}; 156 $tables{ $table_name }{'fields'}{ $field_name } = 157 { %$def, order => $i }; 158 $i++; 159 160 if ( $def->{'is_primary_key'} ) { 161 push @{ $tables{ $table_name }{'constraints'} }, { 162 type => 'primary_key', 163 fields => [ $field_name ], 164 }; 165 } 166 } 167 elsif ( $def->{'supertype'} eq 'constraint' ) { 168 push @{ $tables{ $table_name }{'constraints'} }, $def; 169 } 170 else { 171 push @{ $tables{ $table_name }{'indices'} }, $def; 172 } 173 } 174 } 175 176disable_constraints : if_exists(?) /alter/i /table/i ident /nocheck/i /constraint/i /all/i END_STATEMENT 177 178# this is for the normal case 179create_constraint : /create/i constraint END_STATEMENT 180 { 181 @table_comments = (); 182 push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2]; 183 } 184 185# and this is for the BEGIN/END case 186create_constraint : /create/i constraint 187 { 188 @table_comments = (); 189 push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2]; 190 } 191 192 193create_constraint : /alter/i /table/i ident /add/i foreign_key_constraint END_STATEMENT 194 { 195 push @{ $tables{ $item[3]{name} }{constraints} }, $item[5]; 196 } 197 198 199create_index : /create/i index 200 { 201 @table_comments = (); 202 push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2]; 203 } 204 205create_procedure : /create/i PROCEDURE WORD not_go GO 206 { 207 @table_comments = (); 208 my $proc_name = $item[3]; 209 my $owner = ''; 210 my $sql = "$item[1] $item[2] $proc_name $item[4]"; 211 212 $procedures{ $proc_name }{'order'} = ++$proc_order; 213 $procedures{ $proc_name }{'name'} = $proc_name; 214 $procedures{ $proc_name }{'owner'} = $owner; 215 $procedures{ $proc_name }{'sql'} = $sql; 216 } 217 218create_procedure : /create/i PROCEDURE '[' WORD '].' WORD not_go GO 219 { 220 @table_comments = (); 221 my $proc_name = $item[6]; 222 my $owner = $item[4]; 223 my $sql = "$item[1] $item[2] [$owner].$proc_name $item[7]"; 224 225 $procedures{ $proc_name }{'order'} = ++$proc_order; 226 $procedures{ $proc_name }{'name'} = $proc_name; 227 $procedures{ $proc_name }{'owner'} = $owner; 228 $procedures{ $proc_name }{'sql'} = $sql; 229 } 230 231PROCEDURE : /procedure/i 232 | /function/i 233 234create_view : /create/i /view/i WORD not_go GO 235 { 236 @table_comments = (); 237 my $view_name = $item[3]; 238 my $sql = "$item[1] $item[2] $item[3] $item[4]"; 239 240 $views{ $view_name }{'order'} = ++$view_order; 241 $views{ $view_name }{'name'} = $view_name; 242 $views{ $view_name }{'sql'} = $sql; 243 } 244 245not_go : /((?!\bgo\b).)*/is 246 247create_def : constraint 248 | index 249 | field 250 251blank : /\s*/ 252 253field : field_name data_type field_qualifier(s?) 254 { 255 my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] }; 256 my $nullable = defined $qualifiers{'nullable'} 257 ? $qualifiers{'nullable'} : 1; 258 $return = { 259 supertype => 'field', 260 name => $item{'field_name'}, 261 data_type => $item{'data_type'}{'type'}, 262 size => $item{'data_type'}{'size'}, 263 nullable => $nullable, 264 default => $qualifiers{'default_val'}, 265 is_auto_inc => $qualifiers{'is_auto_inc'}, 266# is_primary_key => $item{'primary_key'}[0], 267 } 268 } 269 270field_qualifier : nullable 271 { 272 $return = { 273 nullable => $item{'nullable'}, 274 } 275 } 276 277field_qualifier : default_val 278 { 279 $return = { 280 default_val => $item{'default_val'}, 281 } 282 } 283 284field_qualifier : auto_inc 285 { 286 $return = { 287 is_auto_inc => $item{'auto_inc'}, 288 } 289 } 290 291constraint : primary_key_constraint 292 | foreign_key_constraint 293 | unique_constraint 294 295field_name : NAME 296 297index_name : NAME 298 299table_name : NAME 300 301data_type : WORD field_size(?) 302 { 303 $return = { 304 type => $item[1], 305 size => $item[2][0] 306 } 307 } 308 309lock : /lock/i /datarows/i 310 311field_type : WORD 312 313field_size : '(' num_range ')' { $item{'num_range'} } 314 315num_range : DIGITS ',' DIGITS 316 { $return = $item[1].','.$item[3] } 317 | DIGITS 318 { $return = $item[1] } 319 320 321nullable : /not/i /null/i 322 { $return = 0 } 323 | /null/i 324 { $return = 1 } 325 326default_val : /default/i /null/i 327 { $return = 'null' } 328 | /default/i SQSTRING 329 { $return = $item[2] } 330 | /default/i WORD 331 { $return = $item[2] } 332 333auto_inc : /identity/i { 1 } 334 335primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list 336 { 337 $return = { 338 supertype => 'constraint', 339 name => $item[2][0], 340 type => 'primary_key', 341 fields => $item[5], 342 } 343 } 344 345foreign_key_constraint : /constraint/i index_name(?) /foreign/i /key/i parens_field_list /references/i table_name parens_field_list(?) on_delete(?) on_update(?) 346 { 347 $return = { 348 supertype => 'constraint', 349 name => $item[2][0], 350 type => 'foreign_key', 351 fields => $item[5], 352 reference_table => $item[7], 353 reference_fields => $item[8][0], 354 on_delete => $item[9][0], 355 on_update => $item[10][0], 356 } 357 } 358 359unique_constraint : /constraint/i index_name(?) /unique/i parens_field_list 360 { 361 $return = { 362 supertype => 'constraint', 363 type => 'unique', 364 name => $item[2][0], 365 fields => $item[4], 366 } 367 } 368 369unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list field_not_null(?) 370 { 371 $return = { 372 supertype => 'constraint', 373 type => 'unique', 374 clustered => $item[2][0], 375 name => $item[4][0], 376 table => $item[5][0], 377 fields => $item[6], 378 } 379 } 380 381on_delete : /on delete/i reference_option 382 { $item[2] } 383 384on_update : /on update/i reference_option 385 { $item[2] } 386 387reference_option: /cascade/i 388 { $item[1] } 389 | /no action/i 390 { $item[1] } 391 392clustered : /clustered/i 393 { $return = 1 } 394 | /nonclustered/i 395 { $return = 0 } 396 397INDEX : /index/i 398 399on_table : /on/i table_name 400 { $return = $item[2] } 401 402on_system : /on/i /system/i 403 { $return = 1 } 404 405index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list END_STATEMENT 406 { 407 $return = { 408 supertype => 'index', 409 type => 'normal', 410 clustered => $item[1][0], 411 name => $item[3][0], 412 table => $item[4][0], 413 fields => $item[5], 414 } 415 } 416 417parens_field_list : '(' field_name(s /,/) ')' 418 { $item[2] } 419 420ident : NAME '.' NAME 421 { $return = { owner => $item[1], name => $item[3] } } 422 | NAME 423 { $return = { name => $item[1] } } 424 425END_STATEMENT : ';' 426 | GO 427 428GO : /^go/i 429 430USERNAME : WORD 431 | SQSTRING 432 433NAME : WORD 434 | DQSTRING 435 | BQSTRING 436 437WORD : /[\w#]+/ 438 439DIGITS : /\d+/ 440 441COMMA : ',' 442 443SQSTRING : "'" <skip: ''> /(?:[^']|'')*/ "'" 444 { ($return = $item[3]) =~ s/''/'/g } 445 446DQSTRING : '"' <skip: ''> /(?:[^"]|"")+/ '"' 447 { ($return = $item[3]) =~ s/""/"/g } 448 449BQSTRING : '[' <skip: ''> /(?:[^]]|]])+/ ']' 450 { ($return = $item[3]) =~ s/]]/]/g; } 451 452END_OF_GRAMMAR 453 454sub parse { 455 my ( $translator, $data ) = @_; 456 457 # Enable warnings within the Parse::RecDescent module. 458 local $::RD_ERRORS = 1 unless defined $::RD_ERRORS; # Make sure the parser dies when it encounters an error 459 local $::RD_WARN = 1 unless defined $::RD_WARN; # Enable warnings. This will warn on unused rules &c. 460 local $::RD_HINT = 1 unless defined $::RD_HINT; # Give out hints to help fix problems. 461 462 local $::RD_TRACE = $translator->trace ? 1 : undef; 463 local $DEBUG = $translator->debug; 464 465 my $parser = ddl_parser_instance('SQLServer'); 466 467 my $result = $parser->startrule($data); 468 return $translator->error( "Parse failed." ) unless defined $result; 469 warn Dumper( $result ) if $DEBUG; 470 471 my $schema = $translator->schema; 472 my @tables = sort { 473 $result->{tables}->{ $a }->{'order'} <=> $result->{tables}->{ $b }->{'order'} 474 } keys %{ $result->{tables} }; 475 476 for my $table_name ( @tables ) { 477 my $tdata = $result->{tables}->{ $table_name }; 478 my $table = $schema->add_table( name => $tdata->{'name'} ) 479 or die "Can't create table '$table_name': ", $schema->error; 480 481 $table->comments( $tdata->{'comments'} ); 482 483 my @fields = sort { 484 $tdata->{'fields'}->{$a}->{'order'} 485 <=> 486 $tdata->{'fields'}->{$b}->{'order'} 487 } keys %{ $tdata->{'fields'} }; 488 489 for my $fname ( @fields ) { 490 my $fdata = $tdata->{'fields'}{ $fname }; 491 my $field = $table->add_field( 492 name => $fdata->{'name'}, 493 data_type => $fdata->{'data_type'}, 494 size => $fdata->{'size'}, 495 default_value => $fdata->{'default'}, 496 is_auto_increment => $fdata->{'is_auto_inc'}, 497 is_nullable => $fdata->{'nullable'}, 498 comments => $fdata->{'comments'}, 499 ) or die $table->error; 500 501 $table->primary_key( $field->name ) if $fdata->{'is_primary_key'}; 502 503 for my $qual ( qw[ binary unsigned zerofill list ] ) { 504 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) { 505 next if ref $val eq 'ARRAY' && !@$val; 506 $field->extra( $qual, $val ); 507 } 508 } 509 510 if ( $field->data_type =~ /(set|enum)/i && !$field->size ) { 511 my %extra = $field->extra; 512 my $longest = 0; 513 for my $len ( map { length } @{ $extra{'list'} || [] } ) { 514 $longest = $len if $len > $longest; 515 } 516 $field->size( $longest ) if $longest; 517 } 518 519 for my $cdata ( @{ $fdata->{'constraints'} } ) { 520 next unless $cdata->{'type'} eq 'foreign_key'; 521 $cdata->{'fields'} ||= [ $field->name ]; 522 push @{ $tdata->{'constraints'} }, $cdata; 523 } 524 } 525 526 for my $idata ( @{ $tdata->{'indices'} || [] } ) { 527 my $index = $table->add_index( 528 name => $idata->{'name'}, 529 type => uc $idata->{'type'}, 530 fields => $idata->{'fields'}, 531 ) or die $table->error; 532 } 533 534 for my $cdata ( @{ $tdata->{'constraints'} || [] } ) { 535 my $constraint = $table->add_constraint( 536 name => $cdata->{'name'}, 537 type => $cdata->{'type'}, 538 fields => $cdata->{'fields'}, 539 reference_table => $cdata->{'reference_table'}, 540 reference_fields => $cdata->{'reference_fields'}, 541 match_type => $cdata->{'match_type'} || '', 542 on_delete => $cdata->{'on_delete'} || $cdata->{'on_delete_do'}, 543 on_update => $cdata->{'on_update'} || $cdata->{'on_update_do'}, 544 ) or die $table->error; 545 } 546 } 547 548 my @procedures = sort { 549 $result->{procedures}->{ $a }->{'order'} <=> $result->{procedures}->{ $b }->{'order'} 550 } keys %{ $result->{procedures} }; 551 for my $proc_name (@procedures) { 552 $schema->add_procedure( 553 name => $proc_name, 554 owner => $result->{procedures}->{$proc_name}->{owner}, 555 sql => $result->{procedures}->{$proc_name}->{sql}, 556 ); 557 } 558 559 my @views = sort { 560 $result->{views}->{ $a }->{'order'} <=> $result->{views}->{ $b }->{'order'} 561 } keys %{ $result->{views} }; 562 for my $view_name (keys %{ $result->{views} }) { 563 $schema->add_view( 564 name => $view_name, 565 sql => $result->{views}->{$view_name}->{sql}, 566 ); 567 } 568 569 return 1; 570} 571 5721; 573 574# ------------------------------------------------------------------- 575# Every hero becomes a bore at last. 576# Ralph Waldo Emerson 577# ------------------------------------------------------------------- 578 579=pod 580 581=head1 AUTHOR 582 583Chris Hilton E<lt>chris@dctank.comE<gt> - Bulk of code from 584Sybase parser, I just tweaked it for SQLServer. Thanks. 585 586=head1 SEE ALSO 587 588SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>. 589 590=cut 591