lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::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::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
  24
  25 =head1 SYNOPSIS
  26
  27   my $t = SQL::Translator->new( parser => '...', producer => 'PostgreSQL' );
  28   $t->translate;
  29
  30 =head1 DESCRIPTION
  31
  32 Creates a DDL suitable for PostgreSQL.  Very heavily based on the Oracle
  33 producer.
  34
  35 =cut
  36
  37 use strict;
  38 use warnings;
  39 use vars qw[ $DEBUG $WARN $VERSION %used_names ];
  40 $VERSION = '1.59';
  41 $DEBUG = 0 unless defined $DEBUG;
  42
  43 use base qw(SQL::Translator::Producer);
  44 use SQL::Translator::Schema::Constants;
  45 use SQL::Translator::Utils qw(debug header_comment);
  46 use Data::Dumper;
  47
  48 my %translate;
  49 my $max_id_length;
  50
  51 BEGIN {
  52
  53  %translate  = (
  54     #
  55     # MySQL types
  56     #
  57     bigint     => 'bigint',
  58     double     => 'numeric',
  59     decimal    => 'numeric',
  60     float      => 'numeric',
  61     int        => 'integer',
  62     mediumint  => 'integer',
  63     smallint   => 'smallint',
  64     tinyint    => 'smallint',
  65     char       => 'character',
  66     varchar    => 'character varying',
  67     longtext   => 'text',
  68     mediumtext => 'text',
  69     text       => 'text',
  70     tinytext   => 'text',
  71     tinyblob   => 'bytea',
  72     blob       => 'bytea',
  73     mediumblob => 'bytea',
  74     longblob   => 'bytea',
  75     enum       => 'character varying',
  76     set        => 'character varying',
  77     date       => 'date',
  78     datetime   => 'timestamp',
  79     time       => 'time',
  80     timestamp  => 'timestamp',
  81     year       => 'date',
  82
  83     #
  84     # Oracle types
  85     #
  86     number     => 'integer',
  87     char       => 'character',
  88     varchar2   => 'character varying',
  89     long       => 'text',
  90     CLOB       => 'bytea',
  91     date       => 'date',
  92
  93     #
  94     # Sybase types
  95     #
  96     int        => 'integer',
  97     money      => 'money',
  98     varchar    => 'character varying',
  99     datetime   => 'timestamp',
 100     text       => 'text',
 101     real       => 'numeric',
 102     comment    => 'text',
 103     bit        => 'bit',
 104     tinyint    => 'smallint',
 105     float      => 'numeric',
 106 );
 107
 108  $max_id_length = 62;
 109 }
 110 my %reserved = map { $_, 1 } qw[
 111     ALL ANALYSE ANALYZE AND ANY AS ASC
 112     BETWEEN BINARY BOTH
 113     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
 114     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
 115     DEFAULT DEFERRABLE DESC DISTINCT DO
 116     ELSE END EXCEPT
 117     FALSE FOR FOREIGN FREEZE FROM FULL
 118     GROUP HAVING
 119     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
 120     JOIN LEADING LEFT LIKE LIMIT
 121     NATURAL NEW NOT NOTNULL NULL
 122     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
 123     PRIMARY PUBLIC REFERENCES RIGHT
 124     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
 125     UNION UNIQUE USER USING VERBOSE WHEN WHERE
 126 ];
 127
 128 # my $max_id_length    = 62;
 129 my %used_identifiers = ();
 130 my %global_names;
 131 my %unreserve;
 132 my %truncated;
 133
 134 =pod
 135
 136 =head1 PostgreSQL Create Table Syntax
 137
 138   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
 139       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
 140       | table_constraint }  [, ... ]
 141   )
 142   [ INHERITS ( parent_table [, ... ] ) ]
 143   [ WITH OIDS | WITHOUT OIDS ]
 144
 145 where column_constraint is:
 146
 147   [ CONSTRAINT constraint_name ]
 148   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
 149     CHECK (expression) |
 150     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
 151       [ ON DELETE action ] [ ON UPDATE action ] }
 152   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 153
 154 and table_constraint is:
 155
 156   [ CONSTRAINT constraint_name ]
 157   { UNIQUE ( column_name [, ... ] ) |
 158     PRIMARY KEY ( column_name [, ... ] ) |
 159     CHECK ( expression ) |
 160     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 161       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 162   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 163
 164 =head1 Create Index Syntax
 165
 166   CREATE [ UNIQUE ] INDEX index_name ON table
 167       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 168       [ WHERE predicate ]
 169   CREATE [ UNIQUE ] INDEX index_name ON table
 170       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 171       [ WHERE predicate ]
 172
 173 =cut
 174
 175 # -------------------------------------------------------------------
 176 sub produce {
 177     my $translator     = shift;
 178     local $DEBUG             = $translator->debug;
 179     local $WARN              = $translator->show_warnings;
 180     my $no_comments    = $translator->no_comments;
 181     my $add_drop_table = $translator->add_drop_table;
 182     my $schema         = $translator->schema;
 183     my $pargs          = $translator->producer_args;
 184     local %used_names  = ();
 185
 186     my $postgres_version = $pargs->{postgres_version} || 0;
 187
 188     my $qt = '';
 189     $qt = '"' if ($translator->quote_table_names);
 190     my $qf = '';
 191     $qf = '"' if ($translator->quote_field_names);
 192
 193     my $output;
 194     $output .= header_comment unless ($no_comments);
 195
 196     my (@table_defs, @fks);
 197     for my $table ( $schema->get_tables ) {
 198
 199         my ($table_def, $fks) = create_table($table,
 200                                              { quote_table_names => $qt,
 201                                                quote_field_names => $qf,
 202                                                no_comments => $no_comments,
 203                                                postgres_version => $postgres_version,
 204                                                add_drop_table => $add_drop_table,});
 205         push @table_defs, $table_def;
 206         push @fks, @$fks;
 207
 208     }
 209
 210     for my $view ( $schema->get_views ) {
 211       push @table_defs, create_view($view, {
 212         add_drop_view     => $add_drop_table,
 213         quote_table_names => $qt,
 214         quote_field_names => $qf,
 215         no_comments       => $no_comments,
 216       });
 217     }
 218
 219     $output  = join(";\n\n", @table_defs) . ";\n\n";
 220     if ( @fks ) {
 221         $output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
 222         $output .= join( ";\n\n", @fks ) . ";\n";
 223     }
 224
 225     if ( $WARN ) {
 226         if ( %truncated ) {
 227             warn "Truncated " . keys( %truncated ) . " names:\n";
 228             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 229         }
 230
 231         if ( %unreserve ) {
 232             warn "Encounted " . keys( %unreserve ) .
 233                 " unsafe names in schema (reserved or invalid):\n";
 234             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 235         }
 236     }
 237
 238     return $output;
 239 }
 240
 241 # -------------------------------------------------------------------
 242 sub mk_name {
 243     my $basename      = shift || '';
 244     my $type          = shift || '';
 245     my $scope         = shift || '';
 246     my $critical      = shift || '';
 247     my $basename_orig = $basename;
 248 #    my $max_id_length = 62;
 249     my $max_name      = $type
 250                         ? $max_id_length - (length($type) + 1)
 251                         : $max_id_length;
 252     $basename         = substr( $basename, 0, $max_name )
 253                         if length( $basename ) > $max_name;
 254     my $name          = $type ? "${type}_$basename" : $basename;
 255
 256     if ( $basename ne $basename_orig and $critical ) {
 257         my $show_type = $type ? "+'$type'" : "";
 258         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 259             "character limit to make '$name'\n" if $WARN;
 260         $truncated{ $basename_orig } = $name;
 261     }
 262
 263     $scope ||= \%global_names;
 264     if ( my $prev = $scope->{ $name } ) {
 265         my $name_orig = $name;
 266         $name        .= sprintf( "%02d", ++$prev );
 267         substr($name, $max_id_length - 3) = "00"
 268             if length( $name ) > $max_id_length;
 269
 270         warn "The name '$name_orig' has been changed to ",
 271              "'$name' to make it unique.\n" if $WARN;
 272
 273         $scope->{ $name_orig }++;
 274     }
 275
 276     $scope->{ $name }++;
 277     return $name;
 278 }
 279
 280 # -------------------------------------------------------------------
 281 sub unreserve {
 282     my $name            = shift || '';
 283     my $schema_obj_name = shift || '';
 284
 285     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 286
 287     # also trap fields that don't begin with a letter
 288     return $name if (!$reserved{ uc $name }) && $name =~ /^[a-z]/i;
 289
 290     if ( $schema_obj_name ) {
 291         ++$unreserve{"$schema_obj_name.$name"};
 292     }
 293     else {
 294         ++$unreserve{"$name (table name)"};
 295     }
 296
 297     my $unreserve = sprintf '%s_', $name;
 298     return $unreserve.$suffix;
 299 }
 300
 301 # -------------------------------------------------------------------
 302 sub next_unused_name {
 303     my $name = shift || '';
 304     if ( !defined( $used_names{$name} ) ) {
 305         $used_names{$name} = $name;
 306         return $name;
 307     }
 308
 309     my $i = 2;
 310     while ( defined( $used_names{ $name . $i } ) ) {
 311         ++$i;
 312     }
 313     $name .= $i;
 314     $used_names{$name} = $name;
 315     return $name;
 316 }
 317
 318
 319 sub create_table
 320 {
 321     my ($table, $options) = @_;
 322
 323     my $qt = $options->{quote_table_names} || '';
 324     my $qf = $options->{quote_field_names} || '';
 325     my $no_comments = $options->{no_comments} || 0;
 326     my $add_drop_table = $options->{add_drop_table} || 0;
 327     my $postgres_version = $options->{postgres_version} || 0;
 328
 329     my $table_name = $table->name or next;
 330     $table_name    = mk_name( $table_name, '', undef, 1 );
 331     my ( $fql_tbl_name ) = ( $table_name =~ s/\W(.*)$// ) ? $1 : q{};
 332     my $table_name_ur = $qt ? $table_name
 333         : $fql_tbl_name ? join('.', $table_name, unreserve($fql_tbl_name))
 334         : unreserve($table_name);
 335     $table->name($table_name_ur);
 336
 337 # print STDERR "$table_name table_name\n";
 338     my ( @comments, @field_defs, @sequence_defs, @constraint_defs, @type_defs, @type_drops, @fks );
 339
 340     push @comments, "--\n-- Table: $table_name_ur\n--\n" unless $no_comments;
 341
 342     if ( $table->comments and !$no_comments ){
 343         my $c = "-- Comments: \n-- ";
 344         $c .= join "\n-- ",  $table->comments;
 345         $c .= "\n--\n";
 346         push @comments, $c;
 347     }
 348
 349     #
 350     # Fields
 351     #
 352     my %field_name_scope;
 353     for my $field ( $table->get_fields ) {
 354         push @field_defs, create_field($field, { quote_table_names => $qt,
 355                                                  quote_field_names => $qf,
 356                                                  table_name => $table_name_ur,
 357                                                  postgres_version => $postgres_version,
 358                                                  type_defs => \@type_defs,
 359                                                  type_drops => \@type_drops,
 360                                                  constraint_defs => \@constraint_defs,});
 361     }
 362
 363     #
 364     # Index Declarations
 365     #
 366     my @index_defs = ();
 367  #   my $idx_name_default;
 368     for my $index ( $table->get_indices ) {
 369         my ($idef, $constraints) = create_index($index,
 370                                               {
 371                                                   quote_field_names => $qf,
 372                                                   quote_table_names => $qt,
 373                                                   table_name => $table_name,
 374                                               });
 375         $idef and push @index_defs, $idef;
 376         push @constraint_defs, @$constraints;
 377     }
 378
 379     #
 380     # Table constraints
 381     #
 382     my $c_name_default;
 383     for my $c ( $table->get_constraints ) {
 384         my ($cdefs, $fks) = create_constraint($c,
 385                                               {
 386                                                   quote_field_names => $qf,
 387                                                   quote_table_names => $qt,
 388                                                   table_name => $table_name,
 389                                               });
 390         push @constraint_defs, @$cdefs;
 391         push @fks, @$fks;
 392     }
 393
 394
 395     my $temporary = "";
 396
 397     if(exists $table->{extra}{temporary}) {
 398         $temporary = $table->{extra}{temporary} ? "TEMPORARY " : "";
 399     }
 400
 401     my $create_statement;
 402     $create_statement = join("\n", @comments);
 403     if ($add_drop_table) {
 404         if ($postgres_version >= 8.2) {
 405             $create_statement .= qq[DROP TABLE IF EXISTS $qt$table_name_ur$qt CASCADE;\n];
 406             $create_statement .= join ("\n", @type_drops) . "\n"
 407                 if $postgres_version >= 8.3;
 408         } else {
 409             $create_statement .= qq[DROP TABLE $qt$table_name_ur$qt CASCADE;\n];
 410         }
 411     }
 412     $create_statement .= join("\n", @type_defs) . "\n"
 413         if $postgres_version >= 8.3;
 414     $create_statement .= qq[CREATE ${temporary}TABLE $qt$table_name_ur$qt (\n].
 415                             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 416                             "\n)"
 417                             ;
 418     $create_statement .= @index_defs ? ';' : q{};
 419     $create_statement .= ( $create_statement =~ /;$/ ? "\n" : q{} )
 420         . join(";\n", @index_defs);
 421
 422     return $create_statement, \@fks;
 423 }
 424
 425 sub create_view {
 426     my ($view, $options) = @_;
 427     my $qt = $options->{quote_table_names} || '';
 428     my $qf = $options->{quote_field_names} || '';
 429     my $add_drop_view = $options->{add_drop_view};
 430
 431     my $view_name = $view->name;
 432     debug("PKG: Looking at view '${view_name}'\n");
 433
 434     my $create = '';
 435     $create .= "--\n-- View: ${qt}${view_name}${qt}\n--\n"
 436         unless $options->{no_comments};
 437     $create .= "DROP VIEW ${qt}${view_name}${qt};\n" if $add_drop_view;
 438     $create .= 'CREATE';
 439
 440     my $extra = $view->extra;
 441     $create .= " TEMPORARY" if exists($extra->{temporary}) && $extra->{temporary};
 442     $create .= " VIEW ${qt}${view_name}${qt}";
 443
 444     if ( my @fields = $view->fields ) {
 445         my $field_list = join ', ', map { "${qf}${_}${qf}" } @fields;
 446         $create .= " ( ${field_list} )";
 447     }
 448
 449     if ( my $sql = $view->sql ) {
 450         $create .= " AS (\n    ${sql}\n  )";
 451     }
 452
 453     if ( $extra->{check_option} ) {
 454         $create .= ' WITH ' . uc $extra->{check_option} . ' CHECK OPTION';
 455     }
 456
 457     return $create;
 458 }
 459
 460 {
 461
 462     my %field_name_scope;
 463
 464     sub create_field
 465     {
 466         my ($field, $options) = @_;
 467
 468         my $qt = $options->{quote_table_names} || '';
 469         my $qf = $options->{quote_field_names} || '';
 470         my $table_name = $field->table->name;
 471         my $constraint_defs = $options->{constraint_defs} || [];
 472         my $postgres_version = $options->{postgres_version} || 0;
 473         my $type_defs = $options->{type_defs} || [];
 474         my $type_drops = $options->{type_drops} || [];
 475
 476         $field_name_scope{$table_name} ||= {};
 477         my $field_name    = mk_name(
 478                                     $field->name, '', $field_name_scope{$table_name}, 1
 479                                     );
 480         my $field_name_ur = $qf ? $field_name : unreserve($field_name, $table_name );
 481         $field->name($field_name_ur);
 482         my $field_comments = $field->comments
 483             ? "-- " . $field->comments . "\n  "
 484             : '';
 485
 486         my $field_def     = $field_comments.qq[$qf$field_name_ur$qf];
 487
 488         #
 489         # Datatype
 490         #
 491         my @size      = $field->size;
 492         my $data_type = lc $field->data_type;
 493         my %extra     = $field->extra;
 494         my $list      = $extra{'list'} || [];
 495         # todo deal with embedded quotes
 496         my $commalist = join( ', ', map { qq['$_'] } @$list );
 497
 498         if ($postgres_version >= 8.3 && $field->data_type eq 'enum') {
 499             my $type_name = $field->table->name . '_' . $field->name . '_type';
 500             $field_def .= ' '. $type_name;
 501             push @$type_defs, "CREATE TYPE $type_name AS ENUM ($commalist)";
 502             push @$type_drops, "DROP TYPE IF EXISTS $type_name";
 503         } else {
 504             $field_def .= ' '. convert_datatype($field);
 505         }
 506
 507         #
 508         # Default value
 509         #
 510         my $default = $field->default_value;
 511         if ( defined $default ) {
 512             SQL::Translator::Producer->_apply_default_value(
 513               \$field_def,
 514               $default,
 515               [
 516                 'NULL'              => \'NULL',
 517                 'now()'             => 'now()',
 518                 'CURRENT_TIMESTAMP' => 'CURRENT_TIMESTAMP',
 519               ],
 520             );
 521         }
 522
 523         #
 524         # Not null constraint
 525         #
 526         $field_def .= ' NOT NULL' unless $field->is_nullable;
 527
 528         return $field_def;
 529     }
 530 }
 531
 532     sub create_index
 533     {
 534         my ($index, $options) = @_;
 535
 536         my $qt = $options->{quote_table_names} ||'';
 537         my $qf = $options->{quote_field_names} ||'';
 538         my $table_name = $index->table->name;
 539 #        my $table_name_ur = $qt ? unreserve($table_name) : $table_name;
 540
 541         my ($index_def, @constraint_defs);
 542
 543         my $name = $index->name || '';
 544         if ( $name ) {
 545             $name = next_unused_name($name);
 546         }
 547
 548         my $type = $index->type || NORMAL;
 549         my @fields     =
 550             map { $_ =~ s/\(.+\)//; $_ }
 551         map { $qt ? $_ : unreserve($_, $table_name ) }
 552         $index->fields;
 553         next unless @fields;
 554
 555         my $def_start = qq[CONSTRAINT "$name" ];
 556         if ( $type eq PRIMARY_KEY ) {
 557             push @constraint_defs, "${def_start}PRIMARY KEY ".
 558                 '(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
 559         }
 560         elsif ( $type eq UNIQUE ) {
 561             push @constraint_defs, "${def_start}UNIQUE " .
 562                 '(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
 563         }
 564         elsif ( $type eq NORMAL ) {
 565             $index_def =
 566                 "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
 567                 join( ', ', map { qq[$qf$_$qf] } @fields ).
 568                 ')'
 569                 ;
 570         }
 571         else {
 572             warn "Unknown index type ($type) on table $table_name.\n"
 573                 if $WARN;
 574         }
 575
 576         return $index_def, \@constraint_defs;
 577     }
 578
 579     sub create_constraint
 580     {
 581         my ($c, $options) = @_;
 582
 583         my $qf = $options->{quote_field_names} ||'';
 584         my $qt = $options->{quote_table_names} ||'';
 585         my $table_name = $c->table->name;
 586         my (@constraint_defs, @fks);
 587
 588         my $name = $c->name || '';
 589         if ( $name ) {
 590             $name = next_unused_name($name);
 591         }
 592
 593         my @fields     =
 594             map { $_ =~ s/\(.+\)//; $_ }
 595         map { $qt ? $_ : unreserve( $_, $table_name )}
 596         $c->fields;
 597
 598         my @rfields     =
 599             map { $_ =~ s/\(.+\)//; $_ }
 600         map { $qt ? $_ : unreserve( $_, $table_name )}
 601         $c->reference_fields;
 602
 603         next if !@fields && $c->type ne CHECK_C;
 604         my $def_start = $name ? qq[CONSTRAINT "$name" ] : '';
 605         if ( $c->type eq PRIMARY_KEY ) {
 606             push @constraint_defs, "${def_start}PRIMARY KEY ".
 607                 '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 608         }
 609         elsif ( $c->type eq UNIQUE ) {
 610             $name = next_unused_name($name);
 611             push @constraint_defs, "${def_start}UNIQUE " .
 612                 '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 613         }
 614         elsif ( $c->type eq CHECK_C ) {
 615             my $expression = $c->expression;
 616             push @constraint_defs, "${def_start}CHECK ($expression)";
 617         }
 618         elsif ( $c->type eq FOREIGN_KEY ) {
 619             my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" .
 620                 join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
 621                 "\n  REFERENCES " . $qt . $c->reference_table . $qt;
 622
 623             if ( @rfields ) {
 624                 $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
 625             }
 626
 627             if ( $c->match_type ) {
 628                 $def .= ' MATCH ' .
 629                     ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 630             }
 631
 632             if ( $c->on_delete ) {
 633                 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 634             }
 635
 636             if ( $c->on_update ) {
 637                 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 638             }
 639
 640             if ( $c->deferrable ) {
 641                 $def .= ' DEFERRABLE';
 642             }
 643
 644             push @fks, "$def";
 645         }
 646
 647         return \@constraint_defs, \@fks;
 648     }
 649
 650 sub convert_datatype
 651 {
 652     my ($field) = @_;
 653
 654     my @size      = $field->size;
 655     my $data_type = lc $field->data_type;
 656
 657     if ( $data_type eq 'enum' ) {
 658 #        my $len = 0;
 659 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 660 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 661 #        push @$constraint_defs,
 662 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 663 #           qq[IN ($commalist))];
 664         $data_type = 'character varying';
 665     }
 666     elsif ( $data_type eq 'set' ) {
 667         $data_type = 'character varying';
 668     }
 669     elsif ( $field->is_auto_increment ) {
 670         if ( defined $size[0] && $size[0] > 11 ) {
 671             $data_type = 'bigserial';
 672         }
 673         else {
 674             $data_type = 'serial';
 675         }
 676         undef @size;
 677     }
 678     else {
 679         $data_type  = defined $translate{ $data_type } ?
 680             $translate{ $data_type } :
 681             $data_type;
 682     }
 683
 684     if ( $data_type =~ /timestamp/i ) {
 685         if ( defined $size[0] && $size[0] > 6 ) {
 686             $size[0] = 6;
 687         }
 688     }
 689
 690     if ( $data_type eq 'integer' ) {
 691         if ( defined $size[0] && $size[0] > 0) {
 692             if ( $size[0] > 10 ) {
 693                 $data_type = 'bigint';
 694             }
 695             elsif ( $size[0] < 5 ) {
 696                 $data_type = 'smallint';
 697             }
 698             else {
 699                 $data_type = 'integer';
 700             }
 701         }
 702         else {
 703             $data_type = 'integer';
 704         }
 705     }
 706     my @type_without_size = qw/bigint boolean box bytea cidr circle date inet
 707                                integer smallint text line lseg macaddr money
 708                                path point polygon real/;
 709     foreach (@type_without_size) {
 710         if ( $data_type =~ qr/$_/ ) {
 711             undef @size; last;
 712         }
 713     }
 714
 715     if ( defined $size[0] && $size[0] > 0 ) {
 716         $data_type .= '(' . join( ',', @size ) . ')';
 717     }
 718     elsif (defined $size[0] && $data_type eq 'timestamp' ) {
 719         $data_type .= '(' . join( ',', @size ) . ')';
 720     }
 721
 722
 723     return $data_type;
 724 }
 725
 726
 727 sub alter_field
 728 {
 729     my ($from_field, $to_field) = @_;
 730
 731     die "Can't alter field in another table"
 732         if($from_field->table->name ne $to_field->table->name);
 733
 734     my @out;
 735     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL',
 736                        $to_field->table->name,
 737                        $to_field->name) if(!$to_field->is_nullable and
 738                                            $from_field->is_nullable);
 739
 740     my $from_dt = convert_datatype($from_field);
 741     my $to_dt   = convert_datatype($to_field);
 742     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s',
 743                        $to_field->table->name,
 744                        $to_field->name,
 745                        $to_dt) if($to_dt ne $from_dt);
 746
 747     push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s',
 748                        $to_field->table->name,
 749                        $from_field->name,
 750                        $to_field->name) if($from_field->name ne $to_field->name);
 751
 752     my $old_default = $from_field->default_value;
 753     my $new_default = $to_field->default_value;
 754     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
 755                        $to_field->table->name,
 756                        $to_field->name,
 757                        $to_field->default_value)
 758         if ( defined $new_default &&
 759              (!defined $old_default || $old_default ne $new_default) );
 760
 761     return wantarray ? @out : join("\n", @out);
 762 }
 763
 764 sub rename_field { alter_field(@_) }
 765
 766 sub add_field
 767 {
 768     my ($new_field) = @_;
 769
 770     my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
 771                       $new_field->table->name,
 772                       create_field($new_field));
 773     return $out;
 774
 775 }
 776
 777 sub drop_field
 778 {
 779     my ($old_field) = @_;
 780
 781     my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
 782                       $old_field->table->name,
 783                       $old_field->name);
 784
 785     return $out;
 786 }
 787
 788 sub alter_table {
 789     my ($to_table, $options) = @_;
 790     my $qt = $options->{quote_table_names} || '';
 791     my $out = sprintf('ALTER TABLE %s %s',
 792                       $qt . $to_table->name . $qt,
 793                       $options->{alter_table_action});
 794     return $out;
 795 }
 796
 797 sub rename_table {
 798     my ($old_table, $new_table, $options) = @_;
 799     my $qt = $options->{quote_table_names} || '';
 800     $options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
 801     return alter_table($old_table, $options);
 802 }
 803
 804 sub alter_create_index {
 805     my ($index, $options) = @_;
 806     my $qt = $options->{quote_table_names} || '';
 807     my $qf = $options->{quote_field_names} || '';
 808     my ($idef, $constraints) = create_index($index, {
 809         quote_field_names => $qf,
 810         quote_table_names => $qt,
 811         table_name => $index->table->name,
 812     });
 813     return $index->type eq NORMAL ? $idef
 814         : sprintf('ALTER TABLE %s ADD %s',
 815               $qt . $index->table->name . $qt,
 816               join(q{}, @$constraints)
 817           );
 818 }
 819
 820 sub alter_drop_index {
 821     my ($index, $options) = @_;
 822     my $index_name = $index->name;
 823     return "DROP INDEX $index_name";
 824 }
 825
 826 sub alter_drop_constraint {
 827     my ($c, $options) = @_;
 828     my $qt = $options->{quote_table_names} || '';
 829     my $qc = $options->{quote_field_names} || '';
 830     my $out = sprintf('ALTER TABLE %s DROP CONSTRAINT %s',
 831                       $qt . $c->table->name . $qt,
 832                       $qc . $c->name . $qc );
 833     return $out;
 834 }
 835
 836 sub alter_create_constraint {
 837     my ($index, $options) = @_;
 838     my $qt = $options->{quote_table_names} || '';
 839     return $index->type eq FOREIGN_KEY ? join(q{}, @{create_constraint(@_)})
 840         : join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
 841               'ADD', join(q{}, map { @{$_} } create_constraint(@_))
 842           );
 843 }
 844
 845 sub drop_table {
 846     my ($table, $options) = @_;
 847     my $qt = $options->{quote_table_names} || '';
 848     return "DROP TABLE $qt$table$qt CASCADE";
 849 }
 850
 851 1;
 852
 853 # -------------------------------------------------------------------
 854 # Life is full of misery, loneliness, and suffering --
 855 # and it's all over much too soon.
 856 # Woody Allen
 857 # -------------------------------------------------------------------
 858
 859 =pod
 860
 861 =head1 SEE ALSO
 862
 863 SQL::Translator, SQL::Translator::Producer::Oracle.
 864
 865 =head1 AUTHOR
 866
 867 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 868
 869 =cut