lib/SQL/Translator/Producer/PostgreSQL.pm

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