lib/SQL/Translator/Producer/PostgreSQL.pm

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