lib/SQL/Translator/Parser/PostgreSQL.pm

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