Allow embedded comments a la the PG parser, store the comments; also strip
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / PostgreSQL.pm
CommitLineData
84012a55 1package SQL::Translator::Parser::PostgreSQL;
4422e22a 2
3# -------------------------------------------------------------------
1bbd4a2b 4# $Id: PostgreSQL.pm,v 1.21 2003-07-11 15:22:45 kycl4rk Exp $
4422e22a 5# -------------------------------------------------------------------
6# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
0efb6e1b 7# Allen Day <allenday@users.sourceforge.net>,
4422e22a 8# darren chamberlain <darren@cpan.org>,
9# Chris Mungall <cjm@fruitfly.org>
10#
11# This program is free software; you can redistribute it and/or
12# modify it under the terms of the GNU General Public License as
13# published by the Free Software Foundation; version 2.
14#
15# This program is distributed in the hope that it will be useful, but
16# WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18# General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
0efb6e1b 22# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
4422e22a 23# 02111-1307 USA
24# -------------------------------------------------------------------
25
26=head1 NAME
27
84012a55 28SQL::Translator::Parser::PostgreSQL - parser for PostgreSQL
4422e22a 29
30=head1 SYNOPSIS
31
32 use SQL::Translator;
84012a55 33 use SQL::Translator::Parser::PostgreSQL;
4422e22a 34
35 my $translator = SQL::Translator->new;
84012a55 36 $translator->parser("SQL::Translator::Parser::PostgreSQL");
4422e22a 37
38=head1 DESCRIPTION
39
0efb6e1b 40The grammar was started from the MySQL parsers. Here is the description
41from PostgreSQL:
42
43Table:
629b76f9 44(http://www.postgresql.org/docs/view.php?version=7.3&idoc=1&file=sql-createtable.html)
45
46 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
47 { column_name data_type [ DEFAULT default_expr ]
48 [ column_constraint [, ... ] ]
49 | table_constraint } [, ... ]
50 )
51 [ INHERITS ( parent_table [, ... ] ) ]
52 [ WITH OIDS | WITHOUT OIDS ]
53
54 where column_constraint is:
55
56 [ CONSTRAINT constraint_name ]
57 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
58 CHECK (expression) |
59 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
60 [ ON DELETE action ] [ ON UPDATE action ] }
61 [ DEFERRABLE | NOT DEFERRABLE ]
62 [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
63
64 and table_constraint is:
65
66 [ CONSTRAINT constraint_name ]
67 { UNIQUE ( column_name [, ... ] ) |
68 PRIMARY KEY ( column_name [, ... ] ) |
69 CHECK ( expression ) |
70 FOREIGN KEY ( column_name [, ... ] )
71 REFERENCES reftable [ ( refcolumn [, ... ] ) ]
72 [ MATCH FULL | MATCH PARTIAL ]
73 [ ON DELETE action ] [ ON UPDATE action ] }
74 [ DEFERRABLE | NOT DEFERRABLE ]
75 [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
0efb6e1b 76
77Index:
629b76f9 78(http://www.postgresql.org/docs/view.php?version=7.3&idoc=1&file=sql-createindex.html)
0efb6e1b 79
629b76f9 80 CREATE [ UNIQUE ] INDEX index_name ON table
81 [ USING acc_method ] ( column [ ops_name ] [, ...] )
82 [ WHERE predicate ]
83 CREATE [ UNIQUE ] INDEX index_name ON table
84 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
85 [ WHERE predicate ]
4422e22a 86
0012a163 87Alter table:
88
89 ALTER TABLE [ ONLY ] table [ * ]
90 ADD [ COLUMN ] column type [ column_constraint [ ... ] ]
91 ALTER TABLE [ ONLY ] table [ * ]
92 ALTER [ COLUMN ] column { SET DEFAULT value | DROP DEFAULT }
93 ALTER TABLE [ ONLY ] table [ * ]
94 ALTER [ COLUMN ] column SET STATISTICS integer
95 ALTER TABLE [ ONLY ] table [ * ]
96 RENAME [ COLUMN ] column TO newcolumn
97 ALTER TABLE table
98 RENAME TO new_table
99 ALTER TABLE table
100 ADD table_constraint_definition
101 ALTER TABLE [ ONLY ] table
102 DROP CONSTRAINT constraint { RESTRICT | CASCADE }
103 ALTER TABLE table
104 OWNER TO new_owner
105
3022f45b 106View table:
107
108 CREATE [ OR REPLACE ] VIEW view [ ( column name list ) ] AS SELECT query
109
4422e22a 110=cut
111
112use strict;
113use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
1bbd4a2b 114$VERSION = sprintf "%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/;
4422e22a 115$DEBUG = 0 unless defined $DEBUG;
116
117use Data::Dumper;
118use Parse::RecDescent;
119use Exporter;
120use base qw(Exporter);
121
122@EXPORT_OK = qw(parse);
123
124# Enable warnings within the Parse::RecDescent module.
125$::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
126$::RD_WARN = 1; # Enable warnings. This will warn on unused rules &c.
127$::RD_HINT = 1; # Give out hints to help fix problems.
128
129my $parser; # should we do this? There's no programmic way to
130 # change the grammar, so I think this is safe.
131
132$GRAMMAR = q!
133
0efb6e1b 134{ our ( %tables, $table_order ) }
4422e22a 135
629b76f9 136#
137# The "eofile" rule makes the parser fail if any "statement" rule
138# fails. Otherwise, the first successful match by a "statement"
139# won't cause the failure needed to know that the parse, as a whole,
140# failed. -ky
141#
0efb6e1b 142startrule : statement(s) eofile { \%tables }
4422e22a 143
0efb6e1b 144eofile : /^\Z/
145
146statement : create
147 | comment
0012a163 148 | alter
0efb6e1b 149 | grant
150 | revoke
4422e22a 151 | drop
4d2da1f7 152 | insert
0efb6e1b 153 | connect
4d2da1f7 154 | update
0012a163 155 | set
4422e22a 156 | <error>
157
0efb6e1b 158connect : /^\s*\\\connect.*\n/
159
0012a163 160set : /SET/ /[^;]*/ ';'
161
2574969e 162revoke : /revoke/i WORD(s /,/) /on/i /table/i table_name /from/i name_with_opt_quotes(s /,/) ';'
0efb6e1b 163 {
164 my $table_name = $item{'table_name'};
165 push @{ $tables{ $table_name }{'permissions'} }, {
166 type => 'revoke',
167 actions => $item[2],
168 users => $item[6],
169 }
170 }
171
2574969e 172grant : /grant/i WORD(s /,/) /on/i /table/i table_name /to/i name_with_opt_quotes(s /,/) ';'
0efb6e1b 173 {
174 my $table_name = $item{'table_name'};
175 push @{ $tables{ $table_name }{'permissions'} }, {
176 type => 'grant',
177 actions => $item[2],
178 users => $item[6],
179 }
180 }
181
182drop : /drop/i /[^;]*/ ';'
4422e22a 183
4d2da1f7 184insert : /insert/i /[^;]*/ ';'
185
186update : /update/i /[^;]*/ ';'
187
0012a163 188#
189# Create table.
190#
ba1a1626 191create : create_table table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
0efb6e1b 192 {
193 my $table_name = $item{'table_name'};
194 $tables{ $table_name }{'order'} = ++$table_order;
195 $tables{ $table_name }{'table_name'} = $table_name;
196
197 my $i = 1;
198 my @constraints;
199 for my $definition ( @{ $item[4] } ) {
200 if ( $definition->{'type'} eq 'field' ) {
201 my $field_name = $definition->{'name'};
202 $tables{ $table_name }{'fields'}{ $field_name } =
203 { %$definition, order => $i };
204 $i++;
4422e22a 205
0138f7bb 206 for my $constraint ( @{ $definition->{'constraints'} || [] } ) {
207 $constraint->{'fields'} = [ $field_name ];
7d5bcab8 208 push @{ $tables{ $table_name }{'constraints'} },
0138f7bb 209 $constraint;
0efb6e1b 210 }
211 }
212 elsif ( $definition->{'type'} eq 'constraint' ) {
213 $definition->{'type'} = $definition->{'constraint_type'};
0138f7bb 214 # group FKs at the field level
82968eb9 215# if ( $definition->{'type'} eq 'foreign_key' ) {
216# for my $fld ( @{ $definition->{'fields'} || [] } ) {
217# push @{
218# $tables{$table_name}{'fields'}{$fld}{'constraints'}
219# }, $definition;
220# }
221# }
222# else {
0138f7bb 223 push @{ $tables{ $table_name }{'constraints'} },
224 $definition;
82968eb9 225# }
0efb6e1b 226 }
227 else {
228 push @{ $tables{ $table_name }{'indices'} }, $definition;
229 }
230 }
231
232 for my $option ( @{ $item[6] } ) {
3022f45b 233 $tables{ $table_name }{'table_options(s?)'}{ $option->{'type'} } =
0efb6e1b 234 $option;
235 }
236
237 1;
238 }
239
0012a163 240#
241# Create index.
242#
0efb6e1b 243create : /create/i unique(?) /(index|key)/i index_name /on/i table_name using_method(?) '(' field_name(s /,/) ')' where_predicate(?) ';'
4422e22a 244 {
245 push @{ $tables{ $item{'table_name'} }{'indices'} },
246 {
0efb6e1b 247 name => $item{'index_name'},
248 type => $item{'unique'}[0] ? 'unique' : 'normal',
249 fields => $item[9],
250 method => $item{'using_method'}[0],
4422e22a 251 }
252 ;
253 }
254
0012a163 255#
256# Create anything else (e.g., domain, function, etc.)
257#
258create : /create/i WORD /[^;]+/ ';'
259
0efb6e1b 260using_method : /using/i WORD { $item[2] }
261
262where_predicate : /where/i /[^;]+/
263
264create_definition : field
0efb6e1b 265 | table_constraint
4422e22a 266 | <error>
267
268comment : /^\s*(?:#|-{2}).*\n/
269
f2f71b8e 270field : comment(s?) field_name data_type field_meta(s?) comment(s?)
4422e22a 271 {
3022f45b 272 my ( $default, @constraints, $is_pk );
82968eb9 273 my $null = 1;
41fc9cb3 274 for my $meta ( @{ $item[4] } ) {
82968eb9 275 if ( $meta->{'type'} eq 'default' ) {
276 $default = $meta;
277 next;
278 }
279 elsif ( $meta->{'type'} eq 'not_null' ) {
280 $null = 0;
281 next;
282 }
283 elsif ( $meta->{'type'} eq 'primary_key' ) {
284 $is_pk = 1;
285 }
4422e22a 286
82968eb9 287 push @constraints, $meta if $meta->{'supertype'} eq 'constraint';
288 }
0efb6e1b 289
f2f71b8e 290 my @comments = ( @{ $item[1] }, @{ $item[5] } );
291
0a7fc605 292 $return = {
4422e22a 293 type => 'field',
294 name => $item{'field_name'},
295 data_type => $item{'data_type'}{'type'},
296 size => $item{'data_type'}{'size'},
4422e22a 297 null => $null,
0efb6e1b 298 default => $default->{'value'},
299 constraints => [ @constraints ],
f2f71b8e 300 comments => [ @comments ],
3022f45b 301 is_primary_key => $is_pk || 0,
4422e22a 302 }
303 }
304 | <error>
305
0efb6e1b 306field_meta : default_val
82968eb9 307 | column_constraint
4422e22a 308
0efb6e1b 309column_constraint : constraint_name(?) column_constraint_type deferrable(?) deferred(?)
310 {
311 my $desc = $item{'column_constraint_type'};
312 my $type = $desc->{'type'};
313 my $fields = $desc->{'fields'} || [];
314 my $expression = $desc->{'expression'} || '';
315
316 $return = {
82968eb9 317 supertype => 'constraint',
0efb6e1b 318 name => $item{'constraint_name'}[0] || '',
319 type => $type,
320 expression => $type eq 'check' ? $expression : '',
321 deferreable => $item{'deferrable'},
322 deferred => $item{'deferred'},
323 reference_table => $desc->{'reference_table'},
324 reference_fields => $desc->{'reference_fields'},
325 match_type => $desc->{'match_type'},
326 on_delete_do => $desc->{'on_delete_do'},
327 on_update_do => $desc->{'on_update_do'},
4422e22a 328 }
329 }
330
0efb6e1b 331constraint_name : /constraint/i name_with_opt_quotes { $item[2] }
332
333column_constraint_type : /not null/i { $return = { type => 'not_null' } }
334 |
335 /null/
336 { $return = { type => 'null' } }
337 |
338 /unique/
339 { $return = { type => 'unique' } }
340 |
341 /primary key/i
342 { $return = { type => 'primary_key' } }
343 |
344 /check/i '(' /[^)]+/ ')'
345 { $return = { type => 'check', expression => $item[2] } }
346 |
3022f45b 347 /references/i table_name parens_word_list(?) match_type(?) key_action(s?)
0efb6e1b 348 {
3022f45b 349 my ( $on_delete, $on_update );
350 for my $action ( @{ $item[5] || [] } ) {
351 $on_delete = $action->{'action'} if $action->{'type'} eq 'delete';
352 $on_update = $action->{'action'} if $action->{'type'} eq 'update';
353 }
354
0efb6e1b 355 $return = {
356 type => 'foreign_key',
357 reference_table => $item[2],
0138f7bb 358 reference_fields => $item[3][0],
0efb6e1b 359 match_type => $item[4][0],
3022f45b 360 on_delete_do => $on_delete,
361 on_update_do => $on_update,
ba1a1626 362 }
4422e22a 363 }
364
0efb6e1b 365table_name : name_with_opt_quotes
4422e22a 366
0efb6e1b 367field_name : name_with_opt_quotes
4422e22a 368
0012a163 369name_with_opt_quotes : double_quote(?) NAME double_quote(?) { $item[2] }
4422e22a 370
0efb6e1b 371double_quote: /"/
4422e22a 372
0efb6e1b 373index_name : WORD
4422e22a 374
0efb6e1b 375data_type : pg_data_type parens_value_list(?)
4422e22a 376 {
3022f45b 377 my $data_type = $item[1];
ba1a1626 378
0efb6e1b 379 #
380 # We can deduce some sizes from the data type's name.
381 #
82968eb9 382 $data_type->{'size'} ||= $item[2][0];
4422e22a 383
3022f45b 384 $return = $data_type;
4422e22a 385 }
386
0efb6e1b 387pg_data_type :
1bbd4a2b 388 /(bigint|int8|bigserial|serial8)/i
3022f45b 389 {
390 $return = {
391 type => 'integer',
7a88750c 392 size => [8],
3022f45b 393 auto_increment => 1,
394 };
395 }
0efb6e1b 396 |
1bbd4a2b 397 /(smallint|int2)/i
3022f45b 398 {
399 $return = {
400 type => 'integer',
7a88750c 401 size => [2],
3022f45b 402 };
403 }
0efb6e1b 404 |
1bbd4a2b 405 /int(eger)?|int4/i
3022f45b 406 {
407 $return = {
408 type => 'integer',
7a88750c 409 size => [4],
3022f45b 410 };
411 }
0efb6e1b 412 |
1bbd4a2b 413 /(double precision|float8?)/i
3022f45b 414 {
415 $return = {
416 type => 'float',
7a88750c 417 size => [8],
3022f45b 418 };
419 }
0efb6e1b 420 |
1bbd4a2b 421 /(real|float4)/i
3022f45b 422 {
423 $return = {
424 type => 'real',
7a88750c 425 size => [4],
3022f45b 426 };
427 }
0efb6e1b 428 |
1bbd4a2b 429 /serial4?/i
3022f45b 430 {
431 $return = {
432 type => 'integer',
7a88750c 433 size => [4],
3022f45b 434 auto_increment => 1,
435 };
436 }
0efb6e1b 437 |
1bbd4a2b 438 /bigserial/i
3022f45b 439 {
440 $return = {
441 type => 'integer',
7a88750c 442 size => [8],
3022f45b 443 auto_increment => 1,
444 };
445 }
0efb6e1b 446 |
1bbd4a2b 447 /(bit varying|varbit)/i
3022f45b 448 {
449 $return = { type => 'varbit' };
450 }
0efb6e1b 451 |
1bbd4a2b 452 /character varying/i
3022f45b 453 {
454 $return = { type => 'varchar' };
455 }
0efb6e1b 456 |
1bbd4a2b 457 /char(acter)?/i
3022f45b 458 {
459 $return = { type => 'char' };
460 }
0efb6e1b 461 |
1bbd4a2b 462 /bool(ean)?/i
3022f45b 463 {
464 $return = { type => 'boolean' };
465 }
0efb6e1b 466 |
1bbd4a2b 467 /bytea/i
3022f45b 468 {
82968eb9 469 $return = { type => 'bytea' };
3022f45b 470 }
0efb6e1b 471 |
1bbd4a2b 472 /timestampz?/i
3022f45b 473 {
474 $return = { type => 'timestamp' };
475 }
0efb6e1b 476 |
1bbd4a2b 477 /(bit|box|cidr|circle|date|inet|interval|line|lseg|macaddr|money|numeric|decimal|path|point|polygon|text|time|varchar)/i
3022f45b 478 {
479 $return = { type => $item[1] };
480 }
0efb6e1b 481
4422e22a 482parens_value_list : '(' VALUE(s /,/) ')'
483 { $item[2] }
484
0efb6e1b 485parens_word_list : '(' WORD(s /,/) ')'
486 { $item[2] }
4422e22a 487
0efb6e1b 488field_size : '(' num_range ')' { $item{'num_range'} }
4422e22a 489
0efb6e1b 490num_range : DIGITS ',' DIGITS
4422e22a 491 { $return = $item[1].','.$item[3] }
492 | DIGITS
493 { $return = $item[1] }
494
f2f71b8e 495table_constraint : comment(s?) constraint_name(?) table_constraint_type deferrable(?) deferred(?) comment(s?)
0efb6e1b 496 {
497 my $desc = $item{'table_constraint_type'};
498 my $type = $desc->{'type'};
499 my $fields = $desc->{'fields'};
500 my $expression = $desc->{'expression'};
f2f71b8e 501 my @comments = ( @{ $item[1] }, @{ $item[-1] } );
0efb6e1b 502
503 $return = {
504 name => $item{'constraint_name'}[0] || '',
505 type => 'constraint',
506 constraint_type => $type,
507 fields => $type ne 'check' ? $fields : [],
508 expression => $type eq 'check' ? $expression : '',
509 deferreable => $item{'deferrable'},
510 deferred => $item{'deferred'},
511 reference_table => $desc->{'reference_table'},
512 reference_fields => $desc->{'reference_fields'},
513 match_type => $desc->{'match_type'}[0],
0012a163 514 on_delete_do => $desc->{'on_delete_do'},
515 on_update_do => $desc->{'on_update_do'},
f2f71b8e 516 comments => [ @comments ],
0efb6e1b 517 }
518 }
4422e22a 519
0efb6e1b 520table_constraint_type : /primary key/i '(' name_with_opt_quotes(s /,/) ')'
521 {
522 $return = {
523 type => 'primary_key',
524 fields => $item[3],
525 }
526 }
527 |
528 /unique/i '(' name_with_opt_quotes(s /,/) ')'
529 {
530 $return = {
531 type => 'unique',
532 fields => $item[3],
533 }
534 }
535 |
536 /check/ '(' /(.+)/ ')'
537 {
538 $return = {
539 type => 'check',
540 expression => $item[3],
541 }
542 }
543 |
3022f45b 544 /foreign key/i '(' name_with_opt_quotes(s /,/) ')' /references/i table_name parens_word_list(?) match_type(?) key_action(s?)
0efb6e1b 545 {
3022f45b 546 my ( $on_delete, $on_update );
547 for my $action ( @{ $item[9] || [] } ) {
548 $on_delete = $action->{'action'} if $action->{'type'} eq 'delete';
549 $on_update = $action->{'action'} if $action->{'type'} eq 'update';
550 }
551
0efb6e1b 552 $return = {
553 type => 'foreign_key',
554 fields => $item[3],
555 reference_table => $item[6],
556 reference_fields => $item[7][0],
557 match_type => $item[8][0],
3022f45b 558 on_delete_do => $on_delete || '',
559 on_update_do => $on_update || '',
0efb6e1b 560 }
561 }
562
563deferrable : /not/i /deferrable/i
564 {
565 $return = ( $item[1] =~ /not/i ) ? 0 : 1;
566 }
4422e22a 567
0efb6e1b 568deferred : /initially/i /(deferred|immediate)/i { $item[2] }
4422e22a 569
0efb6e1b 570match_type : /match full/i { 'match_full' }
571 |
572 /match partial/i { 'match_partial' }
573
3022f45b 574key_action : key_delete
575 |
576 key_update
0efb6e1b 577
3022f45b 578key_delete : /on delete/i key_mutation
579 {
580 $return => {
581 type => 'delete',
582 action => $item[2],
583 };
584 }
585
586key_update : /on update/i key_mutation
587 {
588 $return => {
589 type => 'update',
590 action => $item[2],
591 };
592 }
593
594key_mutation : /no action/i { $return = 'no_action' }
595 |
596 /restrict/i { $return = 'restrict' }
597 |
598 /cascade/i { $return = 'cascade' }
599 |
600 /set null/i { $return = 'set_null' }
601 |
602 /set default/i { $return = 'set_default' }
0efb6e1b 603
0012a163 604alter : alter_table table_name /add/i table_constraint ';'
605 {
606 my $table_name = $item[2];
607 my $constraint = $item[4];
608 $constraint->{'type'} = $constraint->{'constraint_type'};
609 push @{ $tables{ $table_name }{'constraints'} }, $constraint;
610 }
611
612alter_table : /alter/i /table/i only(?)
613
614only : /only/i
615
0efb6e1b 616create_table : /create/i /table/i
617
618create_index : /create/i /index/i
4422e22a 619
5ddd74af 620default_val : /default/i /(?:')?[\w\d().-]*(?:')?/
4422e22a 621 {
0efb6e1b 622 my $val = $item[2] || '';
623 $val =~ s/'//g;
624 $return = {
82968eb9 625 supertype => 'constraint',
626 type => 'default',
0efb6e1b 627 value => $val,
628 }
4422e22a 629 }
f27085c9 630 | /null/i
631 {
632 $return = {
633 supertype => 'constraint',
634 type => 'default',
635 value => 'NULL',
636 }
637 }
4422e22a 638
4422e22a 639name_with_opt_paren : NAME parens_value_list(s?)
0efb6e1b 640 { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
4422e22a 641
642unique : /unique/i { 1 }
643
644key : /key/i | /index/i
645
0efb6e1b 646table_option : /inherits/i '(' name_with_opt_quotes(s /,/) ')'
4422e22a 647 {
0efb6e1b 648 $return = { type => 'inherits', table_name => $item[3] }
649 }
650 |
651 /with(out)? oids/i
652 {
653 $return = { type => $item[1] =~ /out/i ? 'without_oids' : 'with_oids' }
4422e22a 654 }
655
0efb6e1b 656SEMICOLON : /\s*;\n?/
657
4422e22a 658WORD : /\w+/
659
660DIGITS : /\d+/
661
662COMMA : ','
663
664NAME : "`" /\w+/ "`"
665 { $item[2] }
666 | /\w+/
667 { $item[1] }
0012a163 668 | /[\$\w]+/
669 { $item[1] }
4422e22a 670
671VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
672 { $item[1] }
673 | /'.*?'/ # XXX doesn't handle embedded quotes
674 { $item[1] }
675 | /NULL/
676 { 'NULL' }
677
678!;
679
680# -------------------------------------------------------------------
681sub parse {
682 my ( $translator, $data ) = @_;
683 $parser ||= Parse::RecDescent->new($GRAMMAR);
684
685 $::RD_TRACE = $translator->trace ? 1 : undef;
686 $DEBUG = $translator->debug;
687
688 unless (defined $parser) {
689 return $translator->error("Error instantiating Parse::RecDescent ".
690 "instance: Bad grammer");
691 }
692
693 my $result = $parser->startrule($data);
694 die "Parse failed.\n" unless defined $result;
695 warn Dumper($result) if $DEBUG;
82968eb9 696
697 my $schema = $translator->schema;
698 my @tables = sort {
699 $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
700 } keys %{ $result };
701
702 for my $table_name ( @tables ) {
703 my $tdata = $result->{ $table_name };
704 my $table = $schema->add_table(
705 name => $tdata->{'table_name'},
706 ) or die $schema->error;
707
708 my @fields = sort {
709 $tdata->{'fields'}->{$a}->{'order'}
710 <=>
711 $tdata->{'fields'}->{$b}->{'order'}
712 } keys %{ $tdata->{'fields'} };
713
714 for my $fname ( @fields ) {
715 my $fdata = $tdata->{'fields'}{ $fname };
716 my $field = $table->add_field(
717 name => $fdata->{'name'},
718 data_type => $fdata->{'data_type'},
719 size => $fdata->{'size'},
720 default_value => $fdata->{'default'},
721 is_auto_increment => $fdata->{'is_auto_inc'},
722 is_nullable => $fdata->{'null'},
723 ) or die $table->error;
724
725 $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
726
727 for my $cdata ( @{ $fdata->{'constraints'} } ) {
728 next unless $cdata->{'type'} eq 'foreign_key';
729 $cdata->{'fields'} ||= [ $field->name ];
730 push @{ $tdata->{'constraints'} }, $cdata;
731 }
732 }
733
734 for my $idata ( @{ $tdata->{'indices'} || [] } ) {
735 my $index = $table->add_index(
736 name => $idata->{'name'},
737 type => uc $idata->{'type'},
738 fields => $idata->{'fields'},
739 ) or die $table->error;
740 }
741
742 for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
743 my $constraint = $table->add_constraint(
744 name => $cdata->{'name'},
745 type => $cdata->{'type'},
746 fields => $cdata->{'fields'},
747 reference_table => $cdata->{'reference_table'},
748 reference_fields => $cdata->{'reference_fields'},
749 match_type => $cdata->{'match_type'} || '',
750 on_delete => $cdata->{'on_delete_do'},
751 on_update => $cdata->{'on_update_do'},
752 ) or die $table->error;
753 }
754 }
755
f62bd16c 756 return 1;
4422e22a 757}
758
7591;
760
82968eb9 761# -------------------------------------------------------------------
762# Rescue the drowning and tie your shoestrings.
763# Henry David Thoreau
764# -------------------------------------------------------------------
4422e22a 765
766=pod
767
0efb6e1b 768=head1 AUTHORS
4422e22a 769
770Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
0a7fc605 771Allen Day <allenday@ucla.edu>.
4422e22a 772
773=head1 SEE ALSO
774
775perl(1), Parse::RecDescent.
776
777=cut