lib/SQL/Translator/Parser/PostgreSQL.pm

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