lib/SQL/Translator/Parser/SQLServer.pm

   1 package SQL::Translator::Parser::SQLServer;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: SQLServer.pm,v 1.5 2007-03-14 17:03:52 duality72 Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =head1 NAME
  24
  25 SQL::Translator::Parser::SQLServer - parser for SQL Server
  26
  27 =head1 SYNOPSIS
  28
  29   use SQL::Translator::Parser::SQLServer;
  30
  31 =head1 DESCRIPTION
  32
  33 Adapted from Parser::Sybase and mostly parses the output of
  34 Producer::SQLServer.  The parsing is by no means complete and
  35 should probably be considered a work in progress.
  36
  37 =cut
  38
  39 use strict;
  40
  41 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
  42 $VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
  43 $DEBUG   = 0 unless defined $DEBUG;
  44
  45 use Data::Dumper;
  46 use Parse::RecDescent;
  47 use Exporter;
  48 use base qw(Exporter);
  49
  50 @EXPORT_OK = qw(parse);
  51
  52 $::RD_ERRORS = 1;
  53 $::RD_WARN   = 1;
  54 $::RD_HINT   = 1;
  55
  56 $GRAMMAR = q{
  57
  58 {
  59     my ( %tables, @table_comments, $table_order, %procedures, $proc_order, %views, $view_order );
  60 }
  61
  62 startrule : statement(s) eofile
  63         {
  64                 return {
  65                         tables     => \%tables,
  66                         procedures => \%procedures,
  67                         views      => \%views,
  68                 }
  69         }
  70
  71 eofile : /^\Z/
  72
  73 statement : create_table
  74     | create_procedure
  75     | create_view
  76     | create_index
  77     | create_constraint
  78     | comment
  79     | use
  80     | setuser
  81     | if
  82     | print
  83     | grant
  84     | exec
  85     | <error>
  86
  87 use : /use/i WORD GO
  88     { @table_comments = () }
  89
  90 setuser : /setuser/i NAME GO
  91
  92 if : /if/i object_not_null begin if_command end GO
  93
  94 if_command : grant
  95     | create_index
  96     | create_constraint
  97
  98 object_not_null : /object_id/i '(' ident ')' /is not null/i
  99
 100 print : /\s*/ /print/i /.*/
 101
 102 else : /else/i /.*/
 103
 104 begin : /begin/i
 105
 106 end : /end/i
 107
 108 grant : /grant/i /[^\n]*/
 109
 110 exec : exec_statement(s) GO
 111
 112 exec_statement : /exec/i /[^\n]+/
 113
 114 comment : /^\s*(?:#|-{2}).*\n/
 115     {
 116         my $comment =  $item[1];
 117         $comment    =~ s/^\s*(#|--)\s*//;
 118         $comment    =~ s/\s*$//;
 119         $return     = $comment;
 120         push @table_comments, $comment;
 121     }
 122
 123 comment : comment_start comment_middle comment_end
 124     {
 125         my $comment = $item[2];
 126         $comment =~ s/^\s*|\s*$//mg;
 127         $comment =~ s/^\**\s*//mg;
 128         push @table_comments, $comment;
 129     }
 130
 131 comment_start : m#^\s*\/\*#
 132
 133 comment_end : m#\s*\*\/#
 134
 135 comment_middle : m{([^*]+|\*(?!/))*}
 136
 137 #
 138 # Create table.
 139 #
 140 create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) END_STATEMENT
 141     {
 142         my $table_owner = $item[3]{'owner'};
 143         my $table_name  = $item[3]{'name'};
 144
 145         if ( @table_comments ) {
 146             $tables{ $table_name }{'comments'} = [ @table_comments ];
 147             @table_comments = ();
 148         }
 149
 150         $tables{ $table_name }{'order'}  = ++$table_order;
 151         $tables{ $table_name }{'name'}   = $table_name;
 152         $tables{ $table_name }{'owner'}  = $table_owner;
 153         $tables{ $table_name }{'system'} = $item[7];
 154
 155         my $i = 0;
 156         for my $def ( @{ $item[5] } ) {
 157             if ( $def->{'supertype'} eq 'field' ) {
 158                 my $field_name = $def->{'name'};
 159                 $tables{ $table_name }{'fields'}{ $field_name } =
 160                     { %$def, order => $i };
 161                 $i++;
 162
 163                 if ( $def->{'is_primary_key'} ) {
 164                     push @{ $tables{ $table_name }{'constraints'} }, {
 165                         type   => 'primary_key',
 166                         fields => [ $field_name ],
 167                     };
 168                 }
 169             }
 170             elsif ( $def->{'supertype'} eq 'constraint' ) {
 171                 push @{ $tables{ $table_name }{'constraints'} }, $def;
 172             }
 173             else {
 174                 push @{ $tables{ $table_name }{'indices'} }, $def;
 175             }
 176         }
 177     }
 178
 179 create_constraint : /create/i constraint
 180     {
 181         @table_comments = ();
 182         push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
 183     }
 184
 185 create_index : /create/i index
 186     {
 187         @table_comments = ();
 188         push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
 189     }
 190
 191 create_procedure : /create/i PROCEDURE WORD not_go GO
 192     {
 193         @table_comments = ();
 194         my $proc_name = $item[3];
 195         my $owner = '';
 196         my $sql = "$item[1] $item[2] $proc_name $item[4]";
 197
 198         $procedures{ $proc_name }{'order'}  = ++$proc_order;
 199         $procedures{ $proc_name }{'name'}   = $proc_name;
 200         $procedures{ $proc_name }{'owner'}  = $owner;
 201         $procedures{ $proc_name }{'sql'}    = $sql;
 202     }
 203
 204 create_procedure : /create/i PROCEDURE '[' WORD '].' WORD not_go GO
 205     {
 206         @table_comments = ();
 207         my $proc_name = $item[6];
 208         my $owner = $item[4];
 209         my $sql = "$item[1] $item[2] [$owner].$proc_name $item[7]";
 210
 211         $procedures{ $proc_name }{'order'}  = ++$proc_order;
 212         $procedures{ $proc_name }{'name'}   = $proc_name;
 213         $procedures{ $proc_name }{'owner'}  = $owner;
 214         $procedures{ $proc_name }{'sql'}    = $sql;
 215     }
 216
 217 PROCEDURE : /procedure/i
 218         | /function/i
 219
 220 procedure_body : not_go(s)
 221
 222 create_view : /create/i /view/i WORD not_go GO
 223     {
 224         @table_comments = ();
 225         my $view_name = $item[3];
 226         my $sql = "$item[1] $item[2] $item[3] $item[4]";
 227
 228         $views{ $view_name }{'order'}  = ++$view_order;
 229         $views{ $view_name }{'name'}   = $view_name;
 230         $views{ $view_name }{'sql'}    = $sql;
 231     }
 232
 233 view_body : not_go(s)
 234
 235 not_go : /((?!\bgo\b).)*/is
 236
 237 create_def : constraint
 238     | index
 239     | field
 240
 241 blank : /\s*/
 242
 243 field : field_name data_type field_qualifier(s?)
 244     {
 245         my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
 246         my $nullable = defined $qualifiers{'nullable'}
 247                    ? $qualifiers{'nullable'} : 1;
 248         $return = {
 249             supertype      => 'field',
 250             name           => $item{'field_name'},
 251             data_type      => $item{'data_type'}{'type'},
 252             size           => $item{'data_type'}{'size'},
 253             nullable       => $nullable,
 254             default        => $qualifiers{'default_val'},
 255             is_auto_inc    => $qualifiers{'is_auto_inc'},
 256 #            is_primary_key => $item{'primary_key'}[0],
 257         }
 258     }
 259
 260 field_qualifier : nullable
 261     {
 262         $return = {
 263              nullable => $item{'nullable'},
 264         }
 265     }
 266
 267 field_qualifier : default_val
 268     {
 269         $return = {
 270              default_val => $item{'default_val'},
 271         }
 272     }
 273
 274 field_qualifier : auto_inc
 275     {
 276         $return = {
 277              is_auto_inc => $item{'auto_inc'},
 278         }
 279     }
 280
 281 constraint : primary_key_constraint
 282     | foreign_key_constraint
 283     | unique_constraint
 284
 285 field_name : WORD
 286
 287 index_name : WORD
 288
 289 table_name : WORD
 290
 291 data_type : WORD field_size(?)
 292     {
 293         $return = {
 294             type => $item[1],
 295             size => $item[2][0]
 296         }
 297     }
 298
 299 lock : /lock/i /datarows/i
 300
 301 field_type : WORD
 302
 303 field_size : '(' num_range ')' { $item{'num_range'} }
 304
 305 num_range : DIGITS ',' DIGITS
 306     { $return = $item[1].','.$item[3] }
 307                | DIGITS
 308     { $return = $item[1] }
 309
 310
 311 nullable : /not/i /null/i
 312     { $return = 0 }
 313     | /null/i
 314     { $return = 1 }
 315
 316 default_val : /default/i /null/i
 317     { $return = 'null' }
 318         | /default/i /'[^']*'/
 319     { $item[2]=~ s/'//g; $return = $item[2] }
 320
 321 auto_inc : /identity/i { 1 }
 322
 323 primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list
 324     {
 325         $return = {
 326             supertype => 'constraint',
 327             name      => $item[2][0],
 328             type      => 'primary_key',
 329             fields    => $item[5],
 330         }
 331     }
 332
 333 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(?)
 334     {
 335         $return = {
 336             supertype        => 'constraint',
 337             name             => $item[2][0],
 338             type             => 'foreign_key',
 339             fields           => $item[5],
 340             reference_table  => $item[7],
 341             reference_fields => $item[8][0],
 342             on_delete        => $item[9][0],
 343             on_update        => $item[10][0],
 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 ';'
 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