lib/SQL/Translator/Parser/PostgreSQL.pm

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