lib/SQL/Translator/Producer/PostgreSQL.pm

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