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