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         SQL::Translator::Producer->_apply_default_value(
 509           $field,
 510           \$field_def,
 511           [
 512             'NULL'              => \'NULL',
 513             'now()'             => 'now()',
 514             'CURRENT_TIMESTAMP' => 'CURRENT_TIMESTAMP',
 515           ],
 516         );
 517
 518         #
 519         # Not null constraint
 520         #
 521         $field_def .= ' NOT NULL' unless $field->is_nullable;
 522
 523         return $field_def;
 524     }
 525 }
 526
 527 sub create_index
 528 {
 529     my ($index, $options) = @_;
 530
 531     my $qt = $options->{quote_table_names} ||'';
 532     my $qf = $options->{quote_field_names} ||'';
 533     my $table_name = $index->table->name;
 534 #        my $table_name_ur = $qt ? unreserve($table_name) : $table_name;
 535
 536     my ($index_def, @constraint_defs);
 537
 538     my $name = next_unused_name(
 539         $index->name
 540         || join('_', $table_name, 'idx', ++$index_name{ $table_name })
 541     );
 542
 543     my $type = $index->type || NORMAL;
 544     my @fields     =
 545         map { $_ =~ s/\(.+\)//; $_ }
 546     map { $qt ? $_ : unreserve($_, $table_name ) }
 547     $index->fields;
 548     next unless @fields;
 549
 550     my $def_start = qq[CONSTRAINT "$name" ];
 551     if ( $type eq PRIMARY_KEY ) {
 552         push @constraint_defs, "${def_start}PRIMARY KEY ".
 553             '(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
 554     }
 555     elsif ( $type eq UNIQUE ) {
 556         push @constraint_defs, "${def_start}UNIQUE " .
 557             '(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
 558     }
 559     elsif ( $type eq NORMAL ) {
 560         $index_def =
 561             "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
 562             join( ', ', map { qq[$qf$_$qf] } @fields ).
 563             ')'
 564             ;
 565     }
 566     else {
 567         warn "Unknown index type ($type) on table $table_name.\n"
 568             if $WARN;
 569     }
 570
 571     return $index_def, \@constraint_defs;
 572 }
 573
 574 sub create_constraint
 575 {
 576     my ($c, $options) = @_;
 577
 578     my $qf = $options->{quote_field_names} ||'';
 579     my $qt = $options->{quote_table_names} ||'';
 580     my $table_name = $c->table->name;
 581     my (@constraint_defs, @fks);
 582
 583     my $name = $c->name || '';
 584     if ( $name ) {
 585         $name = next_unused_name($name);
 586     }
 587
 588     my @fields     =
 589         map { $_ =~ s/\(.+\)//; $_ }
 590     map { $qt ? $_ : unreserve( $_, $table_name )}
 591     $c->fields;
 592
 593     my @rfields     =
 594         map { $_ =~ s/\(.+\)//; $_ }
 595     map { $qt ? $_ : unreserve( $_, $table_name )}
 596     $c->reference_fields;
 597
 598     next if !@fields && $c->type ne CHECK_C;
 599     my $def_start = $name ? qq[CONSTRAINT "$name" ] : '';
 600     if ( $c->type eq PRIMARY_KEY ) {
 601         push @constraint_defs, "${def_start}PRIMARY KEY ".
 602             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 603     }
 604     elsif ( $c->type eq UNIQUE ) {
 605         $name = next_unused_name($name);
 606         push @constraint_defs, "${def_start}UNIQUE " .
 607             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 608     }
 609     elsif ( $c->type eq CHECK_C ) {
 610         my $expression = $c->expression;
 611         push @constraint_defs, "${def_start}CHECK ($expression)";
 612     }
 613     elsif ( $c->type eq FOREIGN_KEY ) {
 614         my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" .
 615             join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
 616             "\n  REFERENCES " . $qt . $c->reference_table . $qt;
 617
 618         if ( @rfields ) {
 619             $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
 620         }
 621
 622         if ( $c->match_type ) {
 623             $def .= ' MATCH ' .
 624                 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 625         }
 626
 627         if ( $c->on_delete ) {
 628             $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 629         }
 630
 631         if ( $c->on_update ) {
 632             $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 633         }
 634
 635         if ( $c->deferrable ) {
 636             $def .= ' DEFERRABLE';
 637         }
 638
 639         push @fks, "$def";
 640     }
 641
 642     return \@constraint_defs, \@fks;
 643 }
 644
 645 sub convert_datatype
 646 {
 647     my ($field) = @_;
 648
 649     my @size      = $field->size;
 650     my $data_type = lc $field->data_type;
 651
 652     if ( $data_type eq 'enum' ) {
 653 #        my $len = 0;
 654 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 655 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 656 #        push @$constraint_defs,
 657 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 658 #           qq[IN ($commalist))];
 659         $data_type = 'character varying';
 660     }
 661     elsif ( $data_type eq 'set' ) {
 662         $data_type = 'character varying';
 663     }
 664     elsif ( $field->is_auto_increment ) {
 665         if ( defined $size[0] && $size[0] > 11 ) {
 666             $data_type = 'bigserial';
 667         }
 668         else {
 669             $data_type = 'serial';
 670         }
 671         undef @size;
 672     }
 673     else {
 674         $data_type  = defined $translate{ $data_type } ?
 675             $translate{ $data_type } :
 676             $data_type;
 677     }
 678
 679     if ( $data_type =~ /^time/i || $data_type =~ /^interval/i ) {
 680         if ( defined $size[0] && $size[0] > 6 ) {
 681             $size[0] = 6;
 682         }
 683     }
 684
 685     if ( $data_type eq 'integer' ) {
 686         if ( defined $size[0] && $size[0] > 0) {
 687             if ( $size[0] > 10 ) {
 688                 $data_type = 'bigint';
 689             }
 690             elsif ( $size[0] < 5 ) {
 691                 $data_type = 'smallint';
 692             }
 693             else {
 694                 $data_type = 'integer';
 695             }
 696         }
 697         else {
 698             $data_type = 'integer';
 699         }
 700     }
 701
 702     my $type_with_size = join('|',
 703         'bit', 'varbit', 'character', 'bit varying', 'character varying',
 704         'time', 'timestamp', 'interval', 'numeric'
 705     );
 706
 707     if ( $data_type !~ /$type_with_size/ ) {
 708         @size = ();
 709     }
 710
 711     if (defined $size[0] && $size[0] > 0 && $data_type =~ /^time/i ) {
 712         $data_type =~ s/^(time.*?)( with.*)?$/$1($size[0])/;
 713         $data_type .= $2 if(defined $2);
 714     } elsif ( defined $size[0] && $size[0] > 0 ) {
 715         $data_type .= '(' . join( ',', @size ) . ')';
 716     }
 717
 718     return $data_type;
 719 }
 720
 721
 722 sub alter_field
 723 {
 724     my ($from_field, $to_field) = @_;
 725
 726     die "Can't alter field in another table"
 727         if($from_field->table->name ne $to_field->table->name);
 728
 729     my @out;
 730     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL',
 731                        $to_field->table->name,
 732                        $to_field->name) if(!$to_field->is_nullable and
 733                                            $from_field->is_nullable);
 734
 735     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP NOT NULL',
 736                       $to_field->table->name,
 737                       $to_field->name)
 738        if ( !$from_field->is_nullable and $to_field->is_nullable );
 739
 740
 741     my $from_dt = convert_datatype($from_field);
 742     my $to_dt   = convert_datatype($to_field);
 743     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s',
 744                        $to_field->table->name,
 745                        $to_field->name,
 746                        $to_dt) if($to_dt ne $from_dt);
 747
 748     push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s',
 749                        $to_field->table->name,
 750                        $from_field->name,
 751                        $to_field->name) if($from_field->name ne $to_field->name);
 752
 753     my $old_default = $from_field->default_value;
 754     my $new_default = $to_field->default_value;
 755     my $default_value = $to_field->default_value;
 756
 757     # fixes bug where output like this was created:
 758     # ALTER TABLE users ALTER COLUMN column SET DEFAULT ThisIsUnescaped;
 759     if(ref $default_value eq "SCALAR" ) {
 760         $default_value = $$default_value;
 761     } elsif( defined $default_value && $to_dt =~ /^(character|text)/xsmi ) {
 762         $default_value =~ s/'/''/xsmg;
 763         $default_value = q(') . $default_value . q(');
 764     }
 765
 766     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
 767                        $to_field->table->name,
 768                        $to_field->name,
 769                        $default_value)
 770         if ( defined $new_default &&
 771              (!defined $old_default || $old_default ne $new_default) );
 772
 773      # fixes bug where removing the DEFAULT statement of a column
 774      # would result in no change
 775
 776      push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
 777                        $to_field->table->name,
 778                        $to_field->name)
 779         if ( !defined $new_default && defined $old_default );
 780
 781
 782     return wantarray ? @out : join("\n", @out);
 783 }
 784
 785 sub rename_field { alter_field(@_) }
 786
 787 sub add_field
 788 {
 789     my ($new_field) = @_;
 790
 791     my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
 792                       $new_field->table->name,
 793                       create_field($new_field));
 794     return $out;
 795
 796 }
 797
 798 sub drop_field
 799 {
 800     my ($old_field) = @_;
 801
 802     my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
 803                       $old_field->table->name,
 804                       $old_field->name);
 805
 806     return $out;
 807 }
 808
 809 sub alter_table {
 810     my ($to_table, $options) = @_;
 811     my $qt = $options->{quote_table_names} || '';
 812     my $out = sprintf('ALTER TABLE %s %s',
 813                       $qt . $to_table->name . $qt,
 814                       $options->{alter_table_action});
 815     return $out;
 816 }
 817
 818 sub rename_table {
 819     my ($old_table, $new_table, $options) = @_;
 820     my $qt = $options->{quote_table_names} || '';
 821     $options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
 822     return alter_table($old_table, $options);
 823 }
 824
 825 sub alter_create_index {
 826     my ($index, $options) = @_;
 827     my $qt = $options->{quote_table_names} || '';
 828     my $qf = $options->{quote_field_names} || '';
 829     my ($idef, $constraints) = create_index($index, {
 830         quote_field_names => $qf,
 831         quote_table_names => $qt,
 832         table_name => $index->table->name,
 833     });
 834     return $index->type eq NORMAL ? $idef
 835         : sprintf('ALTER TABLE %s ADD %s',
 836               $qt . $index->table->name . $qt,
 837               join(q{}, @$constraints)
 838           );
 839 }
 840
 841 sub alter_drop_index {
 842     my ($index, $options) = @_;
 843     my $index_name = $index->name;
 844     return "DROP INDEX $index_name";
 845 }
 846
 847 sub alter_drop_constraint {
 848     my ($c, $options) = @_;
 849     my $qt = $options->{quote_table_names} || '';
 850     my $qc = $options->{quote_field_names} || '';
 851     my $out = sprintf('ALTER TABLE %s DROP CONSTRAINT %s',
 852                       $qt . $c->table->name . $qt,
 853                       $qc . $c->name . $qc );
 854     return $out;
 855 }
 856
 857 sub alter_create_constraint {
 858     my ($index, $options) = @_;
 859     my $qt = $options->{quote_table_names} || '';
 860     my ($defs, $fks) = create_constraint(@_);
 861
 862     # return if there are no constraint definitions so we don't run
 863     # into output like this:
 864     # ALTER TABLE users ADD ;
 865
 866     return unless(@{$defs} || @{$fks});
 867     return $index->type eq FOREIGN_KEY ? join(q{}, @{$fks})
 868         : join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
 869               'ADD', join(q{}, @{$defs}, @{$fks})
 870           );
 871 }
 872
 873 sub drop_table {
 874     my ($table, $options) = @_;
 875     my $qt = $options->{quote_table_names} || '';
 876     return "DROP TABLE $qt$table$qt CASCADE";
 877 }
 878
 879 1;
 880
 881 # -------------------------------------------------------------------
 882 # Life is full of misery, loneliness, and suffering --
 883 # and it's all over much too soon.
 884 # Woody Allen
 885 # -------------------------------------------------------------------
 886
 887 =pod
 888
 889 =head1 SEE ALSO
 890
 891 SQL::Translator, SQL::Translator::Producer::Oracle.
 892
 893 =head1 AUTHOR
 894
 895 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 896
 897 =cut