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