lib/SQL/Translator/Parser/SQLServer.pm

   1 package SQL::Translator::Parser::SQLServer;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Parser::SQLServer - parser for SQL Server
   6
   7 =head1 SYNOPSIS
   8
   9   use SQL::Translator::Parser::SQLServer;
  10
  11 =head1 DESCRIPTION
  12
  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.
  16
  17 =cut
  18
  19 use strict;
  20 use warnings;
  21
  22 our $VERSION = '1.62';
  23
  24 our $DEBUG;
  25 $DEBUG   = 0 unless defined $DEBUG;
  26
  27 use Data::Dumper;
  28 use SQL::Translator::Utils qw/ddl_parser_instance/;
  29
  30 use base qw(Exporter);
  31 our @EXPORT_OK = qw(parse);
  32
  33 our $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
  49 startrule : statement(s) eofile
  50    {
  51       return {
  52          tables     => \%tables,
  53          procedures => \%procedures,
  54          views      => \%views,
  55       }
  56    }
  57
  58 eofile : /^\Z/
  59
  60 statement : 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
  76 use : /use/i NAME GO
  77     { @table_comments = () }
  78
  79 setuser : /setuser/i USERNAME GO
  80
  81 if : /if/i object_not_null begin if_command end GO
  82
  83 if_command : grant
  84     | create_index
  85     | create_constraint
  86
  87 object_not_null : /object_id/i '(' SQSTRING ')' /is not null/i
  88
  89 field_not_null : /where/i field_name /is \s+ not \s+ null/ix
  90
  91 print : /\s*/ /print/i /.*/
  92
  93 else : /else/i /.*/
  94
  95 begin : /begin/i
  96
  97 end : /end/i
  98
  99 grant : /grant/i /[^\n]*/
 100
 101 exec : exec_statement(s) GO
 102
 103 exec_statement : /exec/i /[^\n]+/
 104
 105 comment : /^\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
 114 comment : 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
 122 comment_start : m#^\s*\/\*#
 123
 124 comment_end : m#\s*\*\/#
 125
 126 comment_middle : m{([^*]+|\*(?!/))*}
 127
 128 drop : if_exists(?) /drop/i tbl_drop END_STATEMENT
 129
 130 tbl_drop : /table/i ident
 131
 132 if_exists : /if exists/i '(' /select/i 'name' /from/i 'sysobjects' /[^\)]+/ ')'
 133
 134 #
 135 # Create table.
 136 #
 137 create_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
 176 disable_constraints : if_exists(?) /alter/i /table/i ident /nocheck/i /constraint/i /all/i END_STATEMENT
 177
 178 # this is for the normal case
 179 create_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
 186 create_constraint : /create/i constraint
 187     {
 188         @table_comments = ();
 189         push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
 190     }
 191
 192
 193 create_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
 199 create_index : /create/i index
 200     {
 201         @table_comments = ();
 202         push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
 203     }
 204
 205 create_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
 218 create_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
 231 PROCEDURE : /procedure/i
 232    | /function/i
 233
 234 create_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
 245 not_go : /((?!\bgo\b).)*/is
 246
 247 create_def : constraint
 248     | index
 249     | field
 250
 251 blank : /\s*/
 252
 253 field : 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
 270 field_qualifier : nullable
 271     {
 272         $return = {
 273              nullable => $item{'nullable'},
 274         }
 275     }
 276
 277 field_qualifier : default_val
 278     {
 279         $return = {
 280              default_val => $item{'default_val'},
 281         }
 282     }
 283
 284 field_qualifier : auto_inc
 285     {
 286         $return = {
 287              is_auto_inc => $item{'auto_inc'},
 288         }
 289     }
 290
 291 constraint : primary_key_constraint
 292     | foreign_key_constraint
 293     | unique_constraint
 294
 295 field_name : NAME
 296
 297 index_name : NAME
 298
 299 table_name : NAME
 300
 301 data_type : WORD field_size(?)
 302     {
 303         $return = {
 304             type => $item[1],
 305             size => $item[2][0]
 306         }
 307     }
 308
 309 lock : /lock/i /datarows/i
 310
 311 field_type : WORD
 312
 313 field_size : '(' num_range ')' { $item{'num_range'} }
 314
 315 num_range : DIGITS ',' DIGITS
 316     { $return = $item[1].','.$item[3] }
 317                | DIGITS
 318     { $return = $item[1] }
 319
 320
 321 nullable : /not/i /null/i
 322     { $return = 0 }
 323     | /null/i
 324     { $return = 1 }
 325
 326 default_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
 333 auto_inc : /identity/i { 1 }
 334
 335 primary_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
 345 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(?)
 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
 359 unique_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
 369 unique_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
 381 on_delete : /on delete/i reference_option
 382     { $item[2] }
 383
 384 on_update : /on update/i reference_option
 385     { $item[2] }
 386
 387 reference_option: /cascade/i
 388     { $item[1] }
 389     | /no action/i
 390     { $item[1] }
 391
 392 clustered : /clustered/i
 393     { $return = 1 }
 394     | /nonclustered/i
 395     { $return = 0 }
 396
 397 INDEX : /index/i
 398
 399 on_table : /on/i table_name
 400     { $return = $item[2] }
 401
 402 on_system : /on/i /system/i
 403     { $return = 1 }
 404
 405 index : 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
 417 parens_field_list : '(' field_name(s /,/) ')'
 418     { $item[2] }
 419
 420 ident : NAME '.' NAME
 421     { $return = { owner => $item[1], name => $item[3] } }
 422     | NAME
 423     { $return = { name  => $item[1] } }
 424
 425 END_STATEMENT : ';'
 426    | GO
 427
 428 GO : /^go/i
 429
 430 USERNAME : WORD
 431     | SQSTRING
 432
 433 NAME : WORD
 434     | DQSTRING
 435     | BQSTRING
 436
 437 WORD : /[\w#]+/
 438
 439 DIGITS : /\d+/
 440
 441 COMMA : ','
 442
 443 SQSTRING : "'" <skip: ''> /(?:[^']|'')*/ "'"
 444     { ($return = $item[3]) =~ s/''/'/g }
 445
 446 DQSTRING : '"' <skip: ''> /(?:[^"]|"")+/ '"'
 447     { ($return = $item[3]) =~ s/""/"/g }
 448
 449 BQSTRING : '[' <skip: ''> /(?:[^]]|]])+/ ']'
 450     { ($return = $item[3]) =~ s/]]/]/g; }
 451
 452 END_OF_GRAMMAR
 453
 454 sub 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
 572 1;
 573
 574 # -------------------------------------------------------------------
 575 # Every hero becomes a bore at last.
 576 # Ralph Waldo Emerson
 577 # -------------------------------------------------------------------
 578
 579 =pod
 580
 581 =head1 AUTHOR
 582
 583 Chris Hilton E<lt>chris@dctank.comE<gt> - Bulk of code from
 584 Sybase parser, I just tweaked it for SQLServer. Thanks.
 585
 586 =head1 SEE ALSO
 587
 588 SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.
 589
 590 =cut