lib/SQL/Translator/Parser/SQLServer.pm

   1 package SQL::Translator::Parser::SQLServer;
   2
   3 # -------------------------------------------------------------------
   4 # $Id$
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-2009 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 = '1.99';
  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 create_view : /create/i /view/i WORD not_go GO
 221     {
 222         @table_comments = ();
 223         my $view_name = $item[3];
 224         my $sql = "$item[1] $item[2] $item[3] $item[4]";
 225
 226         $views{ $view_name }{'order'}  = ++$view_order;
 227         $views{ $view_name }{'name'}   = $view_name;
 228         $views{ $view_name }{'sql'}    = $sql;
 229     }
 230
 231 not_go : /((?!\bgo\b).)*/is
 232
 233 create_def : constraint
 234     | index
 235     | field
 236
 237 blank : /\s*/
 238
 239 field : field_name data_type field_qualifier(s?)
 240     {
 241         my %qualifiers  = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
 242         my $nullable = defined $qualifiers{'nullable'}
 243                    ? $qualifiers{'nullable'} : 1;
 244         $return = {
 245             supertype      => 'field',
 246             name           => $item{'field_name'},
 247             data_type      => $item{'data_type'}{'type'},
 248             size           => $item{'data_type'}{'size'},
 249             nullable       => $nullable,
 250             default        => $qualifiers{'default_val'},
 251             is_auto_inc    => $qualifiers{'is_auto_inc'},
 252 #            is_primary_key => $item{'primary_key'}[0],
 253         }
 254     }
 255
 256 field_qualifier : nullable
 257     {
 258         $return = {
 259              nullable => $item{'nullable'},
 260         }
 261     }
 262
 263 field_qualifier : default_val
 264     {
 265         $return = {
 266              default_val => $item{'default_val'},
 267         }
 268     }
 269
 270 field_qualifier : auto_inc
 271     {
 272         $return = {
 273              is_auto_inc => $item{'auto_inc'},
 274         }
 275     }
 276
 277 constraint : primary_key_constraint
 278     | foreign_key_constraint
 279     | unique_constraint
 280
 281 field_name : WORD
 282
 283 index_name : WORD
 284
 285 table_name : WORD
 286
 287 data_type : WORD field_size(?)
 288     {
 289         $return = {
 290             type => $item[1],
 291             size => $item[2][0]
 292         }
 293     }
 294
 295 lock : /lock/i /datarows/i
 296
 297 field_type : WORD
 298
 299 field_size : '(' num_range ')' { $item{'num_range'} }
 300
 301 num_range : DIGITS ',' DIGITS
 302     { $return = $item[1].','.$item[3] }
 303                | DIGITS
 304     { $return = $item[1] }
 305
 306
 307 nullable : /not/i /null/i
 308     { $return = 0 }
 309     | /null/i
 310     { $return = 1 }
 311
 312 default_val : /default/i /null/i
 313     { $return = 'null' }
 314         | /default/i /'[^']*'/
 315     { $item[2]=~ s/'//g; $return = $item[2] }
 316
 317 auto_inc : /identity/i { 1 }
 318
 319 primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list
 320     {
 321         $return = {
 322             supertype => 'constraint',
 323             name      => $item[2][0],
 324             type      => 'primary_key',
 325             fields    => $item[5],
 326         }
 327     }
 328
 329 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(?)
 330     {
 331         $return = {
 332             supertype        => 'constraint',
 333             name             => $item[2][0],
 334             type             => 'foreign_key',
 335             fields           => $item[5],
 336             reference_table  => $item[7],
 337             reference_fields => $item[8][0],
 338             on_delete        => $item[9][0],
 339             on_update        => $item[10][0],
 340         }
 341     }
 342
 343 unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list
 344     {
 345         $return = {
 346             supertype => 'constraint',
 347             type      => 'unique',
 348             clustered => $item[2][0],
 349             name      => $item[4][0],
 350             table     => $item[5][0],
 351             fields    => $item[6],
 352         }
 353     }
 354
 355 on_delete : /on delete/i reference_option
 356     { $item[2] }
 357
 358 on_update : /on update/i reference_option
 359     { $item[2] }
 360
 361 reference_option: /cascade/i
 362     { $item[1] }
 363     | /no action/i
 364     { $item[1] }
 365
 366 clustered : /clustered/i
 367     { $return = 1 }
 368     | /nonclustered/i
 369     { $return = 0 }
 370
 371 INDEX : /index/i
 372
 373 on_table : /on/i table_name
 374     { $return = $item[2] }
 375
 376 on_system : /on/i /system/i
 377     { $return = 1 }
 378
 379 index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list ';'
 380     {
 381         $return = {
 382             supertype => 'index',
 383             type      => 'normal',
 384             clustered => $item[1][0],
 385             name      => $item[3][0],
 386             table     => $item[4][0],
 387             fields    => $item[5],
 388         }
 389     }
 390
 391 parens_field_list : '(' field_name(s /,/) ')'
 392     { $item[2] }
 393
 394 ident : QUOTE(?) WORD '.' WORD QUOTE(?)
 395     { $return = { owner => $item[2], name => $item[4] } }
 396     | WORD
 397     { $return = { name  => $item[1] } }
 398
 399 END_STATEMENT : ';'
 400         | GO
 401
 402 GO : /^go/i
 403
 404 NAME : QUOTE(?) /\w+/ QUOTE(?)
 405     { $item[2] }
 406
 407 WORD : /[\w#]+/
 408
 409 DIGITS : /\d+/
 410
 411 COMMA : ','
 412
 413 QUOTE : /'/
 414
 415 };
 416
 417 # -------------------------------------------------------------------
 418 sub parse {
 419     my ( $translator, $data ) = @_;
 420     my $parser = Parse::RecDescent->new($GRAMMAR);
 421
 422     local $::RD_TRACE  = $translator->trace ? 1 : undef;
 423     local $DEBUG       = $translator->debug;
 424
 425     unless (defined $parser) {
 426         return $translator->error("Error instantiating Parse::RecDescent ".
 427             "instance: Bad grammer");
 428     }
 429
 430     my $result = $parser->startrule($data);
 431     return $translator->error( "Parse failed." ) unless defined $result;
 432     warn Dumper( $result ) if $DEBUG;
 433
 434     my $schema = $translator->schema;
 435     my @tables = sort {
 436         $result->{tables}->{ $a }->{'order'} <=> $result->{tables}->{ $b }->{'order'}
 437     } keys %{ $result->{tables} };
 438
 439     for my $table_name ( @tables ) {
 440         my $tdata = $result->{tables}->{ $table_name };
 441         my $table = $schema->add_table( name => $tdata->{'name'} )
 442                     or die "Can't create table '$table_name': ", $schema->error;
 443
 444         $table->comments( $tdata->{'comments'} );
 445
 446         my @fields = sort {
 447             $tdata->{'fields'}->{$a}->{'order'}
 448             <=>
 449             $tdata->{'fields'}->{$b}->{'order'}
 450         } keys %{ $tdata->{'fields'} };
 451
 452         for my $fname ( @fields ) {
 453             my $fdata = $tdata->{'fields'}{ $fname };
 454             my $field = $table->add_field(
 455                 name              => $fdata->{'name'},
 456                 data_type         => $fdata->{'data_type'},
 457                 size              => $fdata->{'size'},
 458                 default_value     => $fdata->{'default'},
 459                 is_auto_increment => $fdata->{'is_auto_inc'},
 460                 is_nullable       => $fdata->{'nullable'},
 461                 comments          => $fdata->{'comments'},
 462             ) or die $table->error;
 463
 464             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
 465
 466             for my $qual ( qw[ binary unsigned zerofill list ] ) {
 467                 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
 468                     next if ref $val eq 'ARRAY' && !@$val;
 469                     $field->extra( $qual, $val );
 470                 }
 471             }
 472
 473             if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
 474                 my %extra = $field->extra;
 475                 my $longest = 0;
 476                 for my $len ( map { length } @{ $extra{'list'} || [] } ) {
 477                     $longest = $len if $len > $longest;
 478                 }
 479                 $field->size( $longest ) if $longest;
 480             }
 481
 482             for my $cdata ( @{ $fdata->{'constraints'} } ) {
 483                 next unless $cdata->{'type'} eq 'foreign_key';
 484                 $cdata->{'fields'} ||= [ $field->name ];
 485                 push @{ $tdata->{'constraints'} }, $cdata;
 486             }
 487         }
 488
 489         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
 490             my $index  =  $table->add_index(
 491                 name   => $idata->{'name'},
 492                 type   => uc $idata->{'type'},
 493                 fields => $idata->{'fields'},
 494             ) or die $table->error;
 495         }
 496
 497         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
 498             my $constraint       =  $table->add_constraint(
 499                 name             => $cdata->{'name'},
 500                 type             => $cdata->{'type'},
 501                 fields           => $cdata->{'fields'},
 502                 reference_table  => $cdata->{'reference_table'},
 503                 reference_fields => $cdata->{'reference_fields'},
 504                 match_type       => $cdata->{'match_type'} || '',
 505                 on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
 506                 on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
 507             ) or die $table->error;
 508         }
 509     }
 510
 511     my @procedures = sort {
 512         $result->{procedures}->{ $a }->{'order'} <=> $result->{procedures}->{ $b }->{'order'}
 513     } keys %{ $result->{procedures} };
 514     for my $proc_name (@procedures) {
 515         $schema->add_procedure(
 516                 name  => $proc_name,
 517                 owner => $result->{procedures}->{$proc_name}->{owner},
 518                 sql   => $result->{procedures}->{$proc_name}->{sql},
 519                 );
 520     }
 521
 522     my @views = sort {
 523         $result->{views}->{ $a }->{'order'} <=> $result->{views}->{ $b }->{'order'}
 524     } keys %{ $result->{views} };
 525     for my $view_name (keys %{ $result->{views} }) {
 526         $schema->add_view(
 527                 name => $view_name,
 528                 sql  => $result->{views}->{$view_name}->{sql},
 529                 );
 530     }
 531
 532     return 1;
 533 }
 534
 535 1;
 536
 537 # -------------------------------------------------------------------
 538 # Every hero becomes a bore at last.
 539 # Ralph Waldo Emerson
 540 # -------------------------------------------------------------------
 541
 542 =pod
 543
 544 =head1 AUTHOR
 545
 546 Chris Hilton E<lt>chris@dctank.comE<gt> - Bulk of code from
 547 Sybase parser, I just tweaked it for SQLServer. Thanks.
 548
 549 =head1 SEE ALSO
 550
 551 SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.
 552
 553 =cut