projects / dbsrgits/SQL-Translator.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
use warnings
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / SQLServer.pm
CommitLineData
be4469ab 1package SQL::Translator::Parser::SQLServer;
2
be4469ab 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;
f27f9229 20use warnings;
be4469ab 21
da06ac74 22use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
11ad2df9 23$VERSION = '1.59';
be4469ab 24$DEBUG = 0 unless defined $DEBUG;
25
26use Data::Dumper;
27use Parse::RecDescent;
28use Exporter;
29use base qw(Exporter);
30
31@EXPORT_OK = qw(parse);
32
33$::RD_ERRORS = 1;
34$::RD_WARN = 1;
35$::RD_HINT = 1;
36
37$GRAMMAR = q{
38
e5f65c59 39{
ff3dd529 40 my ( %tables, @table_comments, $table_order, %procedures, $proc_order, %views, $view_order );
28224573 41
42 sub _err {
43 my $max_lines = 5;
44 my @up_to_N_lines = split (/\n/, $_[1], $max_lines + 1);
45 die sprintf ("Unable to parse line %d:\n%s\n",
46 $_[0],
47 join "\n", (map { "'$_'" } @up_to_N_lines[0..$max_lines - 1 ]), @up_to_N_lines > $max_lines ? '...' : ()
48 );
49 }
50
be4469ab 51}
52
ff3dd529 53startrule : statement(s) eofile
e5f65c59 54 {
55 return {
56 tables => \%tables,
57 procedures => \%procedures,
58 views => \%views,
59 }
60 }
be4469ab 61
62eofile : /^\Z/
63
64statement : create_table
65 | create_procedure
ff3dd529 66 | create_view
be4469ab 67 | create_index
68 | create_constraint
69 | comment
028386aa 70 | disable_constraints
e2fb9ad3 71 | drop
be4469ab 72 | use
73 | setuser
74 | if
75 | print
76 | grant
77 | exec
28224573 78 | /^\Z/ | { _err ($thisline, $text) }
be4469ab 79
e5f65c59 80use : /use/i WORD GO
be4469ab 81 { @table_comments = () }
82
83setuser : /setuser/i NAME GO
84
85if : /if/i object_not_null begin if_command end GO
86
87if_command : grant
88 | create_index
89 | create_constraint
90
91object_not_null : /object_id/i '(' ident ')' /is not null/i
92
028386aa 93field_not_null : /where/i field_name /is \s+ not \s+ null/ix
94
be4469ab 95print : /\s*/ /print/i /.*/
96
97else : /else/i /.*/
98
99begin : /begin/i
100
101end : /end/i
102
103grant : /grant/i /[^\n]*/
104
105exec : exec_statement(s) GO
106
107exec_statement : /exec/i /[^\n]+/
108
e5f65c59 109comment : /^\s*(?:#|-{2}).*\n/
110 {
be4469ab 111 my $comment = $item[1];
112 $comment =~ s/^\s*(#|--)\s*//;
113 $comment =~ s/\s*$//;
114 $return = $comment;
115 push @table_comments, $comment;
116 }
117
118comment : comment_start comment_middle comment_end
e5f65c59 119 {
be4469ab 120 my $comment = $item[2];
121 $comment =~ s/^\s*|\s*$//mg;
122 $comment =~ s/^\**\s*//mg;
123 push @table_comments, $comment;
124 }
125
126comment_start : m#^\s*\/\*#
127
128comment_end : m#\s*\*\/#
129
130comment_middle : m{([^*]+|\*(?!/))*}
131
e2fb9ad3 132drop : if_exists(?) /drop/i tbl_drop END_STATEMENT
133
028386aa 134tbl_drop : /table/i ident
e2fb9ad3 135
136if_exists : /if exists/i '(' /select/i 'name' /from/i 'sysobjects' /[^\)]+/ ')'
137
be4469ab 138#
139# Create table.
140#
ff3dd529 141create_table : /create/i /table/i ident '(' create_def(s /,/) ')' lock(?) on_system(?) END_STATEMENT
e5f65c59 142 {
be4469ab 143 my $table_owner = $item[3]{'owner'};
144 my $table_name = $item[3]{'name'};
145
146 if ( @table_comments ) {
147 $tables{ $table_name }{'comments'} = [ @table_comments ];
148 @table_comments = ();
149 }
150
151 $tables{ $table_name }{'order'} = ++$table_order;
152 $tables{ $table_name }{'name'} = $table_name;
153 $tables{ $table_name }{'owner'} = $table_owner;
154 $tables{ $table_name }{'system'} = $item[7];
155
156 my $i = 0;
157 for my $def ( @{ $item[5] } ) {
158 if ( $def->{'supertype'} eq 'field' ) {
159 my $field_name = $def->{'name'};
e5f65c59 160 $tables{ $table_name }{'fields'}{ $field_name } =
be4469ab 161 { %$def, order => $i };
162 $i++;
e5f65c59 163
be4469ab 164 if ( $def->{'is_primary_key'} ) {
165 push @{ $tables{ $table_name }{'constraints'} }, {
166 type => 'primary_key',
167 fields => [ $field_name ],
168 };
169 }
170 }
171 elsif ( $def->{'supertype'} eq 'constraint' ) {
172 push @{ $tables{ $table_name }{'constraints'} }, $def;
173 }
174 else {
175 push @{ $tables{ $table_name }{'indices'} }, $def;
176 }
177 }
178 }
179
028386aa 180disable_constraints : if_exists(?) /alter/i /table/i ident /nocheck/i /constraint/i /all/i END_STATEMENT
181
182# this is for the normal case
183create_constraint : /create/i constraint END_STATEMENT
184 {
185 @table_comments = ();
186 push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
187 }
188
189# and this is for the BEGIN/END case
f9a5ee79 190create_constraint : /create/i constraint
be4469ab 191 {
192 @table_comments = ();
193 push @{ $tables{ $item[2]{'table'} }{'constraints'} }, $item[2];
194 }
195
028386aa 196
f9a5ee79 197create_constraint : /alter/i /table/i ident /add/i foreign_key_constraint END_STATEMENT
198 {
199 push @{ $tables{ $item[3]{name} }{constraints} }, $item[5];
200 }
201
028386aa 202
be4469ab 203create_index : /create/i index
204 {
205 @table_comments = ();
206 push @{ $tables{ $item[2]{'table'} }{'indices'} }, $item[2];
207 }
208
ff3dd529 209create_procedure : /create/i PROCEDURE WORD not_go GO
be4469ab 210 {
211 @table_comments = ();
ff3dd529 212 my $proc_name = $item[3];
213 my $owner = '';
214 my $sql = "$item[1] $item[2] $proc_name $item[4]";
e5f65c59 215
ff3dd529 216 $procedures{ $proc_name }{'order'} = ++$proc_order;
217 $procedures{ $proc_name }{'name'} = $proc_name;
218 $procedures{ $proc_name }{'owner'} = $owner;
219 $procedures{ $proc_name }{'sql'} = $sql;
be4469ab 220 }
221
ff3dd529 222create_procedure : /create/i PROCEDURE '[' WORD '].' WORD not_go GO
223 {
224 @table_comments = ();
225 my $proc_name = $item[6];
226 my $owner = $item[4];
227 my $sql = "$item[1] $item[2] [$owner].$proc_name $item[7]";
e5f65c59 228
ff3dd529 229 $procedures{ $proc_name }{'order'} = ++$proc_order;
230 $procedures{ $proc_name }{'name'} = $proc_name;
231 $procedures{ $proc_name }{'owner'} = $owner;
232 $procedures{ $proc_name }{'sql'} = $sql;
233 }
234
235PROCEDURE : /procedure/i
e5f65c59 236 | /function/i
ff3dd529 237
ff3dd529 238create_view : /create/i /view/i WORD not_go GO
239 {
240 @table_comments = ();
241 my $view_name = $item[3];
242 my $sql = "$item[1] $item[2] $item[3] $item[4]";
e5f65c59 243
ff3dd529 244 $views{ $view_name }{'order'} = ++$view_order;
245 $views{ $view_name }{'name'} = $view_name;
246 $views{ $view_name }{'sql'} = $sql;
247 }
248
ff3dd529 249not_go : /((?!\bgo\b).)*/is
be4469ab 250
251create_def : constraint
252 | index
253 | field
254
255blank : /\s*/
256
257field : field_name data_type field_qualifier(s?)
e5f65c59 258 {
be4469ab 259 my %qualifiers = map { %$_ } @{ $item{'field_qualifier(s?)'} || [] };
e5f65c59 260 my $nullable = defined $qualifiers{'nullable'}
be4469ab 261 ? $qualifiers{'nullable'} : 1;
e5f65c59 262 $return = {
be4469ab 263 supertype => 'field',
e5f65c59 264 name => $item{'field_name'},
be4469ab 265 data_type => $item{'data_type'}{'type'},
266 size => $item{'data_type'}{'size'},
e5f65c59 267 nullable => $nullable,
268 default => $qualifiers{'default_val'},
269 is_auto_inc => $qualifiers{'is_auto_inc'},
270# is_primary_key => $item{'primary_key'}[0],
271 }
be4469ab 272 }
273
274field_qualifier : nullable
e5f65c59 275 {
276 $return = {
be4469ab 277 nullable => $item{'nullable'},
e5f65c59 278 }
be4469ab 279 }
280
281field_qualifier : default_val
e5f65c59 282 {
283 $return = {
be4469ab 284 default_val => $item{'default_val'},
e5f65c59 285 }
be4469ab 286 }
287
288field_qualifier : auto_inc
e5f65c59 289 {
290 $return = {
be4469ab 291 is_auto_inc => $item{'auto_inc'},
e5f65c59 292 }
be4469ab 293 }
294
295constraint : primary_key_constraint
296 | foreign_key_constraint
297 | unique_constraint
298
299field_name : WORD
028386aa 300 { $return = $item[1] }
301 | LQUOTE WORD RQUOTE
302 { $return = $item[2] }
be4469ab 303
304index_name : WORD
028386aa 305 { $return = $item[1] }
306 | LQUOTE WORD RQUOTE
307 { $return = $item[2] }
be4469ab 308
309table_name : WORD
028386aa 310 { $return = $item[1] }
311 | LQUOTE WORD RQUOTE
312 { $return = $item[2] }
be4469ab 313
e5f65c59 314data_type : WORD field_size(?)
315 {
316 $return = {
317 type => $item[1],
be4469ab 318 size => $item[2][0]
e5f65c59 319 }
be4469ab 320 }
321
322lock : /lock/i /datarows/i
323
324field_type : WORD
325
326field_size : '(' num_range ')' { $item{'num_range'} }
327
328num_range : DIGITS ',' DIGITS
329 { $return = $item[1].','.$item[3] }
330 | DIGITS
331 { $return = $item[1] }
332
333
334nullable : /not/i /null/i
335 { $return = 0 }
336 | /null/i
337 { $return = 1 }
338
2a8fb466 339default_val : /default/i /null/i
340 { $return = 'null' }
e5f65c59 341 | /default/i /'[^']*'/
be4469ab 342 { $item[2]=~ s/'//g; $return = $item[2] }
e5f65c59 343 | /default/i WORD
06baeb21 344 { $return = $item[2] }
be4469ab 345
346auto_inc : /identity/i { 1 }
347
348primary_key_constraint : /constraint/i index_name(?) /primary/i /key/i parens_field_list
e5f65c59 349 {
350 $return = {
be4469ab 351 supertype => 'constraint',
352 name => $item[2][0],
353 type => 'primary_key',
354 fields => $item[5],
e5f65c59 355 }
be4469ab 356 }
357
100684f3 358foreign_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 359 {
e5f65c59 360 $return = {
be4469ab 361 supertype => 'constraint',
362 name => $item[2][0],
363 type => 'foreign_key',
364 fields => $item[5],
365 reference_table => $item[7],
e5f65c59 366 reference_fields => $item[8][0],
100684f3 367 on_delete => $item[9][0],
368 on_update => $item[10][0],
e5f65c59 369 }
be4469ab 370 }
371
e2fb9ad3 372unique_constraint : /constraint/i index_name(?) /unique/i parens_field_list
373 {
e5f65c59 374 $return = {
e2fb9ad3 375 supertype => 'constraint',
376 type => 'unique',
377 name => $item[2][0],
378 fields => $item[4],
379 }
380 }
381
028386aa 382unique_constraint : /unique/i clustered(?) INDEX(?) index_name(?) on_table(?) parens_field_list field_not_null(?)
e5f65c59 383 {
384 $return = {
be4469ab 385 supertype => 'constraint',
386 type => 'unique',
387 clustered => $item[2][0],
388 name => $item[4][0],
389 table => $item[5][0],
390 fields => $item[6],
e5f65c59 391 }
be4469ab 392 }
393
100684f3 394on_delete : /on delete/i reference_option
be4469ab 395 { $item[2] }
396
100684f3 397on_update : /on update/i reference_option
be4469ab 398 { $item[2] }
399
ff3dd529 400reference_option: /cascade/i
401 { $item[1] }
402 | /no action/i
403 { $item[1] }
be4469ab 404
405clustered : /clustered/i
406 { $return = 1 }
407 | /nonclustered/i
408 { $return = 0 }
409
410INDEX : /index/i
411
412on_table : /on/i table_name
413 { $return = $item[2] }
414
415on_system : /on/i /system/i
416 { $return = 1 }
417
e2fb9ad3 418index : clustered(?) INDEX index_name(?) on_table(?) parens_field_list END_STATEMENT
e5f65c59 419 {
420 $return = {
be4469ab 421 supertype => 'index',
422 type => 'normal',
423 clustered => $item[1][0],
424 name => $item[3][0],
425 table => $item[4][0],
426 fields => $item[5],
e5f65c59 427 }
be4469ab 428 }
429
430parens_field_list : '(' field_name(s /,/) ')'
431 { $item[2] }
432
028386aa 433ident : QUOTE WORD '.' WORD QUOTE | LQUOTE WORD '.' WORD RQUOTE
be4469ab 434 { $return = { owner => $item[2], name => $item[4] } }
028386aa 435 | LQUOTE WORD RQUOTE '.' LQUOTE WORD RQUOTE
436 { $return = { owner => $item[2], name => $item[6] } }
437 | LQUOTE WORD RQUOTE
438 { $return = { name => $item[2] } }
439 | WORD '.' WORD
440 { $return = { owner => $item[1], name => $item[3] } }
be4469ab 441 | WORD
442 { $return = { name => $item[1] } }
443
ff3dd529 444END_STATEMENT : ';'
e5f65c59 445 | GO
ff3dd529 446
be4469ab 447GO : /^go/i
448
449NAME : QUOTE(?) /\w+/ QUOTE(?)
450 { $item[2] }
451
452WORD : /[\w#]+/
453
454DIGITS : /\d+/
455
456COMMA : ','
457
458QUOTE : /'/
459
028386aa 460LQUOTE : '['
461
462RQUOTE : ']'
463
be4469ab 464};
465
be4469ab 466sub parse {
467 my ( $translator, $data ) = @_;
468 my $parser = Parse::RecDescent->new($GRAMMAR);
469
470 local $::RD_TRACE = $translator->trace ? 1 : undef;
471 local $DEBUG = $translator->debug;
472
473 unless (defined $parser) {
474 return $translator->error("Error instantiating Parse::RecDescent ".
475 "instance: Bad grammer");
476 }
477
478 my $result = $parser->startrule($data);
479 return $translator->error( "Parse failed." ) unless defined $result;
480 warn Dumper( $result ) if $DEBUG;
481
482 my $schema = $translator->schema;
e5f65c59 483 my @tables = sort {
ff3dd529 484 $result->{tables}->{ $a }->{'order'} <=> $result->{tables}->{ $b }->{'order'}
485 } keys %{ $result->{tables} };
be4469ab 486
487 for my $table_name ( @tables ) {
ff3dd529 488 my $tdata = $result->{tables}->{ $table_name };
e5f65c59 489 my $table = $schema->add_table( name => $tdata->{'name'} )
be4469ab 490 or die "Can't create table '$table_name': ", $schema->error;
491
492 $table->comments( $tdata->{'comments'} );
493
e5f65c59 494 my @fields = sort {
495 $tdata->{'fields'}->{$a}->{'order'}
be4469ab 496 <=>
497 $tdata->{'fields'}->{$b}->{'order'}
498 } keys %{ $tdata->{'fields'} };
499
500 for my $fname ( @fields ) {
501 my $fdata = $tdata->{'fields'}{ $fname };
502 my $field = $table->add_field(
503 name => $fdata->{'name'},
504 data_type => $fdata->{'data_type'},
505 size => $fdata->{'size'},
506 default_value => $fdata->{'default'},
507 is_auto_increment => $fdata->{'is_auto_inc'},
508 is_nullable => $fdata->{'nullable'},
509 comments => $fdata->{'comments'},
510 ) or die $table->error;
511
512 $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
513
514 for my $qual ( qw[ binary unsigned zerofill list ] ) {
515 if ( my $val = $fdata->{ $qual } || $fdata->{ uc $qual } ) {
516 next if ref $val eq 'ARRAY' && !@$val;
517 $field->extra( $qual, $val );
518 }
519 }
520
521 if ( $field->data_type =~ /(set|enum)/i && !$field->size ) {
522 my %extra = $field->extra;
523 my $longest = 0;
524 for my $len ( map { length } @{ $extra{'list'} || [] } ) {
525 $longest = $len if $len > $longest;
526 }
527 $field->size( $longest ) if $longest;
528 }
529
530 for my $cdata ( @{ $fdata->{'constraints'} } ) {
531 next unless $cdata->{'type'} eq 'foreign_key';
532 $cdata->{'fields'} ||= [ $field->name ];
533 push @{ $tdata->{'constraints'} }, $cdata;
534 }
535 }
536
537 for my $idata ( @{ $tdata->{'indices'} || [] } ) {
538 my $index = $table->add_index(
539 name => $idata->{'name'},
540 type => uc $idata->{'type'},
541 fields => $idata->{'fields'},
542 ) or die $table->error;
543 }
544
545 for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
546 my $constraint = $table->add_constraint(
547 name => $cdata->{'name'},
548 type => $cdata->{'type'},
549 fields => $cdata->{'fields'},
550 reference_table => $cdata->{'reference_table'},
551 reference_fields => $cdata->{'reference_fields'},
552 match_type => $cdata->{'match_type'} || '',
100684f3 553 on_delete => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
554 on_update => $cdata->{'on_update'} || $cdata->{'on_update_do'},
be4469ab 555 ) or die $table->error;
556 }
557 }
e5f65c59 558
559 my @procedures = sort {
ff3dd529 560 $result->{procedures}->{ $a }->{'order'} <=> $result->{procedures}->{ $b }->{'order'}
561 } keys %{ $result->{procedures} };
562 for my $proc_name (@procedures) {
e5f65c59 563 $schema->add_procedure(
564 name => $proc_name,
565 owner => $result->{procedures}->{$proc_name}->{owner},
566 sql => $result->{procedures}->{$proc_name}->{sql},
567 );
ff3dd529 568 }
569
e5f65c59 570 my @views = sort {
ff3dd529 571 $result->{views}->{ $a }->{'order'} <=> $result->{views}->{ $b }->{'order'}
572 } keys %{ $result->{views} };
573 for my $view_name (keys %{ $result->{views} }) {
e5f65c59 574 $schema->add_view(
575 name => $view_name,
576 sql => $result->{views}->{$view_name}->{sql},
577 );
ff3dd529 578 }
be4469ab 579
580 return 1;
581}
582
5831;
584
585# -------------------------------------------------------------------
586# Every hero becomes a bore at last.
587# Ralph Waldo Emerson
588# -------------------------------------------------------------------
589
590=pod
591
592=head1 AUTHOR
593
594Chris Hilton E<lt>chris@dctank.comE<gt> - Bulk of code from
595Sybase parser, I just tweaked it for SQLServer. Thanks.
596
597=head1 SEE ALSO
598
599SQL::Translator, SQL::Translator::Parser::DBI, L<http://www.midsomer.org/>.
600
601=cut
DDL Tool (dbsrgits@git.shadowcat.co.uk:SQL-Translator.git)