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 Now handles PostGIS Geometry and Geography data types on table definitions.
  36 Does not yet support PostGIS Views.
  37
  38 =cut
  39
  40 use strict;
  41 use warnings;
  42 use vars qw[ $DEBUG $WARN $VERSION %used_names ];
  43 $VERSION = '1.59';
  44 $DEBUG = 0 unless defined $DEBUG;
  45
  46 use base qw(SQL::Translator::Producer);
  47 use SQL::Translator::Schema::Constants;
  48 use SQL::Translator::Utils qw(debug header_comment parse_dbms_version);
  49 use Data::Dumper;
  50
  51 my ( %translate, %index_name );
  52 my $max_id_length;
  53
  54 BEGIN {
  55
  56  %translate  = (
  57     #
  58     # MySQL types
  59     #
  60     bigint     => 'bigint',
  61     double     => 'numeric',
  62     decimal    => 'numeric',
  63     float      => 'numeric',
  64     int        => 'integer',
  65     mediumint  => 'integer',
  66     smallint   => 'smallint',
  67     tinyint    => 'smallint',
  68     char       => 'character',
  69     varchar    => 'character varying',
  70     longtext   => 'text',
  71     mediumtext => 'text',
  72     text       => 'text',
  73     tinytext   => 'text',
  74     tinyblob   => 'bytea',
  75     blob       => 'bytea',
  76     mediumblob => 'bytea',
  77     longblob   => 'bytea',
  78     enum       => 'character varying',
  79     set        => 'character varying',
  80     date       => 'date',
  81     datetime   => 'timestamp',
  82     time       => 'time',
  83     timestamp  => 'timestamp',
  84     year       => 'date',
  85
  86     #
  87     # Oracle types
  88     #
  89     number     => 'integer',
  90     char       => 'character',
  91     varchar2   => 'character varying',
  92     long       => 'text',
  93     CLOB       => 'bytea',
  94     date       => 'date',
  95
  96     #
  97     # Sybase types
  98     #
  99     int        => 'integer',
 100     money      => 'money',
 101     varchar    => 'character varying',
 102     datetime   => 'timestamp',
 103     text       => 'text',
 104     real       => 'numeric',
 105     comment    => 'text',
 106     bit        => 'bit',
 107     tinyint    => 'smallint',
 108     float      => 'numeric',
 109 );
 110
 111  $max_id_length = 62;
 112 }
 113 my %reserved = map { $_, 1 } qw[
 114     ALL ANALYSE ANALYZE AND ANY AS ASC
 115     BETWEEN BINARY BOTH
 116     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
 117     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
 118     DEFAULT DEFERRABLE DESC DISTINCT DO
 119     ELSE END EXCEPT
 120     FALSE FOR FOREIGN FREEZE FROM FULL
 121     GROUP HAVING
 122     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
 123     JOIN LEADING LEFT LIKE LIMIT
 124     NATURAL NEW NOT NOTNULL NULL
 125     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
 126     PRIMARY PUBLIC REFERENCES RIGHT
 127     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
 128     UNION UNIQUE USER USING VERBOSE WHEN WHERE
 129 ];
 130
 131 # my $max_id_length    = 62;
 132 my %used_identifiers = ();
 133 my %global_names;
 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     my $postgres_version = parse_dbms_version(
 187         $pargs->{postgres_version}, 'perl'
 188     );
 189
 190     my $qt = $translator->quote_table_names ? q{"} : q{};
 191     my $qf = $translator->quote_field_names ? q{"} : q{};
 192
 193     my @output;
 194     push @output, header_comment unless ($no_comments);
 195
 196     my (@table_defs, @fks);
 197     my %type_defs;
 198     for my $table ( $schema->get_tables ) {
 199
 200         my ($table_def, $fks) = create_table($table, {
 201             quote_table_names => $qt,
 202             quote_field_names => $qf,
 203             no_comments       => $no_comments,
 204             postgres_version  => $postgres_version,
 205             add_drop_table    => $add_drop_table,
 206             type_defs         => \%type_defs,
 207         });
 208
 209         push @table_defs, $table_def;
 210         push @fks, @$fks;
 211     }
 212
 213     for my $view ( $schema->get_views ) {
 214       push @table_defs, create_view($view, {
 215         postgres_version  => $postgres_version,
 216         add_drop_view     => $add_drop_table,
 217         quote_table_names => $qt,
 218         quote_field_names => $qf,
 219         no_comments       => $no_comments,
 220       });
 221     }
 222
 223     push @output, map { "$_;\n\n" } values %type_defs;
 224     push @output, map { "$_;\n\n" } @table_defs;
 225     if ( @fks ) {
 226         push @output, "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
 227         push @output, map { "$_;\n\n" } @fks;
 228     }
 229
 230     if ( $WARN ) {
 231         if ( %truncated ) {
 232             warn "Truncated " . keys( %truncated ) . " names:\n";
 233             warn "\t" . join( "\n\t", sort keys %truncated ) . "\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 next_unused_name {
 283     my $orig_name = shift or return;
 284     my $name      = $orig_name;
 285
 286     my $suffix_gen = sub {
 287         my $suffix = 0;
 288         return ++$suffix ? '' : $suffix;
 289     };
 290
 291     for (;;) {
 292         $name = $orig_name . $suffix_gen->();
 293         last if $used_names{ $name }++;
 294     }
 295
 296     return $name;
 297 }
 298
 299 sub is_geometry
 300 {
 301         my $field = shift;
 302         return 1 if $field->data_type eq 'geometry';
 303 }
 304
 305 sub is_geography
 306 {
 307     my $field = shift;
 308     return 1 if $field->data_type eq 'geography';
 309 }
 310
 311 sub create_table
 312 {
 313     my ($table, $options) = @_;
 314
 315     my $qt = $options->{quote_table_names} || '';
 316     my $qf = $options->{quote_field_names} || '';
 317     my $no_comments = $options->{no_comments} || 0;
 318     my $add_drop_table = $options->{add_drop_table} || 0;
 319     my $postgres_version = $options->{postgres_version} || 0;
 320     my $type_defs = $options->{type_defs} || {};
 321
 322     my $table_name = $table->name or next;
 323     my ( $fql_tbl_name ) = ( $table_name =~ s/\W(.*)$// ) ? $1 : q{};
 324     my $table_name_ur = $qt ? $table_name
 325         : $fql_tbl_name ? join('.', $table_name, $fql_tbl_name)
 326         : $table_name;
 327     $table->name($table_name_ur);
 328
 329 # print STDERR "$table_name table_name\n";
 330     my ( @comments, @field_defs, @sequence_defs, @constraint_defs, @fks );
 331
 332     push @comments, "--\n-- Table: $table_name_ur\n--\n" unless $no_comments;
 333
 334     if ( $table->comments and !$no_comments ){
 335         my $c = "-- Comments: \n-- ";
 336         $c .= join "\n-- ",  $table->comments;
 337         $c .= "\n--\n";
 338         push @comments, $c;
 339     }
 340
 341     #
 342     # Fields
 343     #
 344     my %field_name_scope;
 345     for my $field ( $table->get_fields ) {
 346         push @field_defs, create_field($field, { quote_table_names => $qt,
 347                                                  quote_field_names => $qf,
 348                                                  table_name => $table_name_ur,
 349                                                  postgres_version => $postgres_version,
 350                                                  type_defs => $type_defs,
 351                                                  constraint_defs => \@constraint_defs,});
 352     }
 353
 354     #
 355     # Index Declarations
 356     #
 357     my @index_defs = ();
 358  #   my $idx_name_default;
 359     for my $index ( $table->get_indices ) {
 360         my ($idef, $constraints) = create_index($index,
 361                                               {
 362                                                   quote_field_names => $qf,
 363                                                   quote_table_names => $qt,
 364                                                   table_name => $table_name,
 365                                               });
 366         $idef and push @index_defs, $idef;
 367         push @constraint_defs, @$constraints;
 368     }
 369
 370     #
 371     # Table constraints
 372     #
 373     my $c_name_default;
 374     for my $c ( $table->get_constraints ) {
 375         my ($cdefs, $fks) = create_constraint($c,
 376                                               {
 377                                                   quote_field_names => $qf,
 378                                                   quote_table_names => $qt,
 379                                                   table_name => $table_name,
 380                                               });
 381         push @constraint_defs, @$cdefs;
 382         push @fks, @$fks;
 383     }
 384
 385
 386     my $temporary = "";
 387
 388     if(exists $table->{extra}{temporary}) {
 389         $temporary = $table->{extra}{temporary} ? "TEMPORARY " : "";
 390     }
 391
 392     my $create_statement;
 393     $create_statement = join("\n", @comments);
 394     if ($add_drop_table) {
 395         if ($postgres_version >= 8.002) {
 396             $create_statement .= qq[DROP TABLE IF EXISTS $qt$table_name_ur$qt CASCADE;\n];
 397         } else {
 398             $create_statement .= qq[DROP TABLE $qt$table_name_ur$qt CASCADE;\n];
 399         }
 400     }
 401     $create_statement .= qq[CREATE ${temporary}TABLE $qt$table_name_ur$qt (\n].
 402                             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 403                             "\n)"
 404                             ;
 405     $create_statement .= @index_defs ? ';' : q{};
 406     $create_statement .= ( $create_statement =~ /;$/ ? "\n" : q{} )
 407         . join(";\n", @index_defs);
 408
 409         #
 410         # Geometry
 411         #
 412         if(grep { is_geometry($_) } $table->get_fields){
 413         $create_statement .= ";";
 414         my @geometry_columns;
 415         foreach my $col ($table->get_fields) { push(@geometry_columns,$col) if is_geometry($col); }
 416                 $create_statement .= "\n".join("\n", map{ drop_geometry_column($_) } @geometry_columns) if $options->{add_drop_table};
 417                 $create_statement .= "\n".join("\n", map{ add_geometry_column($_) } @geometry_columns);
 418         }
 419
 420     return $create_statement, \@fks;
 421 }
 422
 423 sub create_view {
 424     my ($view, $options) = @_;
 425     my $qt = $options->{quote_table_names} || '';
 426     my $qf = $options->{quote_field_names} || '';
 427     my $postgres_version = $options->{postgres_version} || 0;
 428     my $add_drop_view = $options->{add_drop_view};
 429
 430     my $view_name = $view->name;
 431     debug("PKG: Looking at view '${view_name}'\n");
 432
 433     my $create = '';
 434     $create .= "--\n-- View: ${qt}${view_name}${qt}\n--\n"
 435         unless $options->{no_comments};
 436     if ($add_drop_view) {
 437         if ($postgres_version >= 8.002) {
 438             $create .= "DROP VIEW IF EXISTS ${qt}${view_name}${qt};\n";
 439         } else {
 440             $create .= "DROP VIEW ${qt}${view_name}${qt};\n";
 441         }
 442     }
 443     $create .= 'CREATE';
 444
 445     my $extra = $view->extra;
 446     $create .= " TEMPORARY" if exists($extra->{temporary}) && $extra->{temporary};
 447     $create .= " VIEW ${qt}${view_name}${qt}";
 448
 449     if ( my @fields = $view->fields ) {
 450         my $field_list = join ', ', map { "${qf}${_}${qf}" } @fields;
 451         $create .= " ( ${field_list} )";
 452     }
 453
 454     if ( my $sql = $view->sql ) {
 455         $create .= " AS\n    ${sql}\n";
 456     }
 457
 458     if ( $extra->{check_option} ) {
 459         $create .= ' WITH ' . uc $extra->{check_option} . ' CHECK OPTION';
 460     }
 461
 462     return $create;
 463 }
 464
 465 {
 466
 467     my %field_name_scope;
 468
 469     sub create_field
 470     {
 471         my ($field, $options) = @_;
 472
 473         my $qt = $options->{quote_table_names} || '';
 474         my $qf = $options->{quote_field_names} || '';
 475         my $table_name = $field->table->name;
 476         my $constraint_defs = $options->{constraint_defs} || [];
 477         my $postgres_version = $options->{postgres_version} || 0;
 478         my $type_defs = $options->{type_defs} || {};
 479
 480         $field_name_scope{$table_name} ||= {};
 481         my $field_name    = $field->name;
 482         my $field_comments = $field->comments
 483             ? "-- " . $field->comments . "\n  "
 484             : '';
 485
 486         my $field_def     = $field_comments.qq[$qf$field_name$qf];
 487
 488         #
 489         # Datatype
 490         #
 491         my @size      = $field->size;
 492         my $data_type = lc $field->data_type;
 493         my %extra     = $field->extra;
 494         my $list      = $extra{'list'} || [];
 495         # todo deal with embedded quotes
 496         my $commalist = join( ', ', map { qq['$_'] } @$list );
 497
 498         if ($postgres_version >= 8.003 && $field->data_type eq 'enum') {
 499             my $type_name = $extra{'custom_type_name'} || $field->table->name . '_' . $field->name . '_type';
 500             $field_def .= ' '. $type_name;
 501             my $new_type_def = "DROP TYPE IF EXISTS $type_name CASCADE;\n" .
 502                                "CREATE TYPE $type_name AS ENUM ($commalist)";
 503             if (! exists $type_defs->{$type_name} ) {
 504                 $type_defs->{$type_name} = $new_type_def;
 505             } elsif ( $type_defs->{$type_name} ne $new_type_def ) {
 506                 die "Attempted to redefine type name '$type_name' as a different type.\n";
 507             }
 508         } else {
 509             $field_def .= ' '. convert_datatype($field);
 510         }
 511
 512         #
 513         # Default value
 514         #
 515         SQL::Translator::Producer->_apply_default_value(
 516           $field,
 517           \$field_def,
 518           [
 519             'NULL'              => \'NULL',
 520             'now()'             => 'now()',
 521             'CURRENT_TIMESTAMP' => 'CURRENT_TIMESTAMP',
 522           ],
 523         );
 524
 525         #
 526         # Not null constraint
 527         #
 528         $field_def .= ' NOT NULL' unless $field->is_nullable;
 529
 530                 #
 531                 # Geometry constraints
 532                 #
 533                 if(is_geometry($field)){
 534                         foreach ( create_geometry_constraints($field) ) {
 535                                 my ($cdefs, $fks) = create_constraint($_,
 536                                                                                                           {
 537                                                                                                                   quote_field_names => $qf,
 538                                                                                                                   quote_table_names => $qt,
 539                                                                                                                   table_name => $table_name,
 540                                                                                                           });
 541                                 push @$constraint_defs, @$cdefs;
 542                                 push @$fks, @$fks;
 543                         }
 544         }
 545
 546         return $field_def;
 547     }
 548 }
 549
 550 sub create_geometry_constraints{
 551         my $field = shift;
 552
 553         my @constraints;
 554         push @constraints, SQL::Translator::Schema::Constraint->new(
 555                                                         name       => "enforce_dims_".$field->name,
 556                                                         expression => "(ST_NDims($field) = ".$field->{extra}{dimensions}.")",
 557                                                         table      => $field->table,
 558                                                         type       => CHECK_C,
 559                                                 );
 560
 561         push @constraints, SQL::Translator::Schema::Constraint->new(
 562                                                         name       => "enforce_srid_".$field->name,
 563                                                         expression => "(ST_SRID($field) = ".$field->{extra}{srid}.")",
 564                                                         table      => $field->table,
 565                                                         type       => CHECK_C,
 566                                                 );
 567         push @constraints, SQL::Translator::Schema::Constraint->new(
 568                                                         name       => "enforce_geotype_".$field->name,
 569                                                         expression => "(GeometryType($field) = '".$field->{extra}{geometry_type}."'::text OR $field IS NULL)",
 570                                                         table      => $field->table,
 571                                                         type       => CHECK_C,
 572                                                 );
 573
 574         return @constraints;
 575 }
 576
 577 sub create_index
 578 {
 579     my ($index, $options) = @_;
 580
 581     my $qt = $options->{quote_table_names} ||'';
 582     my $qf = $options->{quote_field_names} ||'';
 583     my $table_name = $index->table->name;
 584
 585     my ($index_def, @constraint_defs);
 586
 587     my $name = next_unused_name(
 588         $index->name
 589         || join('_', $table_name, 'idx', ++$index_name{ $table_name })
 590     );
 591
 592     my $type = $index->type || NORMAL;
 593     my @fields     =  $index->fields;
 594     next unless @fields;
 595
 596     my $def_start = qq[CONSTRAINT ${qf}$name${qf} ];
 597     my $field_names = '(' . join(", ", (map { $_ =~ /\(.*\)/ ? $_ : ($qf . $_ . $qf ) } @fields)) . ')';
 598     if ( $type eq PRIMARY_KEY ) {
 599         push @constraint_defs, "${def_start}PRIMARY KEY ".$field_names;
 600     }
 601     elsif ( $type eq UNIQUE ) {
 602         push @constraint_defs, "${def_start}UNIQUE " .$field_names;
 603     }
 604     elsif ( $type eq NORMAL ) {
 605         $index_def =
 606             "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} ".$field_names
 607             ;
 608     }
 609     else {
 610         warn "Unknown index type ($type) on table $table_name.\n"
 611             if $WARN;
 612     }
 613
 614     return $index_def, \@constraint_defs;
 615 }
 616
 617 sub create_constraint
 618 {
 619     my ($c, $options) = @_;
 620
 621     my $qf = $options->{quote_field_names} ||'';
 622     my $qt = $options->{quote_table_names} ||'';
 623     my $table_name = $c->table->name;
 624     my (@constraint_defs, @fks);
 625
 626     my $name = $c->name || '';
 627     if ( $name ) {
 628         $name = next_unused_name($name);
 629     }
 630
 631     my @fields = grep { defined } $c->fields;
 632
 633     my @rfields = grep { defined } $c->reference_fields;
 634
 635     next if !@fields && $c->type ne CHECK_C;
 636     my $def_start = $name ? qq[CONSTRAINT ${qf}$name${qf} ] : '';
 637     my $field_names = '(' . join(", ", (map { $_ =~ /\(.*\)/ ? $_ : ($qf . $_ . $qf ) } @fields)) . ')';
 638     if ( $c->type eq PRIMARY_KEY ) {
 639         push @constraint_defs, "${def_start}PRIMARY KEY ".$field_names;
 640     }
 641     elsif ( $c->type eq UNIQUE ) {
 642         push @constraint_defs, "${def_start}UNIQUE " .$field_names;
 643     }
 644     elsif ( $c->type eq CHECK_C ) {
 645         my $expression = $c->expression;
 646         push @constraint_defs, "${def_start}CHECK ($expression)";
 647     }
 648     elsif ( $c->type eq FOREIGN_KEY ) {
 649         my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY " . $field_names .
 650             "\n  REFERENCES " . $qt . $c->reference_table . $qt;
 651
 652         if ( @rfields ) {
 653             $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
 654         }
 655
 656         if ( $c->match_type ) {
 657             $def .= ' MATCH ' .
 658                 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 659         }
 660
 661         if ( $c->on_delete ) {
 662             $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 663         }
 664
 665         if ( $c->on_update ) {
 666             $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 667         }
 668
 669         if ( $c->deferrable ) {
 670             $def .= ' DEFERRABLE';
 671         }
 672
 673         push @fks, "$def";
 674     }
 675
 676     return \@constraint_defs, \@fks;
 677 }
 678
 679 sub convert_datatype
 680 {
 681     my ($field) = @_;
 682
 683     my @size      = $field->size;
 684     my $data_type = lc $field->data_type;
 685     my $array = $data_type =~ s/\[\]$//;
 686
 687     if ( $data_type eq 'enum' ) {
 688 #        my $len = 0;
 689 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 690 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 691 #        push @$constraint_defs,
 692 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 693 #           qq[IN ($commalist))];
 694         $data_type = 'character varying';
 695     }
 696     elsif ( $data_type eq 'set' ) {
 697         $data_type = 'character varying';
 698     }
 699     elsif ( $field->is_auto_increment ) {
 700         if ( defined $size[0] && $size[0] > 11 ) {
 701             $data_type = 'bigserial';
 702         }
 703         else {
 704             $data_type = 'serial';
 705         }
 706         undef @size;
 707     }
 708     else {
 709         $data_type  = defined $translate{ $data_type } ?
 710             $translate{ $data_type } :
 711             $data_type;
 712     }
 713
 714     if ( $data_type =~ /^time/i || $data_type =~ /^interval/i ) {
 715         if ( defined $size[0] && $size[0] > 6 ) {
 716             $size[0] = 6;
 717         }
 718     }
 719
 720     if ( $data_type eq 'integer' ) {
 721         if ( defined $size[0] && $size[0] > 0) {
 722             if ( $size[0] > 10 ) {
 723                 $data_type = 'bigint';
 724             }
 725             elsif ( $size[0] < 5 ) {
 726                 $data_type = 'smallint';
 727             }
 728             else {
 729                 $data_type = 'integer';
 730             }
 731         }
 732         else {
 733             $data_type = 'integer';
 734         }
 735     }
 736
 737     my $type_with_size = join('|',
 738         'bit', 'varbit', 'character', 'bit varying', 'character varying',
 739         'time', 'timestamp', 'interval', 'numeric'
 740     );
 741
 742     if ( $data_type !~ /$type_with_size/ ) {
 743         @size = ();
 744     }
 745
 746     if (defined $size[0] && $size[0] > 0 && $data_type =~ /^time/i ) {
 747         $data_type =~ s/^(time.*?)( with.*)?$/$1($size[0])/;
 748         $data_type .= $2 if(defined $2);
 749     } elsif ( defined $size[0] && $size[0] > 0 ) {
 750         $data_type .= '(' . join( ',', @size ) . ')';
 751     }
 752     if($array)
 753     {
 754         $data_type .= '[]';
 755     }
 756
 757     #
 758     # Geography
 759     #
 760     if($data_type eq 'geography'){
 761         $data_type .= '('.$field->{extra}{geography_type}.','. $field->{extra}{srid} .')'
 762     }
 763
 764     return $data_type;
 765 }
 766
 767
 768 sub alter_field
 769 {
 770     my ($from_field, $to_field) = @_;
 771
 772     die "Can't alter field in another table"
 773         if($from_field->table->name ne $to_field->table->name);
 774
 775     my @out;
 776
 777     # drop geometry column and constraints
 778         push @out, drop_geometry_column($from_field) if is_geometry($from_field);
 779         push @out, drop_geometry_constraints($from_field) if is_geometry($from_field);
 780
 781     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL',
 782                        $to_field->table->name,
 783                        $to_field->name) if(!$to_field->is_nullable and
 784                                            $from_field->is_nullable);
 785
 786     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP NOT NULL',
 787                       $to_field->table->name,
 788                       $to_field->name)
 789        if ( !$from_field->is_nullable and $to_field->is_nullable );
 790
 791
 792     my $from_dt = convert_datatype($from_field);
 793     my $to_dt   = convert_datatype($to_field);
 794     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s',
 795                        $to_field->table->name,
 796                        $to_field->name,
 797                        $to_dt) if($to_dt ne $from_dt);
 798
 799     push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s',
 800                        $to_field->table->name,
 801                        $from_field->name,
 802                        $to_field->name) if($from_field->name ne $to_field->name);
 803
 804     my $old_default = $from_field->default_value;
 805     my $new_default = $to_field->default_value;
 806     my $default_value = $to_field->default_value;
 807
 808     # fixes bug where output like this was created:
 809     # ALTER TABLE users ALTER COLUMN column SET DEFAULT ThisIsUnescaped;
 810     if(ref $default_value eq "SCALAR" ) {
 811         $default_value = $$default_value;
 812     } elsif( defined $default_value && $to_dt =~ /^(character|text)/xsmi ) {
 813         $default_value =~ s/'/''/xsmg;
 814         $default_value = q(') . $default_value . q(');
 815     }
 816
 817     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
 818                        $to_field->table->name,
 819                        $to_field->name,
 820                        $default_value)
 821         if ( defined $new_default &&
 822              (!defined $old_default || $old_default ne $new_default) );
 823
 824      # fixes bug where removing the DEFAULT statement of a column
 825      # would result in no change
 826
 827      push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
 828                        $to_field->table->name,
 829                        $to_field->name)
 830         if ( !defined $new_default && defined $old_default );
 831
 832         # add geometry column and contraints
 833         push @out, add_geometry_column($to_field) if is_geometry($to_field);
 834         push @out, add_geometry_constraints($to_field) if is_geometry($to_field);
 835
 836     return wantarray ? @out : join("\n", @out);
 837 }
 838
 839 sub rename_field { alter_field(@_) }
 840
 841 sub add_field
 842 {
 843     my ($new_field) = @_;
 844
 845     my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
 846                       $new_field->table->name,
 847                       create_field($new_field));
 848     $out .= "\n".add_geometry_column($new_field) if is_geometry($new_field);
 849     $out .= "\n".add_geometry_constraints($new_field) if is_geometry($new_field);
 850     return $out;
 851
 852 }
 853
 854 sub drop_field
 855 {
 856     my ($old_field) = @_;
 857
 858     my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
 859                       $old_field->table->name,
 860                       $old_field->name);
 861         $out .= "\n".drop_geometry_column($old_field) if is_geometry($old_field);
 862     return $out;
 863 }
 864
 865 sub add_geometry_column{
 866         my ($field,$options) = @_;
 867
 868         my $out = sprintf("INSERT INTO geometry_columns VALUES ('%s','%s','%s','%s','%s','%s','%s')",
 869                                                 '',
 870                                                 $field->table->schema->name,
 871                                                 $options->{table} ? $options->{table} : $field->table->name,
 872                                                 $field->name,
 873                                                 $field->{extra}{dimensions},
 874                                                 $field->{extra}{srid},
 875                                                 $field->{extra}{geometry_type});
 876     return $out;
 877 }
 878
 879 sub drop_geometry_column
 880 {
 881         my $field = shift;
 882
 883         my $out = sprintf("DELETE FROM geometry_columns WHERE f_table_schema = '%s' AND f_table_name = '%s' AND f_geometry_column = '%s'",
 884                                                 $field->table->schema->name,
 885                                                 $field->table->name,
 886                                                 $field->name);
 887     return $out;
 888 }
 889
 890 sub add_geometry_constraints{
 891         my $field = shift;
 892
 893         my @constraints = create_geometry_constraints($field);
 894
 895         my $out = join("\n", map { alter_create_constraint($_); } @constraints);
 896
 897         return $out;
 898 }
 899
 900 sub drop_geometry_constraints{
 901         my $field = shift;
 902
 903         my @constraints = create_geometry_constraints($field);
 904
 905         my $out = join("\n", map { alter_drop_constraint($_); } @constraints);
 906
 907         return $out;
 908 }
 909
 910 sub alter_table {
 911     my ($to_table, $options) = @_;
 912     my $qt = $options->{quote_table_names} || '';
 913     my $out = sprintf('ALTER TABLE %s %s',
 914                       $qt . $to_table->name . $qt,
 915                       $options->{alter_table_action});
 916     $out .= "\n".$options->{geometry_changes} if $options->{geometry_changes};
 917     return $out;
 918 }
 919
 920 sub rename_table {
 921     my ($old_table, $new_table, $options) = @_;
 922     my $qt = $options->{quote_table_names} || '';
 923     $options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
 924
 925         my @geometry_changes;
 926         push @geometry_changes, map { drop_geometry_column($_); } grep { is_geometry($_) } $old_table->get_fields;
 927         push @geometry_changes, map { add_geometry_column($_, { table => $new_table }); } grep { is_geometry($_) } $old_table->get_fields;
 928
 929     $options->{geometry_changes} = join ("\n",@geometry_changes) if scalar(@geometry_changes);
 930
 931     return alter_table($old_table, $options);
 932 }
 933
 934 sub alter_create_index {
 935     my ($index, $options) = @_;
 936     my $qt = $options->{quote_table_names} || '';
 937     my $qf = $options->{quote_field_names} || '';
 938     my ($idef, $constraints) = create_index($index, {
 939         quote_field_names => $qf,
 940         quote_table_names => $qt,
 941         table_name => $index->table->name,
 942     });
 943     return $index->type eq NORMAL ? $idef
 944         : sprintf('ALTER TABLE %s ADD %s',
 945               $qt . $index->table->name . $qt,
 946               join(q{}, @$constraints)
 947           );
 948 }
 949
 950 sub alter_drop_index {
 951     my ($index, $options) = @_;
 952     my $index_name = $index->name;
 953     return "DROP INDEX $index_name";
 954 }
 955
 956 sub alter_drop_constraint {
 957     my ($c, $options) = @_;
 958     my $qt = $options->{quote_table_names} || '';
 959     my $qc = $options->{quote_field_names} || '';
 960     my $out = sprintf('ALTER TABLE %s DROP CONSTRAINT %s',
 961                       $qt . $c->table->name . $qt,
 962                       $qc . $c->name . $qc );
 963     return $out;
 964 }
 965
 966 sub alter_create_constraint {
 967     my ($index, $options) = @_;
 968     my $qt = $options->{quote_table_names} || '';
 969     my ($defs, $fks) = create_constraint(@_);
 970
 971     # return if there are no constraint definitions so we don't run
 972     # into output like this:
 973     # ALTER TABLE users ADD ;
 974
 975     return unless(@{$defs} || @{$fks});
 976     return $index->type eq FOREIGN_KEY ? join(q{}, @{$fks})
 977         : join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
 978               'ADD', join(q{}, @{$defs}, @{$fks})
 979           );
 980 }
 981
 982 sub drop_table {
 983     my ($table, $options) = @_;
 984     my $qt = $options->{quote_table_names} || '';
 985     my $out = "DROP TABLE $qt$table$qt CASCADE";
 986
 987     my @geometry_drops = map { drop_geometry_column($_); } grep { is_geometry($_) } $table->get_fields;
 988
 989     $out .= "\n".join("\n",@geometry_drops) if scalar(@geometry_drops);
 990     return $out;
 991 }
 992
 993 1;
 994
 995 # -------------------------------------------------------------------
 996 # Life is full of misery, loneliness, and suffering --
 997 # and it's all over much too soon.
 998 # Woody Allen
 999 # -------------------------------------------------------------------
1000
1001 =pod
1002
1003 =head1 SEE ALSO
1004
1005 SQL::Translator, SQL::Translator::Producer::Oracle.
1006
1007 =head1 AUTHOR
1008
1009 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
1010
1011 =cut