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