1package SQL::Translator::Parser::SQLServer;
2
3=head1 NAME
4
5SQL::Translator::Parser::SQLServer - parser for SQL Server
6
7=head1 SYNOPSIS
8
9  use SQL::Translator::Parser::SQLServer;
10
11=head1 DESCRIPTION
12
13Adapted from Parser::Sybase and mostly parses the output of
14Producer::SQLServer.  The parsing is by no means complete and
15should probably be considered a work in progress.
16
17=cut
18
19use strict;
20use warnings;
21
22our $VERSION = '1.62';
23
24our $DEBUG;
25$DEBUG   = 0 unless defined $DEBUG;
26
27use Data::Dumper;
28use SQL::Translator::Utils qw/ddl_parser_instance/;
29
30use base qw(Exporter);
31our @EXPORT_OK = qw(parse);
32
33our $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
49startrule : statement(s) eofile
50   {
51      return {
52         tables     => \%tables,
53         procedures => \%procedures,
54         views      => \%views,
55      }
56   }
57
58eofile : /^\Z/
59
60statement : 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
76use : /use/i NAME GO
77    { @table_comments = () }
78
79setuser : /setuser/i USERNAME GO
80
81if : /if/i object_not_null begin if_command end GO
82
83if_command : grant
84    | create_index
85    | create_constraint
86
87object_not_null : /object_id/i '(' SQSTRING ')' /is not null/i
88
89field_not_null : /where/i field_name /is \s+ not \s+ null/ix
90
91print : /\s*/ /print/i /.*/
92
93else : /else/i /.*/
94
95begin : /begin/i
96
97end : /end/i
98
99grant : /grant/i /[^\n]*/
100
101exec : exec_statement(s) GO
102
103exec_statement : /exec/i /[^\n]+/
104
105comment : /^\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
114comment : 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
122comment_start : m#^\s*\/\*#
123
124comment_end : m#\s*\*\/#
125
126comment_middle : m{([^*]+|\*(?!/))*}
127
128drop : if_exists(?) /drop/i tbl_drop END_STATEMENT
129
130tbl_drop : /table/i ident
131
132if_exists : /if exists/i '(' /select/i 'name' /from/i 'sysobjects' /[^\)]+/ ')'
133
134#
135# Create table.
136#
137create_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
176disable_constraints : if_exists(?) /alter/i /table/i ident /nocheck/i /constraint/i /all/i END_STATEMENT
177
178# this is for the normal case
179create_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
186create_constraint : /create/i constraint
187    {
188        @table_comments = ();
189        push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
190    }
191
192
193create_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
199create_index : /create/i index
200    {
201        @table_comments = ();
202        push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
203    }
204
205create_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
218create_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
231PROCEDURE : /procedure/i
232   | /function/i
233
234create_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
245not_go : /((?!\bgo\b).)*/is
246
247create_def : constraint
248    | index
249    | field
250
251blank : /\s*/
252
253field : 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
270field_qualifier : nullable
271    {
272        $return = {
273             nullable => $item{'nullable'},
274        }
275    }
276
277field_qualifier : default_val
278    {
279        $return = {
280             default_val => $item{'default_val'},
281        }
282    }
283
284field_qualifier : auto_inc
285    {
286        $return = {
287             is_auto_inc => $item{'auto_inc'},
288        }
289    }
290
291constraint : primary_key_constraint
292    | foreign_key_constraint
293    | unique_constraint
294
295field_name : NAME
296
297index_name : NAME
298
299table_name : NAME
300
301data_type : WORD field_size(?)
302    {
303        $return = {
304            type => $item[1],
305            size => $item[2][0]
306        }
307    }
308
309lock : /lock/i /datarows/i
310
311field_type : WORD
312
313field_size : '(' num_range ')' { $item{'num_range'} }
314
315num_range : DIGITS ',' DIGITS
316    { $return = $item[1].','.$item[3] }
317               | DIGITS
318    { $return = $item[1] }
319
320
321nullable : /not/i /null/i
322    { $return = 0 }
323    | /null/i
324    { $return = 1 }
325
326default_val : /default/i /null/i
327    { $return = 'null' }
328   | /default/i SQSTRING
329    { $return = $item[2] }
330   | /default/i WORD
331    { $return = $item[2] }
332
333auto_inc : /identity/i { 1 }
334
335primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list
336    {
337        $return = {
338            supertype => 'constraint',
339            name      => $item[2][0],
340            type      => 'primary_key',
341            fields    => $item[5],
342        }
343    }
344
345foreign_key_constraint : /constraint/i index_name(?) /foreign/i /key/i parens_field_list /references/i table_name parens_field_list(?) on_delete(?) on_update(?)
346    {
347        $return = {
348            supertype        => 'constraint',
349            name             => $item[2][0],
350            type             => 'foreign_key',
351            fields           => $item[5],
352            reference_table  => $item[7],
353            reference_fields => $item[8][0],
354            on_delete        => $item[9][0],
355            on_update        => $item[10][0],
356        }
357    }
358
359unique_constraint : /constraint/i index_name(?) /unique/i parens_field_list
360    {
361        $return = {
362            supertype => 'constraint',
363            type      => 'unique',
364            name      => $item[2][0],
365            fields    => $item[4],
366        }
367    }
368
369unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list field_not_null(?)
370    {
371        $return = {
372            supertype => 'constraint',
373            type      => 'unique',
374            clustered => $item[2][0],
375            name      => $item[4][0],
376            table     => $item[5][0],
377            fields    => $item[6],
378        }
379    }
380
381on_delete : /on delete/i reference_option
382    { $item[2] }
383
384on_update : /on update/i reference_option
385    { $item[2] }
386
387reference_option: /cascade/i
388    { $item[1] }
389    | /no action/i
390    { $item[1] }
391
392clustered : /clustered/i
393    { $return = 1 }
394    | /nonclustered/i
395    { $return = 0 }
396
397INDEX : /index/i
398
399on_table : /on/i table_name
400    { $return = $item[2] }
401
402on_system : /on/i /system/i
403    { $return = 1 }
404
405index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list END_STATEMENT
406    {
407        $return = {
408            supertype => 'index',
409            type      => 'normal',
410            clustered => $item[1][0],
411            name      => $item[3][0],
412            table     => $item[4][0],
413            fields    => $item[5],
414        }
415    }
416
417parens_field_list : '(' field_name(s /,/) ')'
418    { $item[2] }
419
420ident : NAME '.' NAME
421    { $return = { owner => $item[1], name => $item[3] } }
422    | NAME
423    { $return = { name  => $item[1] } }
424
425END_STATEMENT : ';'
426   | GO
427
428GO : /^go/i
429
430USERNAME : WORD
431    | SQSTRING
432
433NAME : WORD
434    | DQSTRING
435    | BQSTRING
436
437WORD : /[\w#]+/
438
439DIGITS : /\d+/
440
441COMMA : ','
442
443SQSTRING : "'" <skip: ''> /(?:[^']|'')*/ "'"
444    { ($return = $item[3]) =~ s/''/'/g }
445
446DQSTRING : '"' <skip: ''> /(?:[^"]|"")+/ '"'
447    { ($return = $item[3]) =~ s/""/"/g }
448
449BQSTRING : '[' <skip: ''> /(?:[^]]|]])+/ ']'
450    { ($return = $item[3]) =~ s/]]/]/g; }
451
452END_OF_GRAMMAR
453
454sub parse {
455    my ( $translator, $data ) = @_;
456
457    # Enable warnings within the Parse::RecDescent module.
458    local $::RD_ERRORS = 1 unless defined $::RD_ERRORS; # Make sure the parser dies when it encounters an error
459    local $::RD_WARN   = 1 unless defined $::RD_WARN; # Enable warnings. This will warn on unused rules &c.
460    local $::RD_HINT   = 1 unless defined $::RD_HINT; # Give out hints to help fix problems.
461
462    local $::RD_TRACE  = $translator->trace ? 1 : undef;
463    local $DEBUG       = $translator->debug;
464
465    my $parser = ddl_parser_instance('SQLServer');
466
467    my $result = $parser->startrule($data);
468    return $translator->error( "Parse failed." ) unless defined $result;
469    warn Dumper( $result ) if $DEBUG;
470
471    my $schema = $translator->schema;
472    my @tables = sort {
473        $result->{tables}->{ $a }->{'order'} <=> $result->{tables}->{ $b }->{'order'}
474    } keys %{ $result->{tables} };
475
476    for my $table_name ( @tables ) {
477        my $tdata = $result->{tables}->{ $table_name };
478        my $table = $schema->add_table( name => $tdata->{'name'} )
479                    or die "Can't create table '$table_name': ", $schema->error;
480
481        $table->comments( $tdata->{'comments'} );
482
483        my @fields = sort {
484            $tdata->{'fields'}->{$a}->{'order'}
485            <=>
486            $tdata->{'fields'}->{$b}->{'order'}
487        } keys %{ $tdata->{'fields'} };
488
489        for my $fname ( @fields ) {
490            my $fdata = $tdata->{'fields'}{ $fname };
491            my $field = $table->add_field(
492                name              => $fdata->{'name'},
493                data_type         => $fdata->{'data_type'},
494                size              => $fdata->{'size'},
495                default_value     => $fdata->{'default'},
496                is_auto_increment => $fdata->{'is_auto_inc'},
497                is_nullable       => $fdata->{'nullable'},
498                comments          => $fdata->{'comments'},
499            ) or die $table->error;
500
501            $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
502
503            for my $qual ( qw[ binary unsigned zerofill list ] ) {
504                if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
505                    next if ref $val eq 'ARRAY' && !@$val;
506                    $field->extra( $qual, $val );
507                }
508            }
509
510            if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
511                my %extra = $field->extra;
512                my $longest = 0;
513                for my $len ( map { length } @{ $extra{'list'} || [] } ) {
514                    $longest = $len if $len > $longest;
515                }
516                $field->size( $longest ) if $longest;
517            }
518
519            for my $cdata ( @{ $fdata->{'constraints'} } ) {
520                next unless $cdata->{'type'} eq 'foreign_key';
521                $cdata->{'fields'} ||= [ $field->name ];
522                push @{ $tdata->{'constraints'} }, $cdata;
523            }
524        }
525
526        for my $idata ( @{ $tdata->{'indices'} || [] } ) {
527            my $index  =  $table->add_index(
528                name   => $idata->{'name'},
529                type   => uc $idata->{'type'},
530                fields => $idata->{'fields'},
531            ) or die $table->error;
532        }
533
534        for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
535            my $constraint       =  $table->add_constraint(
536                name             => $cdata->{'name'},
537                type             => $cdata->{'type'},
538                fields           => $cdata->{'fields'},
539                reference_table  => $cdata->{'reference_table'},
540                reference_fields => $cdata->{'reference_fields'},
541                match_type       => $cdata->{'match_type'} || '',
542                on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
543                on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
544            ) or die $table->error;
545        }
546    }
547
548    my @procedures = sort {
549        $result->{procedures}->{ $a }->{'order'} <=> $result->{procedures}->{ $b }->{'order'}
550    } keys %{ $result->{procedures} };
551    for my $proc_name (@procedures) {
552      $schema->add_procedure(
553         name  => $proc_name,
554         owner => $result->{procedures}->{$proc_name}->{owner},
555         sql   => $result->{procedures}->{$proc_name}->{sql},
556      );
557    }
558
559    my @views = sort {
560        $result->{views}->{ $a }->{'order'} <=> $result->{views}->{ $b }->{'order'}
561    } keys %{ $result->{views} };
562    for my $view_name (keys %{ $result->{views} }) {
563      $schema->add_view(
564         name => $view_name,
565         sql  => $result->{views}->{$view_name}->{sql},
566      );
567    }
568
569    return 1;
570}
571
5721;
573
574# -------------------------------------------------------------------
575# Every hero becomes a bore at last.
576# Ralph Waldo Emerson
577# -------------------------------------------------------------------
578
579=pod
580
581=head1 AUTHOR
582
583Chris Hilton E<lt>chris@dctank.comE<gt> - Bulk of code from
584Sybase parser, I just tweaked it for SQLServer. Thanks.
585
586=head1 SEE ALSO
587
588SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.
589
590=cut
591