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     push @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     push @output, map { "$_;\n\n" } @table_defs;
 220     if ( @fks ) {
 221         push @output, "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
 222         push @output, map { "$_;\n\n" } @fks;
 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 wantarray
 239         ? @output
 240         : join ('', @output);
 241 }
 242
 243 # -------------------------------------------------------------------
 244 sub mk_name {
 245     my $basename      = shift || '';
 246     my $type          = shift || '';
 247     my $scope         = shift || '';
 248     my $critical      = shift || '';
 249     my $basename_orig = $basename;
 250 #    my $max_id_length = 62;
 251     my $max_name      = $type
 252                         ? $max_id_length - (length($type) + 1)
 253                         : $max_id_length;
 254     $basename         = substr( $basename, 0, $max_name )
 255                         if length( $basename ) > $max_name;
 256     my $name          = $type ? "${type}_$basename" : $basename;
 257
 258     if ( $basename ne $basename_orig and $critical ) {
 259         my $show_type = $type ? "+'$type'" : "";
 260         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 261             "character limit to make '$name'\n" if $WARN;
 262         $truncated{ $basename_orig } = $name;
 263     }
 264
 265     $scope ||= \%global_names;
 266     if ( my $prev = $scope->{ $name } ) {
 267         my $name_orig = $name;
 268         $name        .= sprintf( "%02d", ++$prev );
 269         substr($name, $max_id_length - 3) = "00"
 270             if length( $name ) > $max_id_length;
 271
 272         warn "The name '$name_orig' has been changed to ",
 273              "'$name' to make it unique.\n" if $WARN;
 274
 275         $scope->{ $name_orig }++;
 276     }
 277
 278     $scope->{ $name }++;
 279     return $name;
 280 }
 281
 282 # -------------------------------------------------------------------
 283 sub unreserve {
 284     my $name            = shift || '';
 285     my $schema_obj_name = shift || '';
 286
 287     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 288
 289     # also trap fields that don't begin with a letter
 290     return $name if (!$reserved{ uc $name }) && $name =~ /^[a-z]/i;
 291
 292     if ( $schema_obj_name ) {
 293         ++$unreserve{"$schema_obj_name.$name"};
 294     }
 295     else {
 296         ++$unreserve{"$name (table name)"};
 297     }
 298
 299     my $unreserve = sprintf '%s_', $name;
 300     return $unreserve.$suffix;
 301 }
 302
 303 # -------------------------------------------------------------------
 304 sub next_unused_name {
 305     my $name = shift || '';
 306     if ( !defined( $used_names{$name} ) ) {
 307         $used_names{$name} = $name;
 308         return $name;
 309     }
 310
 311     my $i = 2;
 312     while ( defined( $used_names{ $name . $i } ) ) {
 313         ++$i;
 314     }
 315     $name .= $i;
 316     $used_names{$name} = $name;
 317     return $name;
 318 }
 319
 320
 321 sub create_table
 322 {
 323     my ($table, $options) = @_;
 324
 325     my $qt = $options->{quote_table_names} || '';
 326     my $qf = $options->{quote_field_names} || '';
 327     my $no_comments = $options->{no_comments} || 0;
 328     my $add_drop_table = $options->{add_drop_table} || 0;
 329     my $postgres_version = $options->{postgres_version} || 0;
 330
 331     my $table_name = $table->name or next;
 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
 396     my $temporary = "";
 397
 398     if(exists $table->{extra}{temporary}) {
 399         $temporary = $table->{extra}{temporary} ? "TEMPORARY " : "";
 400     }
 401
 402     my $create_statement;
 403     $create_statement = join("\n", @comments);
 404     if ($add_drop_table) {
 405         if ($postgres_version >= 8.2) {
 406             $create_statement .= qq[DROP TABLE IF EXISTS $qt$table_name_ur$qt CASCADE;\n];
 407             $create_statement .= join (";\n", @type_drops) . ";\n"
 408                 if $postgres_version >= 8.3 && scalar @type_drops;
 409         } else {
 410             $create_statement .= qq[DROP TABLE $qt$table_name_ur$qt CASCADE;\n];
 411         }
 412     }
 413     $create_statement .= join(";\n", @type_defs) . ";\n"
 414         if $postgres_version >= 8.3 && scalar @type_defs;
 415     $create_statement .= qq[CREATE ${temporary}TABLE $qt$table_name_ur$qt (\n].
 416                             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 417                             "\n)"
 418                             ;
 419     $create_statement .= @index_defs ? ';' : q{};
 420     $create_statement .= ( $create_statement =~ /;$/ ? "\n" : q{} )
 421         . join(";\n", @index_defs);
 422
 423     return $create_statement, \@fks;
 424 }
 425
 426 sub create_view {
 427     my ($view, $options) = @_;
 428     my $qt = $options->{quote_table_names} || '';
 429     my $qf = $options->{quote_field_names} || '';
 430     my $add_drop_view = $options->{add_drop_view};
 431
 432     my $view_name = $view->name;
 433     debug("PKG: Looking at view '${view_name}'\n");
 434
 435     my $create = '';
 436     $create .= "--\n-- View: ${qt}${view_name}${qt}\n--\n"
 437         unless $options->{no_comments};
 438     $create .= "DROP VIEW ${qt}${view_name}${qt};\n" if $add_drop_view;
 439     $create .= 'CREATE';
 440
 441     my $extra = $view->extra;
 442     $create .= " TEMPORARY" if exists($extra->{temporary}) && $extra->{temporary};
 443     $create .= " VIEW ${qt}${view_name}${qt}";
 444
 445     if ( my @fields = $view->fields ) {
 446         my $field_list = join ', ', map { "${qf}${_}${qf}" } @fields;
 447         $create .= " ( ${field_list} )";
 448     }
 449
 450     if ( my $sql = $view->sql ) {
 451         $create .= " AS\n    ${sql}\n";
 452     }
 453
 454     if ( $extra->{check_option} ) {
 455         $create .= ' WITH ' . uc $extra->{check_option} . ' CHECK OPTION';
 456     }
 457
 458     return $create;
 459 }
 460
 461 {
 462
 463     my %field_name_scope;
 464
 465     sub create_field
 466     {
 467         my ($field, $options) = @_;
 468
 469         my $qt = $options->{quote_table_names} || '';
 470         my $qf = $options->{quote_field_names} || '';
 471         my $table_name = $field->table->name;
 472         my $constraint_defs = $options->{constraint_defs} || [];
 473         my $postgres_version = $options->{postgres_version} || 0;
 474         my $type_defs = $options->{type_defs} || [];
 475         my $type_drops = $options->{type_drops} || [];
 476
 477         $field_name_scope{$table_name} ||= {};
 478         my $field_name    = $field->name;
 479         my $field_name_ur = $qf ? $field_name : unreserve($field_name, $table_name );
 480         $field->name($field_name_ur);
 481         my $field_comments = $field->comments
 482             ? "-- " . $field->comments . "\n  "
 483             : '';
 484
 485         my $field_def     = $field_comments.qq[$qf$field_name_ur$qf];
 486
 487         #
 488         # Datatype
 489         #
 490         my @size      = $field->size;
 491         my $data_type = lc $field->data_type;
 492         my %extra     = $field->extra;
 493         my $list      = $extra{'list'} || [];
 494         # todo deal with embedded quotes
 495         my $commalist = join( ', ', map { qq['$_'] } @$list );
 496
 497         if ($postgres_version >= 8.3 && $field->data_type eq 'enum') {
 498             my $type_name = $field->table->name . '_' . $field->name . '_type';
 499             $field_def .= ' '. $type_name;
 500             push @$type_defs, "CREATE TYPE $type_name AS ENUM ($commalist)";
 501             push @$type_drops, "DROP TYPE IF EXISTS $type_name";
 502         } else {
 503             $field_def .= ' '. convert_datatype($field);
 504         }
 505
 506         #
 507         # Default value
 508         #
 509         my $default = $field->default_value;
 510         if ( defined $default ) {
 511             SQL::Translator::Producer->_apply_default_value(
 512               \$field_def,
 513               $default,
 514               [
 515                 'NULL'              => \'NULL',
 516                 'now()'             => 'now()',
 517                 'CURRENT_TIMESTAMP' => 'CURRENT_TIMESTAMP',
 518               ],
 519             );
 520         }
 521
 522         #
 523         # Not null constraint
 524         #
 525         $field_def .= ' NOT NULL' unless $field->is_nullable;
 526
 527         return $field_def;
 528     }
 529 }
 530
 531     sub create_index
 532     {
 533         my ($index, $options) = @_;
 534
 535         my $qt = $options->{quote_table_names} ||'';
 536         my $qf = $options->{quote_field_names} ||'';
 537         my $table_name = $index->table->name;
 538 #        my $table_name_ur = $qt ? unreserve($table_name) : $table_name;
 539
 540         my ($index_def, @constraint_defs);
 541
 542         my $name = $index->name || '';
 543         if ( $name ) {
 544             $name = next_unused_name($name);
 545         }
 546
 547         my $type = $index->type || NORMAL;
 548         my @fields     =
 549             map { $_ =~ s/\(.+\)//; $_ }
 550         map { $qt ? $_ : unreserve($_, $table_name ) }
 551         $index->fields;
 552         next unless @fields;
 553
 554         my $def_start = qq[CONSTRAINT "$name" ];
 555         if ( $type eq PRIMARY_KEY ) {
 556             push @constraint_defs, "${def_start}PRIMARY KEY ".
 557                 '(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
 558         }
 559         elsif ( $type eq UNIQUE ) {
 560             push @constraint_defs, "${def_start}UNIQUE " .
 561                 '(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
 562         }
 563         elsif ( $type eq NORMAL ) {
 564             $index_def =
 565                 "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
 566                 join( ', ', map { qq[$qf$_$qf] } @fields ).
 567                 ')'
 568                 ;
 569         }
 570         else {
 571             warn "Unknown index type ($type) on table $table_name.\n"
 572                 if $WARN;
 573         }
 574
 575         return $index_def, \@constraint_defs;
 576     }
 577
 578     sub create_constraint
 579     {
 580         my ($c, $options) = @_;
 581
 582         my $qf = $options->{quote_field_names} ||'';
 583         my $qt = $options->{quote_table_names} ||'';
 584         my $table_name = $c->table->name;
 585         my (@constraint_defs, @fks);
 586
 587         my $name = $c->name || '';
 588         if ( $name ) {
 589             $name = next_unused_name($name);
 590         }
 591
 592         my @fields     =
 593             map { $_ =~ s/\(.+\)//; $_ }
 594         map { $qt ? $_ : unreserve( $_, $table_name )}
 595         $c->fields;
 596
 597         my @rfields     =
 598             map { $_ =~ s/\(.+\)//; $_ }
 599         map { $qt ? $_ : unreserve( $_, $table_name )}
 600         $c->reference_fields;
 601
 602         next if !@fields && $c->type ne CHECK_C;
 603         my $def_start = $name ? qq[CONSTRAINT "$name" ] : '';
 604         if ( $c->type eq PRIMARY_KEY ) {
 605             push @constraint_defs, "${def_start}PRIMARY KEY ".
 606                 '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 607         }
 608         elsif ( $c->type eq UNIQUE ) {
 609             $name = next_unused_name($name);
 610             push @constraint_defs, "${def_start}UNIQUE " .
 611                 '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 612         }
 613         elsif ( $c->type eq CHECK_C ) {
 614             my $expression = $c->expression;
 615             push @constraint_defs, "${def_start}CHECK ($expression)";
 616         }
 617         elsif ( $c->type eq FOREIGN_KEY ) {
 618             my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" .
 619                 join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
 620                 "\n  REFERENCES " . $qt . $c->reference_table . $qt;
 621
 622             if ( @rfields ) {
 623                 $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
 624             }
 625
 626             if ( $c->match_type ) {
 627                 $def .= ' MATCH ' .
 628                     ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 629             }
 630
 631             if ( $c->on_delete ) {
 632                 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 633             }
 634
 635             if ( $c->on_update ) {
 636                 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 637             }
 638
 639             if ( $c->deferrable ) {
 640                 $def .= ' DEFERRABLE';
 641             }
 642
 643             push @fks, "$def";
 644         }
 645
 646         return \@constraint_defs, \@fks;
 647     }
 648
 649 sub convert_datatype
 650 {
 651     my ($field) = @_;
 652
 653     my @size      = $field->size;
 654     my $data_type = lc $field->data_type;
 655
 656     if ( $data_type eq 'enum' ) {
 657 #        my $len = 0;
 658 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 659 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 660 #        push @$constraint_defs,
 661 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 662 #           qq[IN ($commalist))];
 663         $data_type = 'character varying';
 664     }
 665     elsif ( $data_type eq 'set' ) {
 666         $data_type = 'character varying';
 667     }
 668     elsif ( $field->is_auto_increment ) {
 669         if ( defined $size[0] && $size[0] > 11 ) {
 670             $data_type = 'bigserial';
 671         }
 672         else {
 673             $data_type = 'serial';
 674         }
 675         undef @size;
 676     }
 677     else {
 678         $data_type  = defined $translate{ $data_type } ?
 679             $translate{ $data_type } :
 680             $data_type;
 681     }
 682
 683     if ( $data_type =~ /^time/i || $data_type =~ /^interval/i ) {
 684         if ( defined $size[0] && $size[0] > 6 ) {
 685             $size[0] = 6;
 686         }
 687     }
 688
 689     if ( $data_type eq 'integer' ) {
 690         if ( defined $size[0] && $size[0] > 0) {
 691             if ( $size[0] > 10 ) {
 692                 $data_type = 'bigint';
 693             }
 694             elsif ( $size[0] < 5 ) {
 695                 $data_type = 'smallint';
 696             }
 697             else {
 698                 $data_type = 'integer';
 699             }
 700         }
 701         else {
 702             $data_type = 'integer';
 703         }
 704     }
 705     my @type_without_size = qw/bigint boolean box bytea cidr circle date inet
 706                                integer smallint text line lseg macaddr money
 707                                path point polygon real/;
 708     foreach (@type_without_size) {
 709         if ( $data_type =~ qr/$_/ ) {
 710             undef @size; last;
 711         }
 712     }
 713
 714     if (defined $size[0] && $size[0] > 0 && $data_type =~ /^time/i ) {
 715         $data_type =~ s/^(time.*?)( with.*)?$/$1($size[0])/;
 716         $data_type .= $2 if(defined $2);
 717     } elsif ( defined $size[0] && $size[0] > 0 ) {
 718             $data_type .= '(' . join( ',', @size ) . ')';
 719     }
 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     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP NOT NULL',
 741                       $to_field->table->name,
 742                       $to_field->name)
 743        if ( !$from_field->is_nullable and $to_field->is_nullable );
 744
 745
 746     my $from_dt = convert_datatype($from_field);
 747     my $to_dt   = convert_datatype($to_field);
 748     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s',
 749                        $to_field->table->name,
 750                        $to_field->name,
 751                        $to_dt) if($to_dt ne $from_dt);
 752
 753     push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s',
 754                        $to_field->table->name,
 755                        $from_field->name,
 756                        $to_field->name) if($from_field->name ne $to_field->name);
 757
 758     my $old_default = $from_field->default_value;
 759     my $new_default = $to_field->default_value;
 760     my $default_value = $to_field->default_value;
 761
 762     # fixes bug where output like this was created:
 763     # ALTER TABLE users ALTER COLUMN column SET DEFAULT ThisIsUnescaped;
 764     if(ref $default_value eq "SCALAR" ) {
 765         $default_value = $$default_value;
 766     } elsif( defined $default_value && $to_dt =~ /^(character|text)/xsmi ) {
 767         $default_value =~ s/'/''/xsmg;
 768         $default_value = q(') . $default_value . q(');
 769     }
 770
 771     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
 772                        $to_field->table->name,
 773                        $to_field->name,
 774                        $default_value)
 775         if ( defined $new_default &&
 776              (!defined $old_default || $old_default ne $new_default) );
 777
 778      # fixes bug where removing the DEFAULT statement of a column
 779      # would result in no change
 780
 781      push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
 782                        $to_field->table->name,
 783                        $to_field->name)
 784         if ( !defined $new_default && defined $old_default );
 785
 786
 787     return wantarray ? @out : join("\n", @out);
 788 }
 789
 790 sub rename_field { alter_field(@_) }
 791
 792 sub add_field
 793 {
 794     my ($new_field) = @_;
 795
 796     my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
 797                       $new_field->table->name,
 798                       create_field($new_field));
 799     return $out;
 800
 801 }
 802
 803 sub drop_field
 804 {
 805     my ($old_field) = @_;
 806
 807     my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
 808                       $old_field->table->name,
 809                       $old_field->name);
 810
 811     return $out;
 812 }
 813
 814 sub alter_table {
 815     my ($to_table, $options) = @_;
 816     my $qt = $options->{quote_table_names} || '';
 817     my $out = sprintf('ALTER TABLE %s %s',
 818                       $qt . $to_table->name . $qt,
 819                       $options->{alter_table_action});
 820     return $out;
 821 }
 822
 823 sub rename_table {
 824     my ($old_table, $new_table, $options) = @_;
 825     my $qt = $options->{quote_table_names} || '';
 826     $options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
 827     return alter_table($old_table, $options);
 828 }
 829
 830 sub alter_create_index {
 831     my ($index, $options) = @_;
 832     my $qt = $options->{quote_table_names} || '';
 833     my $qf = $options->{quote_field_names} || '';
 834     my ($idef, $constraints) = create_index($index, {
 835         quote_field_names => $qf,
 836         quote_table_names => $qt,
 837         table_name => $index->table->name,
 838     });
 839     return $index->type eq NORMAL ? $idef
 840         : sprintf('ALTER TABLE %s ADD %s',
 841               $qt . $index->table->name . $qt,
 842               join(q{}, @$constraints)
 843           );
 844 }
 845
 846 sub alter_drop_index {
 847     my ($index, $options) = @_;
 848     my $index_name = $index->name;
 849     return "DROP INDEX $index_name";
 850 }
 851
 852 sub alter_drop_constraint {
 853     my ($c, $options) = @_;
 854     my $qt = $options->{quote_table_names} || '';
 855     my $qc = $options->{quote_field_names} || '';
 856     my $out = sprintf('ALTER TABLE %s DROP CONSTRAINT %s',
 857                       $qt . $c->table->name . $qt,
 858                       $qc . $c->name . $qc );
 859     return $out;
 860 }
 861
 862 sub alter_create_constraint {
 863     my ($index, $options) = @_;
 864     my $qt = $options->{quote_table_names} || '';
 865     my ($defs, $fks) = create_constraint(@_);
 866
 867     # return if there are no constraint definitions so we don't run
 868     # into output like this:
 869     # ALTER TABLE users ADD ;
 870
 871     return unless(@{$defs} || @{$fks});
 872     return $index->type eq FOREIGN_KEY ? join(q{}, @{$fks})
 873         : join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
 874               'ADD', join(q{}, @{$defs}, @{$fks})
 875           );
 876 }
 877
 878 sub drop_table {
 879     my ($table, $options) = @_;
 880     my $qt = $options->{quote_table_names} || '';
 881     return "DROP TABLE $qt$table$qt CASCADE";
 882 }
 883
 884 1;
 885
 886 # -------------------------------------------------------------------
 887 # Life is full of misery, loneliness, and suffering --
 888 # and it's all over much too soon.
 889 # Woody Allen
 890 # -------------------------------------------------------------------
 891
 892 =pod
 893
 894 =head1 SEE ALSO
 895
 896 SQL::Translator, SQL::Translator::Producer::Oracle.
 897
 898 =head1 AUTHOR
 899
 900 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 901
 902 =cut