2fc37ce81e2bd077061f3b4234e67faaf39eb61b
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / PostgreSQL.pm
1 package SQL::Translator::Parser::PostgreSQL;
2
3 # -------------------------------------------------------------------
4 # Copyright (C) 2002-2009 SQLFairy Authors
5 #
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License as
8 # published by the Free Software Foundation; version 2.
9 #
10 # This program is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 # General Public License for more details.
14 #
15 # You should have received a copy of the GNU General Public License
16 # along with this program; if not, write to the Free Software
17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
18 # 02111-1307  USA
19 # -------------------------------------------------------------------
20
21 =head1 NAME
22
23 SQL::Translator::Parser::PostgreSQL - parser for PostgreSQL
24
25 =head1 SYNOPSIS
26
27   use SQL::Translator;
28   use SQL::Translator::Parser::PostgreSQL;
29
30   my $translator = SQL::Translator->new;
31   $translator->parser("SQL::Translator::Parser::PostgreSQL");
32
33 =head1 DESCRIPTION
34
35 The grammar was started from the MySQL parsers.  Here is the description 
36 from PostgreSQL:
37
38 Table:
39 (http://www.postgresql.org/docs/view.php?version=7.3&idoc=1&file=sql-createtable.html)
40
41   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
42       { column_name data_type [ DEFAULT default_expr ] 
43          [ column_constraint [, ... ] ]
44       | table_constraint }  [, ... ]
45   )
46   [ INHERITS ( parent_table [, ... ] ) ]
47   [ WITH OIDS | WITHOUT OIDS ]
48   
49   where column_constraint is:
50   
51   [ CONSTRAINT constraint_name ]
52   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
53     CHECK (expression) |
54     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
55       [ ON DELETE action ] [ ON UPDATE action ] }
56   [ DEFERRABLE | NOT DEFERRABLE ] 
57   [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
58   
59   and table_constraint is:
60   
61   [ CONSTRAINT constraint_name ]
62   { UNIQUE ( column_name [, ... ] ) |
63     PRIMARY KEY ( column_name [, ... ] ) |
64     CHECK ( expression ) |
65     FOREIGN KEY ( column_name [, ... ] ) 
66      REFERENCES reftable [ ( refcolumn [, ... ] ) ]
67       [ MATCH FULL | MATCH PARTIAL ] 
68       [ ON DELETE action ] [ ON UPDATE action ] }
69   [ DEFERRABLE | NOT DEFERRABLE ] 
70   [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
71
72 Index:
73 (http://www.postgresql.org/docs/view.php?version=7.3&idoc=1&file=sql-createindex.html)
74
75   CREATE [ UNIQUE ] INDEX index_name ON table
76       [ USING acc_method ] ( column [ ops_name ] [, ...] )
77       [ WHERE predicate ]
78   CREATE [ UNIQUE ] INDEX index_name ON table
79       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
80       [ WHERE predicate ]
81
82 Alter table:
83
84   ALTER TABLE [ ONLY ] table [ * ]
85       ADD [ COLUMN ] column type [ column_constraint [ ... ] ]
86   ALTER TABLE [ ONLY ] table [ * ]
87       ALTER [ COLUMN ] column { SET DEFAULT value | DROP DEFAULT }
88   ALTER TABLE [ ONLY ] table [ * ]
89       ALTER [ COLUMN ] column SET STATISTICS integer
90   ALTER TABLE [ ONLY ] table [ * ]
91       RENAME [ COLUMN ] column TO newcolumn
92   ALTER TABLE table
93       RENAME TO new_table
94   ALTER TABLE table
95       ADD table_constraint_definition
96   ALTER TABLE [ ONLY ] table 
97           DROP CONSTRAINT constraint { RESTRICT | CASCADE }
98   ALTER TABLE table
99           OWNER TO new_owner 
100
101 View table:
102
103     CREATE [ OR REPLACE ] VIEW view [ ( column name list ) ] AS SELECT query
104
105 =cut
106
107 use strict;
108 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
109 $VERSION = '1.59';
110 $DEBUG   = 0 unless defined $DEBUG;
111
112 use Data::Dumper;
113 use Parse::RecDescent;
114 use Exporter;
115 use base qw(Exporter);
116
117 @EXPORT_OK = qw(parse);
118
119 # Enable warnings within the Parse::RecDescent module.
120 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
121 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
122 $::RD_HINT   = 1; # Give out hints to help fix problems.
123
124 my $parser; # should we do this?  There's no programmic way to 
125             # change the grammar, so I think this is safe.
126
127 $GRAMMAR = q!
128
129 { my ( %tables, $table_order, $field_order, @table_comments) }
130
131 #
132 # The "eofile" rule makes the parser fail if any "statement" rule
133 # fails.  Otherwise, the first successful match by a "statement" 
134 # won't cause the failure needed to know that the parse, as a whole,
135 # failed. -ky
136 #
137 startrule : statement(s) eofile { \%tables }
138
139 eofile : /^\Z/
140    
141
142 statement : create
143   | comment_on_table
144   | comment_on_column
145   | comment_on_other
146   | comment
147   | alter
148   | grant
149   | revoke
150   | drop
151   | insert
152   | connect
153   | update
154   | set
155   | select
156   | copy
157   | readin_symbol
158   | <error>
159
160 connect : /^\s*\\\connect.*\n/
161
162 set : /set/i /[^;]*/ ';'
163
164 revoke : /revoke/i WORD(s /,/) /on/i TABLE(?) table_name /from/i name_with_opt_quotes(s /,/) ';'
165     {
166         my $table_info  = $item{'table_name'};
167         my $schema_name = $table_info->{'schema_name'};
168         my $table_name  = $table_info->{'table_name'};
169         push @{ $tables{ $table_name }{'permissions'} }, {
170             type       => 'revoke',
171             actions    => $item[2],
172             users      => $item[7],
173         }
174     }
175
176 revoke : /revoke/i WORD(s /,/) /on/i SCHEMA(?) schema_name /from/i name_with_opt_quotes(s /,/) ';'
177     { 1 }
178
179 grant : /grant/i WORD(s /,/) /on/i TABLE(?) table_name /to/i name_with_opt_quotes(s /,/) ';'
180     {
181         my $table_info  = $item{'table_name'};
182         my $schema_name = $table_info->{'schema_name'};
183         my $table_name  = $table_info->{'table_name'};
184         push @{ $tables{ $table_name }{'permissions'} }, {
185             type       => 'grant',
186             actions    => $item[2],
187             users      => $item[7],
188         }
189     }
190
191 grant : /grant/i WORD(s /,/) /on/i SCHEMA(?) schema_name /to/i name_with_opt_quotes(s /,/) ';'
192     { 1 }
193
194 drop : /drop/i /[^;]*/ ';'
195
196 string :
197    /'(\\.|''|[^\\\'])*'/ 
198
199 nonstring : /[^;\'"]+/
200
201 statement_body : string | nonstring
202
203 insert : /insert/i statement_body(s?) ';'
204
205 update : /update/i statement_body(s?) ';'
206
207 #
208 # Create table.
209 #
210 create : CREATE temporary_table(?) TABLE table_name '(' create_definition(s? /,/) ')' table_option(s?) ';'
211     {
212         my $table_info  = $item{'table_name'};
213         my $schema_name = $table_info->{'schema_name'};
214         my $table_name  = $table_info->{'table_name'};
215         $tables{ $table_name }{'order'}       = ++$table_order;
216         $tables{ $table_name }{'schema_name'} = $schema_name;
217         $tables{ $table_name }{'table_name'}  = $table_name;
218
219         $tables{ $table_name }{'temporary'} = $item[2][0]; 
220
221         if ( @table_comments ) {
222             $tables{ $table_name }{'comments'} = [ @table_comments ];
223             @table_comments = ();
224         }
225
226         my @constraints;
227         for my $definition ( @{ $item[6] } ) {
228             if ( $definition->{'supertype'} eq 'field' ) {
229                 my $field_name = $definition->{'name'};
230                 $tables{ $table_name }{'fields'}{ $field_name } = 
231                     { %$definition, order => $field_order++ };
232                                 
233                 for my $constraint ( @{ $definition->{'constraints'} || [] } ) {
234                     $constraint->{'fields'} = [ $field_name ];
235                     push @{ $tables{ $table_name }{'constraints'} },
236                         $constraint;
237                 }
238             }
239             elsif ( $definition->{'supertype'} eq 'constraint' ) {
240                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
241             }
242             elsif ( $definition->{'supertype'} eq 'index' ) {
243                 push @{ $tables{ $table_name }{'indices'} }, $definition;
244             }
245         }
246
247         for my $option ( @{ $item[8] } ) {
248             $tables{ $table_name }{'table_options(s?)'}{ $option->{'type'} } = 
249                 $option;
250         }
251
252         1;
253     }
254
255 create : CREATE unique(?) /(index|key)/i index_name /on/i table_name using_method(?) '(' field_name(s /,/) ')' where_predicate(?) ';'
256     {
257         my $table_info  = $item{'table_name'};
258         my $schema_name = $table_info->{'schema_name'};
259         my $table_name  = $table_info->{'table_name'};
260         push @{ $tables{ $table_name }{'indices'} },
261             {
262                 name      => $item{'index_name'},
263                 supertype => $item{'unique'}[0] ? 'constraint' : 'index',
264                 type      => $item{'unique'}[0] ? 'unique'     : 'normal',
265                 fields    => $item[9],
266                 method    => $item{'using_method'}[0],
267             }
268         ;
269     }
270
271 #
272 # Create anything else (e.g., domain, etc.)
273 #
274 create : CREATE WORD /[^;]+/ ';'
275     { @table_comments = (); }
276
277 using_method : /using/i WORD { $item[2] }
278
279 where_predicate : /where/i /[^;]+/
280
281 create_definition : field
282     | table_constraint
283     | <error>
284
285 comment : /^\s*(?:#|-{2})(.*)\n/ 
286     { 
287         my $comment =  $item[1];
288         $comment    =~ s/^\s*(#|-*)\s*//;
289         $comment    =~ s/\s*$//;
290         $return     = $comment;
291         push @table_comments, $comment;
292     }
293
294 comment_on_table : /comment/i /on/i /table/i table_name /is/i comment_phrase ';'
295     {
296         my $table_info  = $item{'table_name'};
297         my $schema_name = $table_info->{'schema_name'};
298         my $table_name  = $table_info->{'table_name'};
299         push @{ $tables{ $table_name }{'comments'} }, $item{'comment_phrase'};
300     }
301
302 comment_on_column : /comment/i /on/i /column/i column_name /is/i comment_phrase ';'
303     {
304         my $table_name = $item[4]->{'table'};
305         my $field_name = $item[4]->{'field'};
306         if ($tables{ $table_name }{'fields'}{ $field_name } ) {
307           push @{ $tables{ $table_name }{'fields'}{ $field_name }{'comments'} }, 
308               $item{'comment_phrase'};
309         }
310         else {
311            die "No such column as $table_name.$field_name";
312         }
313     }
314
315 comment_on_other : /comment/i /on/i /\w+/ /\w+/ /is/i comment_phrase ';'
316     {
317         push(@table_comments, $item{'comment_phrase'});
318     }
319
320 # [added by cjm 20041019]
321 # [TODO: other comment-on types]
322 # for now we just have a general mechanism for handling other
323 # kinds of comments than table/column; I'm not sure of the best
324 # way to incorporate these into the datamodel
325 #
326 # this is the exhaustive list of types of comment:
327 #COMMENT ON DATABASE my_database IS 'Development Database';
328 #COMMENT ON INDEX my_index IS 'Enforces uniqueness on employee id';
329 #COMMENT ON RULE my_rule IS 'Logs UPDATES of employee records';
330 #COMMENT ON SEQUENCE my_sequence IS 'Used to generate primary keys';
331 #COMMENT ON TABLE my_table IS 'Employee Information';
332 #COMMENT ON TYPE my_type IS 'Complex Number support';
333 #COMMENT ON VIEW my_view IS 'View of departmental costs';
334 #COMMENT ON COLUMN my_table.my_field IS 'Employee ID number';
335 #COMMENT ON TRIGGER my_trigger ON my_table IS 'Used for R.I.';
336 #
337 # this is tested by test 08
338
339 column_name : NAME '.' NAME
340     { $return = { table => $item[1], field => $item[3] } }
341
342 comment_phrase : /null/i
343     { $return = 'NULL' }
344
345 comment_phrase : /'/ comment_phrase_unquoted(s) /'/
346     { my $phrase = join(' ', @{ $item[2] });
347       $return = $phrase}
348
349 # [cjm TODO: double-single quotes in a comment_phrase]
350 comment_phrase_unquoted : /[^\']*/
351     { $return = $item[1] }
352
353
354 xxxcomment_phrase : /'.*?'|NULL/ 
355     { 
356         my $val = $item[1] || '';
357         $val =~ s/^'|'$//g;
358         $return = $val;
359     }
360
361 field : field_comment(s?) field_name data_type field_meta(s?) field_comment(s?)
362     {
363         my ( $default, @constraints, $is_pk );
364         my $is_nullable = 1;
365         for my $meta ( @{ $item[4] } ) {
366             if ( $meta->{'type'} eq 'default' ) {
367                 $default = $meta;
368                 next;
369             }
370             elsif ( $meta->{'type'} eq 'not_null' ) {
371                 $is_nullable = 0;
372             }
373             elsif ( $meta->{'type'} eq 'primary_key' ) {
374                 $is_pk = 1;
375             }
376
377             push @constraints, $meta if $meta->{'supertype'} eq 'constraint';
378         }
379
380         my @comments = ( @{ $item[1] }, @{ $item[5] } );
381
382         $return = {
383             supertype         => 'field',
384             name              => $item{'field_name'}, 
385             data_type         => $item{'data_type'}{'type'},
386             size              => $item{'data_type'}{'size'},
387             is_nullable       => $is_nullable,
388             default           => $default->{'value'},
389             constraints       => [ @constraints ],
390             comments          => [ @comments ],
391             is_primary_key    => $is_pk || 0,
392             is_auto_increment => $item{'data_type'}{'is_auto_increment'},
393         } 
394     }
395     | <error>
396
397 field_comment : /^\s*(?:#|-{2})(.*)\n/ 
398     { 
399         my $comment =  $item[1];
400         $comment    =~ s/^\s*(#|-*)\s*//;
401         $comment    =~ s/\s*$//;
402         $return     = $comment;
403     }
404
405 field_meta : default_val
406     | column_constraint
407
408 column_constraint : constraint_name(?) column_constraint_type deferrable(?) deferred(?)
409     {
410         my $desc       = $item{'column_constraint_type'};
411         my $type       = $desc->{'type'};
412         my $fields     = $desc->{'fields'}     || [];
413         my $expression = $desc->{'expression'} || '';
414
415         $return              =  {
416             supertype        => 'constraint',
417             name             => $item{'constraint_name'}[0] || '',
418             type             => $type,
419             expression       => $type eq 'check' ? $expression : '',
420             deferrable       => $item{'deferrable'},
421             deferred         => $item{'deferred'},
422             reference_table  => $desc->{'reference_table'},
423             reference_fields => $desc->{'reference_fields'},
424             match_type       => $desc->{'match_type'},
425             on_delete        => $desc->{'on_delete'} || $desc->{'on_delete_do'},
426             on_update        => $desc->{'on_update'} || $desc->{'on_update_do'},
427         } 
428     }
429
430 constraint_name : /constraint/i name_with_opt_quotes { $item[2] }
431
432 column_constraint_type : /not null/i { $return = { type => 'not_null' } }
433     |
434     /null/i
435         { $return = { type => 'null' } }
436     |
437     /unique/i
438         { $return = { type => 'unique' } }
439     |
440     /primary key/i 
441         { $return = { type => 'primary_key' } }
442     |
443     /check/i '(' /[^)]+/ ')' 
444         { $return = { type => 'check', expression => $item[3] } }
445     |
446     /references/i table_name parens_word_list(?) match_type(?) key_action(s?)
447     {
448         my $table_info  = $item{'table_name'};
449         my $schema_name = $table_info->{'schema_name'};
450         my $table_name  = $table_info->{'table_name'};
451         my ( $on_delete, $on_update );
452         for my $action ( @{ $item[5] || [] } ) {
453             $on_delete = $action->{'action'} if $action->{'type'} eq 'delete';
454             $on_update = $action->{'action'} if $action->{'type'} eq 'update';
455         }
456
457         $return              =  {
458             type             => 'foreign_key',
459             reference_table  => $table_name,
460             reference_fields => $item[3][0],
461             match_type       => $item[4][0],
462             on_delete        => $on_delete,
463             on_update        => $on_update,
464         }
465     }
466
467 table_name : schema_qualification(?) name_with_opt_quotes {
468     $return = { schema_name => $item[1], table_name => $item[2] }
469 }
470
471   schema_qualification : name_with_opt_quotes '.'
472
473 schema_name : name_with_opt_quotes
474
475 field_name : name_with_opt_quotes
476
477 name_with_opt_quotes : double_quote(?) NAME double_quote(?) { $item[2] }
478
479 double_quote: /"/
480
481 index_name : name_with_opt_quotes
482
483 data_type : pg_data_type parens_value_list(?)
484     { 
485         my $data_type = $item[1];
486
487         #
488         # We can deduce some sizes from the data type's name.
489         #
490         if ( my $size = $item[2][0] ) {
491             $data_type->{'size'} = $size;
492         }
493
494         $return  = $data_type;
495     }
496
497 pg_data_type :
498     /(bigint|int8)/i
499         { 
500             $return = { 
501                 type => 'integer',
502                 size => 20,
503             };
504         }
505     |
506     /(smallint|int2)/i
507         { 
508             $return = {
509                 type => 'integer', 
510                 size => 5,
511             };
512         }
513     |
514     /interval/i
515         {
516             $return = { type => 'interval' };
517         }
518     |
519     /(integer|int4?)/i # interval must come before this
520         { 
521             $return = {
522                 type => 'integer', 
523                 size => 10,
524             };
525         }
526     |    
527     /(real|float4)/i
528         { 
529             $return = {
530                 type => 'real', 
531                 size => 10,
532             };
533         }
534     |
535     /(double precision|float8?)/i
536         { 
537             $return = {
538                 type => 'float', 
539                 size => 20,
540             }; 
541         }
542     |
543     /(bigserial|serial8)/i
544         { 
545             $return = { 
546                 type              => 'integer', 
547                 size              => 20, 
548                 is_auto_increment => 1,
549             };
550         }
551     |
552     /serial4?/i
553         { 
554             $return = { 
555                 type              => 'integer',
556                 size              => 11, 
557                 is_auto_increment => 1,
558             };
559         }
560     |
561     /(bit varying|varbit)/i
562         { 
563             $return = { type => 'varbit' };
564         }
565     |
566     /character varying/i
567         { 
568             $return = { type => 'varchar' };
569         }
570     |
571     /char(acter)?/i
572         { 
573             $return = { type => 'char' };
574         }
575     |
576     /bool(ean)?/i
577         { 
578             $return = { type => 'boolean' };
579         }
580     |
581     /bytea/i
582         { 
583             $return = { type => 'bytea' };
584         }
585     |
586     /(timestamptz|timestamp)(?:\(\d\))?( with(out)? time zone)?/i
587         { 
588             $return = { type => 'timestamp' };
589         }
590     |
591     /text/i
592         { 
593             $return = { 
594                 type => 'text',
595                 size => 64_000,
596             };
597         }
598     |
599     /(bit|box|cidr|circle|date|inet|line|lseg|macaddr|money|numeric|decimal|path|point|polygon|timetz|time|varchar)/i
600         { 
601             $return = { type => $item[1] };
602         }
603
604 parens_value_list : '(' VALUE(s /,/) ')'
605     { $item[2] }
606
607
608 parens_word_list : '(' name_with_opt_quotes(s /,/) ')'
609     { $item[2] }
610
611 field_size : '(' num_range ')' { $item{'num_range'} }
612
613 num_range : DIGITS ',' DIGITS
614     { $return = $item[1].','.$item[3] }
615     | DIGITS
616     { $return = $item[1] }
617
618 table_constraint : comment(s?) constraint_name(?) table_constraint_type deferrable(?) deferred(?) comment(s?)
619     {
620         my $desc       = $item{'table_constraint_type'};
621         my $type       = $desc->{'type'};
622         my $fields     = $desc->{'fields'};
623         my $expression = $desc->{'expression'};
624         my @comments   = ( @{ $item[1] }, @{ $item[-1] } );
625
626         $return              =  {
627             name             => $item[2][0] || '',
628             supertype        => 'constraint',
629             type             => $type,
630             fields           => $type ne 'check' ? $fields : [],
631             expression       => $type eq 'check' ? $expression : '',
632             deferrable       => $item{'deferrable'},
633             deferred         => $item{'deferred'},
634             reference_table  => $desc->{'reference_table'},
635             reference_fields => $desc->{'reference_fields'},
636             match_type       => $desc->{'match_type'}[0],
637             on_delete        => $desc->{'on_delete'} || $desc->{'on_delete_do'},
638             on_update        => $desc->{'on_update'} || $desc->{'on_update_do'},
639             comments         => [ @comments ],
640         } 
641     }
642
643 table_constraint_type : /primary key/i '(' name_with_opt_quotes(s /,/) ')' 
644     { 
645         $return = {
646             type   => 'primary_key',
647             fields => $item[3],
648         }
649     }
650     |
651     /unique/i '(' name_with_opt_quotes(s /,/) ')' 
652     { 
653         $return    =  {
654             type   => 'unique',
655             fields => $item[3],
656         }
657     }
658     |
659     /check/i '(' /[^)]+/ ')' 
660     {
661         $return        =  {
662             type       => 'check',
663             expression => $item[3],
664         }
665     }
666     |
667     /foreign key/i '(' name_with_opt_quotes(s /,/) ')' /references/i table_name parens_word_list(?) match_type(?) key_action(s?)
668     {
669         my ( $on_delete, $on_update );
670         for my $action ( @{ $item[9] || [] } ) {
671             $on_delete = $action->{'action'} if $action->{'type'} eq 'delete';
672             $on_update = $action->{'action'} if $action->{'type'} eq 'update';
673         }
674         
675         $return              =  {
676             supertype        => 'constraint',
677             type             => 'foreign_key',
678             fields           => $item[3],
679             reference_table  => $item[6]->{'table_name'},
680             reference_fields => $item[7][0],
681             match_type       => $item[8][0],
682             on_delete     => $on_delete || '',
683             on_update     => $on_update || '',
684         }
685     }
686
687 deferrable : not(?) /deferrable/i 
688     { 
689         $return = ( $item[1] =~ /not/i ) ? 0 : 1;
690     }
691
692 deferred : /initially/i /(deferred|immediate)/i { $item[2] }
693
694 match_type : /match full/i { 'match_full' }
695     |
696     /match partial/i { 'match_partial' }
697
698 key_action : key_delete 
699     |
700     key_update
701
702 key_delete : /on delete/i key_mutation
703     { 
704         $return = { 
705             type   => 'delete',
706             action => $item[2],
707         };
708     }
709
710 key_update : /on update/i key_mutation
711     { 
712         $return = { 
713             type   => 'update',
714             action => $item[2],
715         };
716     }
717
718 key_mutation : /no action/i { $return = 'no_action' }
719     |
720     /restrict/i { $return = 'restrict' }
721     |
722     /cascade/i { $return = 'cascade' }
723     |
724     /set null/i { $return = 'set null' }
725     |
726     /set default/i { $return = 'set default' }
727
728 alter : alter_table table_name add_column field ';' 
729     { 
730         my $field_def = $item[4];
731         $tables{ $item[2]->{'table_name'} }{'fields'}{ $field_def->{'name'} } = {
732             %$field_def, order => $field_order++
733         };
734         1;
735     }
736
737 alter : alter_table table_name ADD table_constraint ';' 
738     { 
739         my $table_name = $item[2]->{'table_name'};
740         my $constraint = $item[4];
741         push @{ $tables{ $table_name }{'constraints'} }, $constraint;
742         1;
743     }
744
745 alter : alter_table table_name drop_column NAME restrict_or_cascade(?) ';' 
746     {
747         $tables{ $item[2]->{'table_name'} }{'fields'}{ $item[4] }{'drop'} = 1;
748         1;
749     }
750
751 alter : alter_table table_name alter_column NAME alter_default_val ';' 
752     {
753         $tables{ $item[2]->{'table_name'} }{'fields'}{ $item[4] }{'default'} = 
754             $item[5]->{'value'};
755         1;
756     }
757
758 #
759 # These will just parse for now but won't affect the structure. - ky
760 #
761 alter : alter_table table_name /rename/i /to/i NAME ';'
762     { 1 }
763
764 alter : alter_table table_name alter_column NAME SET /statistics/i INTEGER ';' 
765     { 1 }
766
767 alter : alter_table table_name alter_column NAME SET /storage/i storage_type ';'
768     { 1 }
769
770 alter : alter_table table_name rename_column NAME /to/i NAME ';'
771     { 1 }
772
773 alter : alter_table table_name DROP /constraint/i NAME restrict_or_cascade ';'
774     { 1 }
775
776 alter : alter_table table_name /owner/i /to/i NAME ';'
777     { 1 }
778
779 alter : alter_sequence NAME /owned/i /by/i column_name ';'
780     { 1 }
781
782 storage_type : /(plain|external|extended|main)/i
783
784 temporary: /temp(orary)?\\b/i
785
786 temporary_table: temporary
787     {
788         1;
789     }
790
791 alter_default_val : SET default_val 
792     { 
793         $return = { value => $item[2]->{'value'} } 
794     }
795     | DROP DEFAULT 
796     { 
797         $return = { value => undef } 
798     } 
799
800 #
801 # This is a little tricky to get right, at least WRT to making the 
802 # tests pass.  The problem is that the constraints are stored just as
803 # a list (no name access), and the tests expect the constraints in a
804 # particular order.  I'm going to leave the rule but disable the code 
805 # for now. - ky
806 #
807 alter : alter_table table_name alter_column NAME alter_nullable ';'
808     {
809 #        my $table_name  = $item[2]->{'table_name'};
810 #        my $field_name  = $item[4];
811 #        my $is_nullable = $item[5]->{'is_nullable'};
812 #
813 #        $tables{ $table_name }{'fields'}{ $field_name }{'is_nullable'} = 
814 #            $is_nullable;
815 #
816 #        if ( $is_nullable ) {
817 #            1;
818 #            push @{ $tables{ $table_name }{'constraints'} }, {
819 #                type   => 'not_null',
820 #                fields => [ $field_name ],
821 #            };
822 #        }
823 #        else {
824 #            for my $i ( 
825 #                0 .. $#{ $tables{ $table_name }{'constraints'} || [] } 
826 #            ) {
827 #                my $c = $tables{ $table_name }{'constraints'}[ $i ] or next;
828 #                my $fields = join( '', @{ $c->{'fields'} || [] } ) or next;
829 #                if ( $c->{'type'} eq 'not_null' && $fields eq $field_name ) {
830 #                    delete $tables{ $table_name }{'constraints'}[ $i ];
831 #                    last;
832 #                }
833 #            }
834 #        }
835
836         1;
837     }
838
839 alter_nullable : SET not_null 
840     { 
841         $return = { is_nullable => 0 } 
842     }
843     | DROP not_null
844     { 
845         $return = { is_nullable => 1 } 
846     }
847
848 not_null : /not/i /null/i
849
850 not : /not/i
851
852 add_column : ADD COLUMN(?)
853
854 alter_table : ALTER TABLE ONLY(?)
855
856 alter_sequence : ALTER SEQUENCE 
857
858 drop_column : DROP COLUMN(?)
859
860 alter_column : ALTER COLUMN(?)
861
862 rename_column : /rename/i COLUMN(?)
863
864 restrict_or_cascade : /restrict/i | 
865     /cascade/i
866
867 # Handle functions that can be called
868 select : SELECT select_function ';' 
869     { 1 }
870
871 # Read the setval function but don't do anything with it because this parser
872 # isn't handling sequences
873 select_function : schema_qualification(?) /setval/i '(' VALUE /,/ VALUE /,/ /(true|false)/i ')' 
874     { 1 }
875
876 # Skipping all COPY commands
877 copy : COPY WORD /[^;]+/ ';' { 1 }
878     { 1 }
879
880 # The "\." allows reading in from STDIN but this isn't needed for schema
881 # creation, so it is skipped.
882 readin_symbol : '\.'
883     {1}
884
885 #
886 # End basically useless stuff. - ky
887 #
888
889 create_table : CREATE TABLE
890
891 create_index : CREATE /index/i
892
893 default_val  : DEFAULT /(\d+|'[^']*'|\w+\(.*\))|\w+/
894     { 
895         my $val =  defined $item[2] ? $item[2] : '';
896         $val    =~ s/^'|'$//g; 
897         $return =  {
898             supertype => 'constraint',
899             type      => 'default',
900             value     => $val,
901         }
902     }
903     | /null/i
904     { 
905         $return =  {
906             supertype => 'constraint',
907             type      => 'default',
908             value     => 'NULL',
909         }
910     }
911
912 name_with_opt_paren : NAME parens_value_list(s?)
913     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
914
915 unique : /unique/i { 1 }
916
917 key : /key/i | /index/i
918
919 table_option : /inherits/i '(' name_with_opt_quotes(s /,/) ')'
920     { 
921         $return = { type => 'inherits', table_name => $item[3] }
922     }
923     |
924     /with(out)? oids/i
925     {
926         $return = { type => $item[1] =~ /out/i ? 'without_oids' : 'with_oids' }
927     }
928
929 ADD : /add/i
930
931 ALTER : /alter/i
932
933 CREATE : /create/i
934
935 ONLY : /only/i
936
937 DEFAULT : /default/i
938
939 DROP : /drop/i
940
941 COLUMN : /column/i
942
943 TABLE : /table/i
944
945 SCHEMA : /schema/i
946
947 SEMICOLON : /\s*;\n?/
948
949 SEQUENCE : /sequence/i
950
951 SELECT : /select/i
952
953 COPY : /copy/i
954
955 INTEGER : /\d+/
956
957 WORD : /\w+/
958
959 DIGITS : /\d+/
960
961 COMMA : ','
962
963 SET : /set/i
964
965 NAME    : "`" /\w+/ "`"
966     { $item[2] }
967     | /\w+/
968     { $item[1] }
969     | /[\$\w]+/
970     { $item[1] }
971
972 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
973     { $item[1] }
974     | /'.*?'/   # XXX doesn't handle embedded quotes
975     { $item[1] }
976     | /null/i
977     { 'NULL' }
978
979 !;
980
981 # -------------------------------------------------------------------
982 sub parse {
983     my ( $translator, $data ) = @_;
984     $parser ||= Parse::RecDescent->new($GRAMMAR);
985
986     $::RD_TRACE  = $translator->trace ? 1 : undef;
987     $DEBUG       = $translator->debug;
988
989     unless (defined $parser) {
990         return $translator->error("Error instantiating Parse::RecDescent ".
991             "instance: Bad grammer");
992     }
993
994     my $result = $parser->startrule($data);
995     die "Parse failed.\n" unless defined $result;
996     warn Dumper($result) if $DEBUG;
997
998     my $schema = $translator->schema;
999     my @tables = sort { 
1000         ( $result->{ $a }{'order'} || 0 ) <=> ( $result->{ $b }{'order'} || 0 )
1001     } keys %{ $result };
1002
1003     for my $table_name ( @tables ) {
1004         my $tdata =  $result->{ $table_name };
1005         my $table =  $schema->add_table( 
1006             #schema => $tdata->{'schema_name'},
1007             name   => $tdata->{'table_name'},
1008         ) or die "Couldn't create table '$table_name': " . $schema->error;
1009
1010         $table->extra(temporary => 1) if $tdata->{'temporary'};
1011
1012         $table->comments( $tdata->{'comments'} );
1013
1014         my @fields = sort { 
1015             $tdata->{'fields'}{ $a }{'order'} 
1016             <=>
1017             $tdata->{'fields'}{ $b }{'order'}
1018         } keys %{ $tdata->{'fields'} };
1019
1020         for my $fname ( @fields ) {
1021             my $fdata = $tdata->{'fields'}{ $fname };
1022             next if $fdata->{'drop'};
1023             my $field = $table->add_field(
1024                 name              => $fdata->{'name'},
1025                 data_type         => $fdata->{'data_type'},
1026                 size              => $fdata->{'size'},
1027                 default_value     => $fdata->{'default'},
1028                 is_auto_increment => $fdata->{'is_auto_increment'},
1029                 is_nullable       => $fdata->{'is_nullable'},
1030                 comments          => $fdata->{'comments'},
1031             ) or die $table->error;
1032
1033             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
1034
1035             for my $cdata ( @{ $fdata->{'constraints'} } ) {
1036                 next unless $cdata->{'type'} eq 'foreign_key';
1037                 $cdata->{'fields'} ||= [ $field->name ];
1038                 push @{ $tdata->{'constraints'} }, $cdata;
1039             }
1040         }
1041
1042         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
1043             my $index  =  $table->add_index(
1044                 name   => $idata->{'name'},
1045                 type   => uc $idata->{'type'},
1046                 fields => $idata->{'fields'},
1047             ) or die $table->error . ' ' . $table->name;
1048         }
1049
1050         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
1051             my $constraint       =  $table->add_constraint(
1052                 name             => $cdata->{'name'},
1053                 type             => $cdata->{'type'},
1054                 fields           => $cdata->{'fields'},
1055                 reference_table  => $cdata->{'reference_table'},
1056                 reference_fields => $cdata->{'reference_fields'},
1057                 match_type       => $cdata->{'match_type'} || '',
1058                 on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
1059                 on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
1060                 expression       => $cdata->{'expression'},
1061             ) or die "Can't add constraint of type '" .
1062                 $cdata->{'type'} .  "' to table '" . $table->name . 
1063                 "': " . $table->error;
1064         }
1065     }
1066
1067     return 1;
1068 }
1069
1070 1;
1071
1072 # -------------------------------------------------------------------
1073 # Rescue the drowning and tie your shoestrings.
1074 # Henry David Thoreau 
1075 # -------------------------------------------------------------------
1076
1077 =pod
1078
1079 =head1 AUTHORS
1080
1081 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>,
1082 Allen Day E<lt>allenday@ucla.eduE<gt>.
1083
1084 =head1 SEE ALSO
1085
1086 perl(1), Parse::RecDescent.
1087
1088 =cut