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