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 parse_dbms_version);
  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     my $postgres_version = parse_dbms_version(
 185         $pargs->{postgres_version}, 'perl'
 186     );
 187
 188     my $qt = $translator->quote_table_names ? q{"} : q{};
 189     my $qf = $translator->quote_field_names ? q{"} : q{};
 190
 191     my @output;
 192     push @output, header_comment unless ($no_comments);
 193
 194     my (@table_defs, @fks);
 195     for my $table ( $schema->get_tables ) {
 196
 197         my ($table_def, $fks) = create_table($table, {
 198             quote_table_names => $qt,
 199             quote_field_names => $qf,
 200             no_comments       => $no_comments,
 201             postgres_version  => $postgres_version,
 202             add_drop_table    => $add_drop_table,
 203         });
 204
 205         push @table_defs, $table_def;
 206         push @fks, @$fks;
 207     }
 208
 209     for my $view ( $schema->get_views ) {
 210       push @table_defs, create_view($view, {
 211         add_drop_view     => $add_drop_table,
 212         quote_table_names => $qt,
 213         quote_field_names => $qf,
 214         no_comments       => $no_comments,
 215       });
 216     }
 217
 218     push @output, map { "$_;\n\n" } @table_defs;
 219     if ( @fks ) {
 220         push @output, "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
 221         push @output, map { "$_;\n\n" } @fks;
 222     }
 223
 224     if ( $WARN ) {
 225         if ( %truncated ) {
 226             warn "Truncated " . keys( %truncated ) . " names:\n";
 227             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 228         }
 229
 230         if ( %unreserve ) {
 231             warn "Encounted " . keys( %unreserve ) .
 232                 " unsafe names in schema (reserved or invalid):\n";
 233             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 234         }
 235     }
 236
 237     return wantarray
 238         ? @output
 239         : join ('', @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 $orig_name = shift or return;
 305     my $name      = $orig_name;
 306
 307     my $suffix_gen = sub {
 308         my $suffix = 0;
 309         return ++$suffix ? '' : $suffix;
 310     };
 311
 312     for (;;) {
 313         $name = $orig_name . $suffix_gen->();
 314         last if $used_names{ $name }++;
 315     }
 316
 317     return $name;
 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     my ( $fql_tbl_name ) = ( $table_name =~ s/\W(.*)$// ) ? $1 : q{};
 332     my $table_name_ur = $qt ? $table_name
 333         : $fql_tbl_name ? join('.', $table_name, unreserve($fql_tbl_name))
 334         : unreserve($table_name);
 335     $table->name($table_name_ur);
 336
 337 # print STDERR "$table_name table_name\n";
 338     my ( @comments, @field_defs, @sequence_defs, @constraint_defs, @type_defs, @type_drops, @fks );
 339
 340     push @comments, "--\n-- Table: $table_name_ur\n--\n" unless $no_comments;
 341
 342     if ( $table->comments and !$no_comments ){
 343         my $c = "-- Comments: \n-- ";
 344         $c .= join "\n-- ",  $table->comments;
 345         $c .= "\n--\n";
 346         push @comments, $c;
 347     }
 348
 349     #
 350     # Fields
 351     #
 352     my %field_name_scope;
 353     for my $field ( $table->get_fields ) {
 354         push @field_defs, create_field($field, { quote_table_names => $qt,
 355                                                  quote_field_names => $qf,
 356                                                  table_name => $table_name_ur,
 357                                                  postgres_version => $postgres_version,
 358                                                  type_defs => \@type_defs,
 359                                                  type_drops => \@type_drops,
 360                                                  constraint_defs => \@constraint_defs,});
 361     }
 362
 363     #
 364     # Index Declarations
 365     #
 366     my @index_defs = ();
 367  #   my $idx_name_default;
 368     for my $index ( $table->get_indices ) {
 369         my ($idef, $constraints) = create_index($index,
 370                                               {
 371                                                   quote_field_names => $qf,
 372                                                   quote_table_names => $qt,
 373                                                   table_name => $table_name,
 374                                               });
 375         $idef and push @index_defs, $idef;
 376         push @constraint_defs, @$constraints;
 377     }
 378
 379     #
 380     # Table constraints
 381     #
 382     my $c_name_default;
 383     for my $c ( $table->get_constraints ) {
 384         my ($cdefs, $fks) = create_constraint($c,
 385                                               {
 386                                                   quote_field_names => $qf,
 387                                                   quote_table_names => $qt,
 388                                                   table_name => $table_name,
 389                                               });
 390         push @constraint_defs, @$cdefs;
 391         push @fks, @$fks;
 392     }
 393
 394
 395     my $temporary = "";
 396
 397     if(exists $table->{extra}{temporary}) {
 398         $temporary = $table->{extra}{temporary} ? "TEMPORARY " : "";
 399     }
 400
 401     my $create_statement;
 402     $create_statement = join("\n", @comments);
 403     if ($add_drop_table) {
 404         if ($postgres_version >= 8.002) {
 405             $create_statement .= qq[DROP TABLE IF EXISTS $qt$table_name_ur$qt CASCADE;\n];
 406             $create_statement .= join (";\n", @type_drops) . ";\n"
 407                 if $postgres_version >= 8.003 && scalar @type_drops;
 408         } else {
 409             $create_statement .= qq[DROP TABLE $qt$table_name_ur$qt CASCADE;\n];
 410         }
 411     }
 412     $create_statement .= join(";\n", @type_defs) . ";\n"
 413         if $postgres_version >= 8.003 && scalar @type_defs;
 414     $create_statement .= qq[CREATE ${temporary}TABLE $qt$table_name_ur$qt (\n].
 415                             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 416                             "\n)"
 417                             ;
 418     $create_statement .= @index_defs ? ';' : q{};
 419     $create_statement .= ( $create_statement =~ /;$/ ? "\n" : q{} )
 420         . join(";\n", @index_defs);
 421
 422     return $create_statement, \@fks;
 423 }
 424
 425 sub create_view {
 426     my ($view, $options) = @_;
 427     my $qt = $options->{quote_table_names} || '';
 428     my $qf = $options->{quote_field_names} || '';
 429     my $add_drop_view = $options->{add_drop_view};
 430
 431     my $view_name = $view->name;
 432     debug("PKG: Looking at view '${view_name}'\n");
 433
 434     my $create = '';
 435     $create .= "--\n-- View: ${qt}${view_name}${qt}\n--\n"
 436         unless $options->{no_comments};
 437     $create .= "DROP VIEW ${qt}${view_name}${qt};\n" if $add_drop_view;
 438     $create .= 'CREATE';
 439
 440     my $extra = $view->extra;
 441     $create .= " TEMPORARY" if exists($extra->{temporary}) && $extra->{temporary};
 442     $create .= " VIEW ${qt}${view_name}${qt}";
 443
 444     if ( my @fields = $view->fields ) {
 445         my $field_list = join ', ', map { "${qf}${_}${qf}" } @fields;
 446         $create .= " ( ${field_list} )";
 447     }
 448
 449     if ( my $sql = $view->sql ) {
 450         $create .= " AS\n    ${sql}\n";
 451     }
 452
 453     if ( $extra->{check_option} ) {
 454         $create .= ' WITH ' . uc $extra->{check_option} . ' CHECK OPTION';
 455     }
 456
 457     return $create;
 458 }
 459
 460 {
 461
 462     my %field_name_scope;
 463
 464     sub create_field
 465     {
 466         my ($field, $options) = @_;
 467
 468         my $qt = $options->{quote_table_names} || '';
 469         my $qf = $options->{quote_field_names} || '';
 470         my $table_name = $field->table->name;
 471         my $constraint_defs = $options->{constraint_defs} || [];
 472         my $postgres_version = $options->{postgres_version} || 0;
 473         my $type_defs = $options->{type_defs} || [];
 474         my $type_drops = $options->{type_drops} || [];
 475
 476         $field_name_scope{$table_name} ||= {};
 477         my $field_name    = $field->name;
 478         my $field_name_ur = $qf ? $field_name : unreserve($field_name, $table_name );
 479         $field->name($field_name_ur);
 480         my $field_comments = $field->comments
 481             ? "-- " . $field->comments . "\n  "
 482             : '';
 483
 484         my $field_def     = $field_comments.qq[$qf$field_name_ur$qf];
 485
 486         #
 487         # Datatype
 488         #
 489         my @size      = $field->size;
 490         my $data_type = lc $field->data_type;
 491         my %extra     = $field->extra;
 492         my $list      = $extra{'list'} || [];
 493         # todo deal with embedded quotes
 494         my $commalist = join( ', ', map { qq['$_'] } @$list );
 495
 496         if ($postgres_version >= 8.003 && $field->data_type eq 'enum') {
 497             my $type_name = $field->table->name . '_' . $field->name . '_type';
 498             $field_def .= ' '. $type_name;
 499             push @$type_defs, "CREATE TYPE $type_name AS ENUM ($commalist)";
 500             push @$type_drops, "DROP TYPE IF EXISTS $type_name";
 501         } else {
 502             $field_def .= ' '. convert_datatype($field);
 503         }
 504
 505         #
 506         # Default value
 507         #
 508         my $default = $field->default_value;
 509         if ( defined $default ) {
 510             SQL::Translator::Producer->_apply_default_value(
 511               \$field_def,
 512               $default,
 513               [
 514                 'NULL'              => \'NULL',
 515                 'now()'             => 'now()',
 516                 'CURRENT_TIMESTAMP' => 'CURRENT_TIMESTAMP',
 517               ],
 518             );
 519         }
 520
 521         #
 522         # Not null constraint
 523         #
 524         $field_def .= ' NOT NULL' unless $field->is_nullable;
 525
 526         return $field_def;
 527     }
 528 }
 529
 530 sub create_index
 531 {
 532     my ($index, $options) = @_;
 533
 534     my $qt = $options->{quote_table_names} ||'';
 535     my $qf = $options->{quote_field_names} ||'';
 536     my $table_name = $index->table->name;
 537 #        my $table_name_ur = $qt ? unreserve($table_name) : $table_name;
 538
 539     my ($index_def, @constraint_defs);
 540
 541     my $name = next_unused_name(
 542         $index->name
 543         || join('_', $table_name, 'idx', ++$index_name{ $table_name })
 544     );
 545
 546     my $type = $index->type || NORMAL;
 547     my @fields     =
 548         map { $_ =~ s/\(.+\)//; $_ }
 549     map { $qt ? $_ : unreserve($_, $table_name ) }
 550     $index->fields;
 551     next unless @fields;
 552
 553     my $def_start = qq[CONSTRAINT "$name" ];
 554     if ( $type eq PRIMARY_KEY ) {
 555         push @constraint_defs, "${def_start}PRIMARY KEY ".
 556             '(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
 557     }
 558     elsif ( $type eq UNIQUE ) {
 559         push @constraint_defs, "${def_start}UNIQUE " .
 560             '(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
 561     }
 562     elsif ( $type eq NORMAL ) {
 563         $index_def =
 564             "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
 565             join( ', ', map { qq[$qf$_$qf] } @fields ).
 566             ')'
 567             ;
 568     }
 569     else {
 570         warn "Unknown index type ($type) on table $table_name.\n"
 571             if $WARN;
 572     }
 573
 574     return $index_def, \@constraint_defs;
 575 }
 576
 577 sub create_constraint
 578 {
 579     my ($c, $options) = @_;
 580
 581     my $qf = $options->{quote_field_names} ||'';
 582     my $qt = $options->{quote_table_names} ||'';
 583     my $table_name = $c->table->name;
 584     my (@constraint_defs, @fks);
 585
 586     my $name = $c->name || '';
 587     if ( $name ) {
 588         $name = next_unused_name($name);
 589     }
 590
 591     my @fields     =
 592         map { $_ =~ s/\(.+\)//; $_ }
 593     map { $qt ? $_ : unreserve( $_, $table_name )}
 594     $c->fields;
 595
 596     my @rfields     =
 597         map { $_ =~ s/\(.+\)//; $_ }
 598     map { $qt ? $_ : unreserve( $_, $table_name )}
 599     $c->reference_fields;
 600
 601     next if !@fields && $c->type ne CHECK_C;
 602     my $def_start = $name ? qq[CONSTRAINT "$name" ] : '';
 603     if ( $c->type eq PRIMARY_KEY ) {
 604         push @constraint_defs, "${def_start}PRIMARY KEY ".
 605             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 606     }
 607     elsif ( $c->type eq UNIQUE ) {
 608         $name = next_unused_name($name);
 609         push @constraint_defs, "${def_start}UNIQUE " .
 610             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 611     }
 612     elsif ( $c->type eq CHECK_C ) {
 613         my $expression = $c->expression;
 614         push @constraint_defs, "${def_start}CHECK ($expression)";
 615     }
 616     elsif ( $c->type eq FOREIGN_KEY ) {
 617         my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" .
 618             join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
 619             "\n  REFERENCES " . $qt . $c->reference_table . $qt;
 620
 621         if ( @rfields ) {
 622             $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
 623         }
 624
 625         if ( $c->match_type ) {
 626             $def .= ' MATCH ' .
 627                 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 628         }
 629
 630         if ( $c->on_delete ) {
 631             $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 632         }
 633
 634         if ( $c->on_update ) {
 635             $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 636         }
 637
 638         if ( $c->deferrable ) {
 639             $def .= ' DEFERRABLE';
 640         }
 641
 642         push @fks, "$def";
 643     }
 644
 645     return \@constraint_defs, \@fks;
 646 }
 647
 648 sub convert_datatype
 649 {
 650     my ($field) = @_;
 651
 652     my @size      = $field->size;
 653     my $data_type = lc $field->data_type;
 654
 655     if ( $data_type eq 'enum' ) {
 656 #        my $len = 0;
 657 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 658 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 659 #        push @$constraint_defs,
 660 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 661 #           qq[IN ($commalist))];
 662         $data_type = 'character varying';
 663     }
 664     elsif ( $data_type eq 'set' ) {
 665         $data_type = 'character varying';
 666     }
 667     elsif ( $field->is_auto_increment ) {
 668         if ( defined $size[0] && $size[0] > 11 ) {
 669             $data_type = 'bigserial';
 670         }
 671         else {
 672             $data_type = 'serial';
 673         }
 674         undef @size;
 675     }
 676     else {
 677         $data_type  = defined $translate{ $data_type } ?
 678             $translate{ $data_type } :
 679             $data_type;
 680     }
 681
 682     if ( $data_type =~ /^time/i || $data_type =~ /^interval/i ) {
 683         if ( defined $size[0] && $size[0] > 6 ) {
 684             $size[0] = 6;
 685         }
 686     }
 687
 688     if ( $data_type eq 'integer' ) {
 689         if ( defined $size[0] && $size[0] > 0) {
 690             if ( $size[0] > 10 ) {
 691                 $data_type = 'bigint';
 692             }
 693             elsif ( $size[0] < 5 ) {
 694                 $data_type = 'smallint';
 695             }
 696             else {
 697                 $data_type = 'integer';
 698             }
 699         }
 700         else {
 701             $data_type = 'integer';
 702         }
 703     }
 704
 705     my $type_with_size = join('|',
 706         'bit', 'varbit', 'character', 'bit varying', 'character varying',
 707         'time', 'timestamp', 'interval', 'numeric'
 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