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, %index_name );
  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 = next_unused_name(
 543         $index->name
 544         || join('_', $table_name, 'idx', ++$index_name{ $table_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
 706     my $type_with_size = join('|',
 707         'bit', 'varbit', 'character', 'bit varying', 'character varying'
 708     );
 709
 710     if ( $data_type !~ /$type_with_size/ ) {
 711         @size = ();
 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     return $data_type;
 722 }
 723
 724
 725 sub alter_field
 726 {
 727     my ($from_field, $to_field) = @_;
 728
 729     die "Can't alter field in another table"
 730         if($from_field->table->name ne $to_field->table->name);
 731
 732     my @out;
 733     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL',
 734                        $to_field->table->name,
 735                        $to_field->name) if(!$to_field->is_nullable and
 736                                            $from_field->is_nullable);
 737
 738     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP NOT NULL',
 739                       $to_field->table->name,
 740                       $to_field->name)
 741        if ( !$from_field->is_nullable and $to_field->is_nullable );
 742
 743
 744     my $from_dt = convert_datatype($from_field);
 745     my $to_dt   = convert_datatype($to_field);
 746     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s',
 747                        $to_field->table->name,
 748                        $to_field->name,
 749                        $to_dt) if($to_dt ne $from_dt);
 750
 751     push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s',
 752                        $to_field->table->name,
 753                        $from_field->name,
 754                        $to_field->name) if($from_field->name ne $to_field->name);
 755
 756     my $old_default = $from_field->default_value;
 757     my $new_default = $to_field->default_value;
 758     my $default_value = $to_field->default_value;
 759
 760     # fixes bug where output like this was created:
 761     # ALTER TABLE users ALTER COLUMN column SET DEFAULT ThisIsUnescaped;
 762     if(ref $default_value eq "SCALAR" ) {
 763         $default_value = $$default_value;
 764     } elsif( defined $default_value && $to_dt =~ /^(character|text)/xsmi ) {
 765         $default_value =~ s/'/''/xsmg;
 766         $default_value = q(') . $default_value . q(');
 767     }
 768
 769     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
 770                        $to_field->table->name,
 771                        $to_field->name,
 772                        $default_value)
 773         if ( defined $new_default &&
 774              (!defined $old_default || $old_default ne $new_default) );
 775
 776      # fixes bug where removing the DEFAULT statement of a column
 777      # would result in no change
 778
 779      push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
 780                        $to_field->table->name,
 781                        $to_field->name)
 782         if ( !defined $new_default && defined $old_default );
 783
 784
 785     return wantarray ? @out : join("\n", @out);
 786 }
 787
 788 sub rename_field { alter_field(@_) }
 789
 790 sub add_field
 791 {
 792     my ($new_field) = @_;
 793
 794     my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
 795                       $new_field->table->name,
 796                       create_field($new_field));
 797     return $out;
 798
 799 }
 800
 801 sub drop_field
 802 {
 803     my ($old_field) = @_;
 804
 805     my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
 806                       $old_field->table->name,
 807                       $old_field->name);
 808
 809     return $out;
 810 }
 811
 812 sub alter_table {
 813     my ($to_table, $options) = @_;
 814     my $qt = $options->{quote_table_names} || '';
 815     my $out = sprintf('ALTER TABLE %s %s',
 816                       $qt . $to_table->name . $qt,
 817                       $options->{alter_table_action});
 818     return $out;
 819 }
 820
 821 sub rename_table {
 822     my ($old_table, $new_table, $options) = @_;
 823     my $qt = $options->{quote_table_names} || '';
 824     $options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
 825     return alter_table($old_table, $options);
 826 }
 827
 828 sub alter_create_index {
 829     my ($index, $options) = @_;
 830     my $qt = $options->{quote_table_names} || '';
 831     my $qf = $options->{quote_field_names} || '';
 832     my ($idef, $constraints) = create_index($index, {
 833         quote_field_names => $qf,
 834         quote_table_names => $qt,
 835         table_name => $index->table->name,
 836     });
 837     return $index->type eq NORMAL ? $idef
 838         : sprintf('ALTER TABLE %s ADD %s',
 839               $qt . $index->table->name . $qt,
 840               join(q{}, @$constraints)
 841           );
 842 }
 843
 844 sub alter_drop_index {
 845     my ($index, $options) = @_;
 846     my $index_name = $index->name;
 847     return "DROP INDEX $index_name";
 848 }
 849
 850 sub alter_drop_constraint {
 851     my ($c, $options) = @_;
 852     my $qt = $options->{quote_table_names} || '';
 853     my $qc = $options->{quote_field_names} || '';
 854     my $out = sprintf('ALTER TABLE %s DROP CONSTRAINT %s',
 855                       $qt . $c->table->name . $qt,
 856                       $qc . $c->name . $qc );
 857     return $out;
 858 }
 859
 860 sub alter_create_constraint {
 861     my ($index, $options) = @_;
 862     my $qt = $options->{quote_table_names} || '';
 863     my ($defs, $fks) = create_constraint(@_);
 864
 865     # return if there are no constraint definitions so we don't run
 866     # into output like this:
 867     # ALTER TABLE users ADD ;
 868
 869     return unless(@{$defs} || @{$fks});
 870     return $index->type eq FOREIGN_KEY ? join(q{}, @{$fks})
 871         : join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
 872               'ADD', join(q{}, @{$defs}, @{$fks})
 873           );
 874 }
 875
 876 sub drop_table {
 877     my ($table, $options) = @_;
 878     my $qt = $options->{quote_table_names} || '';
 879     return "DROP TABLE $qt$table$qt CASCADE";
 880 }
 881
 882 1;
 883
 884 # -------------------------------------------------------------------
 885 # Life is full of misery, loneliness, and suffering --
 886 # and it's all over much too soon.
 887 # Woody Allen
 888 # -------------------------------------------------------------------
 889
 890 =pod
 891
 892 =head1 SEE ALSO
 893
 894 SQL::Translator, SQL::Translator::Producer::Oracle.
 895
 896 =head1 AUTHOR
 897
 898 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 899
 900 =cut