Typo fixing
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / SQLServer.pm
CommitLineData
be4469ab 1package SQL::Translator::Parser::SQLServer;
2
3# -------------------------------------------------------------------
2a8fb466 4# $Id: SQLServer.pm,v 1.4 2006-05-04 20:47:07 duality72 Exp $
be4469ab 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
25SQL::Translator::Parser::SQLServer - parser for SQL Server
26
27=head1 SYNOPSIS
28
29 use SQL::Translator::Parser::SQLServer;
30
31=head1 DESCRIPTION
32
33Adapted from Parser::Sybase and mostly parses the output of
34Producer::SQLServer. The parsing is by no means complete and
35should probably be considered a work in progress.
36
37=cut
38
39use strict;
40
41use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
2a8fb466 42$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
be4469ab 43$DEBUG = 0 unless defined $DEBUG;
44
45use Data::Dumper;
46use Parse::RecDescent;
47use Exporter;
48use 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
62startrule : statement(s) eofile { \%tables }
63
64eofile : /^\Z/
65
66statement : 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
79use : /use/i WORD GO
80 { @table_comments = () }
81
82setuser : /setuser/i NAME GO
83
84if : /if/i object_not_null begin if_command end GO
85
86if_command : grant
87 | create_index
88 | create_constraint
89
90object_not_null : /object_id/i '(' ident ')' /is not null/i
91
92print : /\s*/ /print/i /.*/
93
94else : /else/i /.*/
95
96begin : /begin/i
97
98end : /end/i
99
100grant : /grant/i /[^\n]*/
101
102exec : exec_statement(s) GO
103
104exec_statement : /exec/i /[^\n]+/
105
106comment : /^\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
115comment : 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
123comment_start : m#^\s*\/\*#
124
125comment_end : m#\s*\*\/#
126
127comment_middle : m{([^*]+|\*(?!/))*}
128
129#
130# Create table.
131#
132create_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
171create_constraint : /create/i constraint
172 {
173 @table_comments = ();
174 push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
175 }
176
177create_index : /create/i index
178 {
179 @table_comments = ();
180 push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
181 }
182
183create_procedure : /create/i /procedure/i procedure_body GO
184 {
185 @table_comments = ();
186 }
187
188procedure_body : not_go(s)
189
190not_go : /((?!go).)*/
191
192create_def : constraint
193 | index
194 | field
195
196blank : /\s*/
197
198field : 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'},
7cfa0d36 210 is_auto_inc => $qualifiers{'is_auto_inc'},
be4469ab 211# is_primary_key => $item{'primary_key'}[0],
212 }
213 }
214
215field_qualifier : nullable
216 {
217 $return = {
218 nullable => $item{'nullable'},
219 }
220 }
221
222field_qualifier : default_val
223 {
224 $return = {
225 default_val => $item{'default_val'},
226 }
227 }
228
229field_qualifier : auto_inc
230 {
231 $return = {
232 is_auto_inc => $item{'auto_inc'},
233 }
234 }
235
236constraint : primary_key_constraint
237 | foreign_key_constraint
238 | unique_constraint
239
240field_name : WORD
241
242index_name : WORD
243
244table_name : WORD
245
246data_type : WORD field_size(?)
247 {
248 $return = {
249 type => $item[1],
250 size => $item[2][0]
251 }
252 }
253
254lock : /lock/i /datarows/i
255
256field_type : WORD
257
258field_size : '(' num_range ')' { $item{'num_range'} }
259
260num_range : DIGITS ',' DIGITS
261 { $return = $item[1].','.$item[3] }
262 | DIGITS
263 { $return = $item[1] }
264
265
266nullable : /not/i /null/i
267 { $return = 0 }
268 | /null/i
269 { $return = 1 }
270
2a8fb466 271default_val : /default/i /null/i
272 { $return = 'null' }
273 | /default/i /'[^']*'/
be4469ab 274 { $item[2]=~ s/'//g; $return = $item[2] }
275
276auto_inc : /identity/i { 1 }
277
278primary_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
100684f3 288foreign_key_constraint : /constraint/i index_name(?) /foreign/i /key/i parens_field_list /references/i table_name parens_field_list(?) on_delete(?) on_update(?)
be4469ab 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],
100684f3 297 on_delete => $item[9][0],
298 on_update => $item[10][0],
be4469ab 299 }
300 }
301
302unique_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
100684f3 314on_delete : /on delete/i reference_option
be4469ab 315 { $item[2] }
316
100684f3 317on_update : /on update/i reference_option
be4469ab 318 { $item[2] }
319
320reference_option: /cascade/i |
321 /no action/i
322 { $item[1] }
323
324clustered : /clustered/i
325 { $return = 1 }
326 | /nonclustered/i
327 { $return = 0 }
328
329INDEX : /index/i
330
331on_table : /on/i table_name
332 { $return = $item[2] }
333
334on_system : /on/i /system/i
335 { $return = 1 }
336
337index : 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
349parens_field_list : '(' field_name(s /,/) ')'
350 { $item[2] }
351
352ident : QUOTE(?) WORD '.' WORD QUOTE(?)
353 { $return = { owner => $item[2], name => $item[4] } }
354 | WORD
355 { $return = { name => $item[1] } }
356
357GO : /^go/i
358
359NAME : QUOTE(?) /\w+/ QUOTE(?)
360 { $item[2] }
361
362WORD : /[\w#]+/
363
364DIGITS : /\d+/
365
366COMMA : ','
367
368QUOTE : /'/
369
370};
371
372# -------------------------------------------------------------------
373sub 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'} || '',
100684f3 460 on_delete => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
461 on_update => $cdata->{'on_update'} || $cdata->{'on_update_do'},
be4469ab 462 ) or die $table->error;
463 }
464 }
465
466 return 1;
467}
468
4691;
470
471# -------------------------------------------------------------------
472# Every hero becomes a bore at last.
473# Ralph Waldo Emerson
474# -------------------------------------------------------------------
475
476=pod
477
478=head1 AUTHOR
479
480Chris Hilton E<lt>chris@dctank.comE<gt> - Bulk of code from
481Sybase parser, I just tweaked it for SQLServer. Thanks.
482
483=head1 SEE ALSO
484
485SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.
486
487=cut