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.59';
  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 WORD GO
  77     { @table_comments = () }
  78
  79 setuser : /setuser/i NAME 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 '(' ident ')' /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 : WORD
 296    { $return = $item[1] }
 297    | LQUOTE WORD RQUOTE
 298    { $return = $item[2] }
 299
 300 index_name : WORD
 301    { $return = $item[1] }
 302    | LQUOTE WORD RQUOTE
 303    { $return = $item[2] }
 304
 305 table_name : WORD
 306  { $return = $item[1] }
 307  | LQUOTE WORD RQUOTE
 308  { $return = $item[2] }
 309
 310 data_type : WORD field_size(?)
 311     {
 312         $return = {
 313             type => $item[1],
 314             size => $item[2][0]
 315         }
 316     }
 317
 318 lock : /lock/i /datarows/i
 319
 320 field_type : WORD
 321
 322 field_size : '(' num_range ')' { $item{'num_range'} }
 323
 324 num_range : DIGITS ',' DIGITS
 325     { $return = $item[1].','.$item[3] }
 326                | DIGITS
 327     { $return = $item[1] }
 328
 329
 330 nullable : /not/i /null/i
 331     { $return = 0 }
 332     | /null/i
 333     { $return = 1 }
 334
 335 default_val : /default/i /null/i
 336     { $return = 'null' }
 337    | /default/i /'[^']*'/
 338     { $item[2]=~ s/'//g; $return = $item[2] }
 339    | /default/i WORD
 340     { $return = $item[2] }
 341
 342 auto_inc : /identity/i { 1 }
 343
 344 primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list
 345     {
 346         $return = {
 347             supertype => 'constraint',
 348             name      => $item[2][0],
 349             type      => 'primary_key',
 350             fields    => $item[5],
 351         }
 352     }
 353
 354 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(?)
 355     {
 356         $return = {
 357             supertype        => 'constraint',
 358             name             => $item[2][0],
 359             type             => 'foreign_key',
 360             fields           => $item[5],
 361             reference_table  => $item[7],
 362             reference_fields => $item[8][0],
 363             on_delete        => $item[9][0],
 364             on_update        => $item[10][0],
 365         }
 366     }
 367
 368 unique_constraint : /constraint/i index_name(?) /unique/i parens_field_list
 369     {
 370         $return = {
 371             supertype => 'constraint',
 372             type      => 'unique',
 373             name      => $item[2][0],
 374             fields    => $item[4],
 375         }
 376     }
 377
 378 unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list field_not_null(?)
 379     {
 380         $return = {
 381             supertype => 'constraint',
 382             type      => 'unique',
 383             clustered => $item[2][0],
 384             name      => $item[4][0],
 385             table     => $item[5][0],
 386             fields    => $item[6],
 387         }
 388     }
 389
 390 on_delete : /on delete/i reference_option
 391     { $item[2] }
 392
 393 on_update : /on update/i reference_option
 394     { $item[2] }
 395
 396 reference_option: /cascade/i
 397     { $item[1] }
 398     | /no action/i
 399     { $item[1] }
 400
 401 clustered : /clustered/i
 402     { $return = 1 }
 403     | /nonclustered/i
 404     { $return = 0 }
 405
 406 INDEX : /index/i
 407
 408 on_table : /on/i table_name
 409     { $return = $item[2] }
 410
 411 on_system : /on/i /system/i
 412     { $return = 1 }
 413
 414 index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list END_STATEMENT
 415     {
 416         $return = {
 417             supertype => 'index',
 418             type      => 'normal',
 419             clustered => $item[1][0],
 420             name      => $item[3][0],
 421             table     => $item[4][0],
 422             fields    => $item[5],
 423         }
 424     }
 425
 426 parens_field_list : '(' field_name(s /,/) ')'
 427     { $item[2] }
 428
 429 ident : QUOTE WORD '.' WORD QUOTE | LQUOTE WORD '.' WORD RQUOTE
 430     { $return = { owner => $item[2], name => $item[4] } }
 431     | LQUOTE WORD RQUOTE '.' LQUOTE WORD RQUOTE
 432     { $return = { owner => $item[2], name => $item[6] } }
 433     | LQUOTE WORD RQUOTE
 434     { $return = { name  => $item[2] } }
 435     | WORD '.' WORD
 436     { $return = { owner => $item[1], name => $item[3] } }
 437     | WORD
 438     { $return = { name  => $item[1] } }
 439
 440 END_STATEMENT : ';'
 441    | GO
 442
 443 GO : /^go/i
 444
 445 NAME : QUOTE(?) /\w+/ QUOTE(?)
 446     { $item[2] }
 447
 448 WORD : /[\w#]+/
 449
 450 DIGITS : /\d+/
 451
 452 COMMA : ','
 453
 454 QUOTE : /'/
 455
 456 LQUOTE : '['
 457
 458 RQUOTE : ']'
 459
 460 END_OF_GRAMMAR
 461
 462 sub parse {
 463     my ( $translator, $data ) = @_;
 464
 465     # Enable warnings within the Parse::RecDescent module.
 466     local $::RD_ERRORS = 1 unless defined $::RD_ERRORS; # Make sure the parser dies when it encounters an error
 467     local $::RD_WARN   = 1 unless defined $::RD_WARN; # Enable warnings. This will warn on unused rules &c.
 468     local $::RD_HINT   = 1 unless defined $::RD_HINT; # Give out hints to help fix problems.
 469
 470     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 471     local $DEBUG       = $translator->debug;
 472
 473     my $parser = ddl_parser_instance('SQLServer');
 474
 475     my $result = $parser->startrule($data);
 476     return $translator->error( "Parse failed." ) unless defined $result;
 477     warn Dumper( $result ) if $DEBUG;
 478
 479     my $schema = $translator->schema;
 480     my @tables = sort {
 481         $result->{tables}->{ $a }->{'order'} <=> $result->{tables}->{ $b }->{'order'}
 482     } keys %{ $result->{tables} };
 483
 484     for my $table_name ( @tables ) {
 485         my $tdata = $result->{tables}->{ $table_name };
 486         my $table = $schema->add_table( name => $tdata->{'name'} )
 487                     or die "Can't create table '$table_name': ", $schema->error;
 488
 489         $table->comments( $tdata->{'comments'} );
 490
 491         my @fields = sort {
 492             $tdata->{'fields'}->{$a}->{'order'}
 493             <=>
 494             $tdata->{'fields'}->{$b}->{'order'}
 495         } keys %{ $tdata->{'fields'} };
 496
 497         for my $fname ( @fields ) {
 498             my $fdata = $tdata->{'fields'}{ $fname };
 499             my $field = $table->add_field(
 500                 name              => $fdata->{'name'},
 501                 data_type         => $fdata->{'data_type'},
 502                 size              => $fdata->{'size'},
 503                 default_value     => $fdata->{'default'},
 504                 is_auto_increment => $fdata->{'is_auto_inc'},
 505                 is_nullable       => $fdata->{'nullable'},
 506                 comments          => $fdata->{'comments'},
 507             ) or die $table->error;
 508
 509             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 510
 511             for my $qual ( qw[ binary unsigned zerofill list ] ) {
 512                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 513                     next if ref $val eq 'ARRAY' && !@$val;
 514                     $field->extra( $qual, $val );
 515                 }
 516             }
 517
 518             if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
 519                 my %extra = $field->extra;
 520                 my $longest = 0;
 521                 for my $len ( map { length } @{ $extra{'list'} || [] } ) {
 522                     $longest = $len if $len > $longest;
 523                 }
 524                 $field->size( $longest ) if $longest;
 525             }
 526
 527             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 528                 next unless $cdata->{'type'} eq 'foreign_key';
 529                 $cdata->{'fields'} ||= [ $field->name ];
 530                 push @{ $tdata->{'constraints'} }, $cdata;
 531             }
 532         }
 533
 534         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 535             my $index  =  $table->add_index(
 536                 name   => $idata->{'name'},
 537                 type   => uc $idata->{'type'},
 538                 fields => $idata->{'fields'},
 539             ) or die $table->error;
 540         }
 541
 542         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 543             my $constraint       =  $table->add_constraint(
 544                 name             => $cdata->{'name'},
 545                 type             => $cdata->{'type'},
 546                 fields           => $cdata->{'fields'},
 547                 reference_table  => $cdata->{'reference_table'},
 548                 reference_fields => $cdata->{'reference_fields'},
 549                 match_type       => $cdata->{'match_type'} || '',
 550                 on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
 551                 on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
 552             ) or die $table->error;
 553         }
 554     }
 555
 556     my @procedures = sort {
 557         $result->{procedures}->{ $a }->{'order'} <=> $result->{procedures}->{ $b }->{'order'}
 558     } keys %{ $result->{procedures} };
 559     for my $proc_name (@procedures) {
 560       $schema->add_procedure(
 561          name  => $proc_name,
 562          owner => $result->{procedures}->{$proc_name}->{owner},
 563          sql   => $result->{procedures}->{$proc_name}->{sql},
 564       );
 565     }
 566
 567     my @views = sort {
 568         $result->{views}->{ $a }->{'order'} <=> $result->{views}->{ $b }->{'order'}
 569     } keys %{ $result->{views} };
 570     for my $view_name (keys %{ $result->{views} }) {
 571       $schema->add_view(
 572          name => $view_name,
 573          sql  => $result->{views}->{$view_name}->{sql},
 574       );
 575     }
 576
 577     return 1;
 578 }
 579
 580 1;
 581
 582 # -------------------------------------------------------------------
 583 # Every hero becomes a bore at last.
 584 # Ralph Waldo Emerson
 585 # -------------------------------------------------------------------
 586
 587 =pod
 588
 589 =head1 AUTHOR
 590
 591 Chris Hilton E<lt>chris@dctank.comE<gt> - Bulk of code from
 592 Sybase parser, I just tweaked it for SQLServer. Thanks.
 593
 594 =head1 SEE ALSO
 595
 596 SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.
 597
 598 =cut