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         add_drop_view     => $add_drop_table,
 216         quote_table_names => $qt,
 217         quote_field_names => $qf,
 218         no_comments       => $no_comments,
 219       });
 220     }
 221
 222     push @output, map { "$_;\n\n" } values %type_defs;
 223     push @output, map { "$_;\n\n" } @table_defs;
 224     if ( @fks ) {
 225         push @output, "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
 226         push @output, map { "$_;\n\n" } @fks;
 227     }
 228
 229     if ( $WARN ) {
 230         if ( %truncated ) {
 231             warn "Truncated " . keys( %truncated ) . " names:\n";
 232             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 233         }
 234     }
 235
 236     return wantarray
 237         ? @output
 238         : join ('', @output);
 239 }
 240
 241 # -------------------------------------------------------------------
 242 sub mk_name {
 243     my $basename      = shift || '';
 244     my $type          = shift || '';
 245     my $scope         = shift || '';
 246     my $critical      = shift || '';
 247     my $basename_orig = $basename;
 248 #    my $max_id_length = 62;
 249     my $max_name      = $type
 250                         ? $max_id_length - (length($type) + 1)
 251                         : $max_id_length;
 252     $basename         = substr( $basename, 0, $max_name )
 253                         if length( $basename ) > $max_name;
 254     my $name          = $type ? "${type}_$basename" : $basename;
 255
 256     if ( $basename ne $basename_orig and $critical ) {
 257         my $show_type = $type ? "+'$type'" : "";
 258         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 259             "character limit to make '$name'\n" if $WARN;
 260         $truncated{ $basename_orig } = $name;
 261     }
 262
 263     $scope ||= \%global_names;
 264     if ( my $prev = $scope->{ $name } ) {
 265         my $name_orig = $name;
 266         $name        .= sprintf( "%02d", ++$prev );
 267         substr($name, $max_id_length - 3) = "00"
 268             if length( $name ) > $max_id_length;
 269
 270         warn "The name '$name_orig' has been changed to ",
 271              "'$name' to make it unique.\n" if $WARN;
 272
 273         $scope->{ $name_orig }++;
 274     }
 275
 276     $scope->{ $name }++;
 277     return $name;
 278 }
 279
 280 # -------------------------------------------------------------------
 281 sub next_unused_name {
 282     my $orig_name = shift or return;
 283     my $name      = $orig_name;
 284
 285     my $suffix_gen = sub {
 286         my $suffix = 0;
 287         return ++$suffix ? '' : $suffix;
 288     };
 289
 290     for (;;) {
 291         $name = $orig_name . $suffix_gen->();
 292         last if $used_names{ $name }++;
 293     }
 294
 295     return $name;
 296 }
 297
 298 sub is_geometry
 299 {
 300         my $field = shift;
 301         return 1 if $field->data_type eq 'geometry';
 302 }
 303
 304 sub is_geography
 305 {
 306     my $field = shift;
 307     return 1 if $field->data_type eq 'geography';
 308 }
 309
 310 sub create_table
 311 {
 312     my ($table, $options) = @_;
 313
 314     my $qt = $options->{quote_table_names} || '';
 315     my $qf = $options->{quote_field_names} || '';
 316     my $no_comments = $options->{no_comments} || 0;
 317     my $add_drop_table = $options->{add_drop_table} || 0;
 318     my $postgres_version = $options->{postgres_version} || 0;
 319     my $type_defs = $options->{type_defs} || {};
 320
 321     my $table_name = $table->name or next;
 322     my ( $fql_tbl_name ) = ( $table_name =~ s/\W(.*)$// ) ? $1 : q{};
 323     my $table_name_ur = $qt ? $table_name
 324         : $fql_tbl_name ? join('.', $table_name, $fql_tbl_name)
 325         : $table_name;
 326     $table->name($table_name_ur);
 327
 328 # print STDERR "$table_name table_name\n";
 329     my ( @comments, @field_defs, @sequence_defs, @constraint_defs, @fks );
 330
 331     push @comments, "--\n-- Table: $table_name_ur\n--\n" unless $no_comments;
 332
 333     if ( $table->comments and !$no_comments ){
 334         my $c = "-- Comments: \n-- ";
 335         $c .= join "\n-- ",  $table->comments;
 336         $c .= "\n--\n";
 337         push @comments, $c;
 338     }
 339
 340     #
 341     # Fields
 342     #
 343     my %field_name_scope;
 344     for my $field ( $table->get_fields ) {
 345         push @field_defs, create_field($field, { quote_table_names => $qt,
 346                                                  quote_field_names => $qf,
 347                                                  table_name => $table_name_ur,
 348                                                  postgres_version => $postgres_version,
 349                                                  type_defs => $type_defs,
 350                                                  constraint_defs => \@constraint_defs,});
 351     }
 352
 353     #
 354     # Index Declarations
 355     #
 356     my @index_defs = ();
 357  #   my $idx_name_default;
 358     for my $index ( $table->get_indices ) {
 359         my ($idef, $constraints) = create_index($index,
 360                                               {
 361                                                   quote_field_names => $qf,
 362                                                   quote_table_names => $qt,
 363                                                   table_name => $table_name,
 364                                               });
 365         $idef and push @index_defs, $idef;
 366         push @constraint_defs, @$constraints;
 367     }
 368
 369     #
 370     # Table constraints
 371     #
 372     my $c_name_default;
 373     for my $c ( $table->get_constraints ) {
 374         my ($cdefs, $fks) = create_constraint($c,
 375                                               {
 376                                                   quote_field_names => $qf,
 377                                                   quote_table_names => $qt,
 378                                                   table_name => $table_name,
 379                                               });
 380         push @constraint_defs, @$cdefs;
 381         push @fks, @$fks;
 382     }
 383
 384
 385     my $temporary = "";
 386
 387     if(exists $table->{extra}{temporary}) {
 388         $temporary = $table->{extra}{temporary} ? "TEMPORARY " : "";
 389     }
 390
 391     my $create_statement;
 392     $create_statement = join("\n", @comments);
 393     if ($add_drop_table) {
 394         if ($postgres_version >= 8.002) {
 395             $create_statement .= qq[DROP TABLE IF EXISTS $qt$table_name_ur$qt CASCADE;\n];
 396         } else {
 397             $create_statement .= qq[DROP TABLE $qt$table_name_ur$qt CASCADE;\n];
 398         }
 399     }
 400     $create_statement .= qq[CREATE ${temporary}TABLE $qt$table_name_ur$qt (\n].
 401                             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 402                             "\n)"
 403                             ;
 404     $create_statement .= @index_defs ? ';' : q{};
 405     $create_statement .= ( $create_statement =~ /;$/ ? "\n" : q{} )
 406         . join(";\n", @index_defs);
 407
 408         #
 409         # Geometry
 410         #
 411         if(grep { is_geometry($_) } $table->get_fields){
 412         $create_statement .= ";";
 413         my @geometry_columns;
 414         foreach my $col ($table->get_fields) { push(@geometry_columns,$col) if is_geometry($col); }
 415                 $create_statement .= "\n".join("\n", map{ drop_geometry_column($_) } @geometry_columns) if $options->{add_drop_table};
 416                 $create_statement .= "\n".join("\n", map{ add_geometry_column($_) } @geometry_columns);
 417         }
 418
 419     return $create_statement, \@fks;
 420 }
 421
 422 sub create_view {
 423     my ($view, $options) = @_;
 424     my $qt = $options->{quote_table_names} || '';
 425     my $qf = $options->{quote_field_names} || '';
 426     my $add_drop_view = $options->{add_drop_view};
 427
 428     my $view_name = $view->name;
 429     debug("PKG: Looking at view '${view_name}'\n");
 430
 431     my $create = '';
 432     $create .= "--\n-- View: ${qt}${view_name}${qt}\n--\n"
 433         unless $options->{no_comments};
 434     $create .= "DROP VIEW ${qt}${view_name}${qt};\n" if $add_drop_view;
 435     $create .= 'CREATE';
 436
 437     my $extra = $view->extra;
 438     $create .= " TEMPORARY" if exists($extra->{temporary}) && $extra->{temporary};
 439     $create .= " VIEW ${qt}${view_name}${qt}";
 440
 441     if ( my @fields = $view->fields ) {
 442         my $field_list = join ', ', map { "${qf}${_}${qf}" } @fields;
 443         $create .= " ( ${field_list} )";
 444     }
 445
 446     if ( my $sql = $view->sql ) {
 447         $create .= " AS\n    ${sql}\n";
 448     }
 449
 450     if ( $extra->{check_option} ) {
 451         $create .= ' WITH ' . uc $extra->{check_option} . ' CHECK OPTION';
 452     }
 453
 454     return $create;
 455 }
 456
 457 {
 458
 459     my %field_name_scope;
 460
 461     sub create_field
 462     {
 463         my ($field, $options) = @_;
 464
 465         my $qt = $options->{quote_table_names} || '';
 466         my $qf = $options->{quote_field_names} || '';
 467         my $table_name = $field->table->name;
 468         my $constraint_defs = $options->{constraint_defs} || [];
 469         my $postgres_version = $options->{postgres_version} || 0;
 470         my $type_defs = $options->{type_defs} || {};
 471
 472         $field_name_scope{$table_name} ||= {};
 473         my $field_name    = $field->name;
 474         my $field_comments = $field->comments
 475             ? "-- " . $field->comments . "\n  "
 476             : '';
 477
 478         my $field_def     = $field_comments.qq[$qf$field_name$qf];
 479
 480         #
 481         # Datatype
 482         #
 483         my @size      = $field->size;
 484         my $data_type = lc $field->data_type;
 485         my %extra     = $field->extra;
 486         my $list      = $extra{'list'} || [];
 487         # todo deal with embedded quotes
 488         my $commalist = join( ', ', map { qq['$_'] } @$list );
 489
 490         if ($postgres_version >= 8.003 && $field->data_type eq 'enum') {
 491             my $type_name = $extra{'custom_type_name'} || $field->table->name . '_' . $field->name . '_type';
 492             $field_def .= ' '. $type_name;
 493             my $new_type_def = "DROP TYPE IF EXISTS $type_name CASCADE;\n" .
 494                                "CREATE TYPE $type_name AS ENUM ($commalist)";
 495             if (! exists $type_defs->{$type_name} ) {
 496                 $type_defs->{$type_name} = $new_type_def;
 497             } elsif ( $type_defs->{$type_name} ne $new_type_def ) {
 498                 die "Attempted to redefine type name '$type_name' as a different type.\n";
 499             }
 500         } else {
 501             $field_def .= ' '. convert_datatype($field);
 502         }
 503
 504         #
 505         # Default value
 506         #
 507         SQL::Translator::Producer->_apply_default_value(
 508           $field,
 509           \$field_def,
 510           [
 511             'NULL'              => \'NULL',
 512             'now()'             => 'now()',
 513             'CURRENT_TIMESTAMP' => 'CURRENT_TIMESTAMP',
 514           ],
 515         );
 516
 517         #
 518         # Not null constraint
 519         #
 520         $field_def .= ' NOT NULL' unless $field->is_nullable;
 521
 522                 #
 523                 # Geometry constraints
 524                 #
 525                 if(is_geometry($field)){
 526                         foreach ( create_geometry_constraints($field) ) {
 527                                 my ($cdefs, $fks) = create_constraint($_,
 528                                                                                                           {
 529                                                                                                                   quote_field_names => $qf,
 530                                                                                                                   quote_table_names => $qt,
 531                                                                                                                   table_name => $table_name,
 532                                                                                                           });
 533                                 push @$constraint_defs, @$cdefs;
 534                                 push @$fks, @$fks;
 535                         }
 536         }
 537
 538         return $field_def;
 539     }
 540 }
 541
 542 sub create_geometry_constraints{
 543         my $field = shift;
 544
 545         my @constraints;
 546         push @constraints, SQL::Translator::Schema::Constraint->new(
 547                                                         name       => "enforce_dims_".$field->name,
 548                                                         expression => "(st_ndims($field) = ".$field->{extra}{dimensions}.")",
 549                                                         table      => $field->table,
 550                                                         type       => CHECK_C,
 551                                                 );
 552
 553         push @constraints, SQL::Translator::Schema::Constraint->new(
 554                                                         name       => "enforce_srid_".$field->name,
 555                                                         expression => "(st_srid($field) = ".$field->{extra}{srid}.")",
 556                                                         table      => $field->table,
 557                                                         type       => CHECK_C,
 558                                                 );
 559         push @constraints, SQL::Translator::Schema::Constraint->new(
 560                                                         name       => "enforce_geotype_".$field->name,
 561                                                         expression => "(geometrytype($field) = '".$field->{extra}{geometry_type}."'::text OR $field IS NULL)",
 562                                                         table      => $field->table,
 563                                                         type       => CHECK_C,
 564                                                 );
 565
 566         return @constraints;
 567 }
 568
 569 sub create_index
 570 {
 571     my ($index, $options) = @_;
 572
 573     my $qt = $options->{quote_table_names} ||'';
 574     my $qf = $options->{quote_field_names} ||'';
 575     my $table_name = $index->table->name;
 576
 577     my ($index_def, @constraint_defs);
 578
 579     my $name = next_unused_name(
 580         $index->name
 581         || join('_', $table_name, 'idx', ++$index_name{ $table_name })
 582     );
 583
 584     my $type = $index->type || NORMAL;
 585     my @fields     =  $index->fields;
 586     next unless @fields;
 587
 588     my $def_start = qq[CONSTRAINT ${qf}$name${qf} ];
 589     my $field_names = '(' . join(", ", (map { $_ =~ /\(.*\)/ ? $_ : ($qf . $_ . $qf ) } @fields)) . ')';
 590     if ( $type eq PRIMARY_KEY ) {
 591         push @constraint_defs, "${def_start}PRIMARY KEY ".$field_names;
 592     }
 593     elsif ( $type eq UNIQUE ) {
 594         push @constraint_defs, "${def_start}UNIQUE " .$field_names;
 595     }
 596     elsif ( $type eq NORMAL ) {
 597         $index_def =
 598             "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} ".$field_names
 599             ;
 600     }
 601     else {
 602         warn "Unknown index type ($type) on table $table_name.\n"
 603             if $WARN;
 604     }
 605
 606     return $index_def, \@constraint_defs;
 607 }
 608
 609 sub create_constraint
 610 {
 611     my ($c, $options) = @_;
 612
 613     my $qf = $options->{quote_field_names} ||'';
 614     my $qt = $options->{quote_table_names} ||'';
 615     my $table_name = $c->table->name;
 616     my (@constraint_defs, @fks);
 617
 618     my $name = $c->name || '';
 619     if ( $name ) {
 620         $name = next_unused_name($name);
 621     }
 622
 623     my @fields = grep { defined } $c->fields;
 624
 625     my @rfields = grep { defined } $c->reference_fields;
 626
 627     next if !@fields && $c->type ne CHECK_C;
 628     my $def_start = $name ? qq[CONSTRAINT ${qf}$name${qf} ] : '';
 629     my $field_names = '(' . join(", ", (map { $_ =~ /\(.*\)/ ? $_ : ($qf . $_ . $qf ) } @fields)) . ')';
 630     if ( $c->type eq PRIMARY_KEY ) {
 631         push @constraint_defs, "${def_start}PRIMARY KEY ".$field_names;
 632     }
 633     elsif ( $c->type eq UNIQUE ) {
 634         push @constraint_defs, "${def_start}UNIQUE " .$field_names;
 635     }
 636     elsif ( $c->type eq CHECK_C ) {
 637         my $expression = $c->expression;
 638         push @constraint_defs, "${def_start}CHECK ($expression)";
 639     }
 640     elsif ( $c->type eq FOREIGN_KEY ) {
 641         my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY " . $field_names .
 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 sub convert_datatype
 672 {
 673     my ($field) = @_;
 674
 675     my @size      = $field->size;
 676     my $data_type = lc $field->data_type;
 677
 678     if ( $data_type eq 'enum' ) {
 679 #        my $len = 0;
 680 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 681 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 682 #        push @$constraint_defs,
 683 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 684 #           qq[IN ($commalist))];
 685         $data_type = 'character varying';
 686     }
 687     elsif ( $data_type eq 'set' ) {
 688         $data_type = 'character varying';
 689     }
 690     elsif ( $field->is_auto_increment ) {
 691         if ( defined $size[0] && $size[0] > 11 ) {
 692             $data_type = 'bigserial';
 693         }
 694         else {
 695             $data_type = 'serial';
 696         }
 697         undef @size;
 698     }
 699     else {
 700         $data_type  = defined $translate{ $data_type } ?
 701             $translate{ $data_type } :
 702             $data_type;
 703     }
 704
 705     if ( $data_type =~ /^time/i || $data_type =~ /^interval/i ) {
 706         if ( defined $size[0] && $size[0] > 6 ) {
 707             $size[0] = 6;
 708         }
 709     }
 710
 711     if ( $data_type eq 'integer' ) {
 712         if ( defined $size[0] && $size[0] > 0) {
 713             if ( $size[0] > 10 ) {
 714                 $data_type = 'bigint';
 715             }
 716             elsif ( $size[0] < 5 ) {
 717                 $data_type = 'smallint';
 718             }
 719             else {
 720                 $data_type = 'integer';
 721             }
 722         }
 723         else {
 724             $data_type = 'integer';
 725         }
 726     }
 727
 728     my $type_with_size = join('|',
 729         'bit', 'varbit', 'character', 'bit varying', 'character varying',
 730         'time', 'timestamp', 'interval', 'numeric'
 731     );
 732
 733     if ( $data_type !~ /$type_with_size/ ) {
 734         @size = ();
 735     }
 736
 737     if (defined $size[0] && $size[0] > 0 && $data_type =~ /^time/i ) {
 738         $data_type =~ s/^(time.*?)( with.*)?$/$1($size[0])/;
 739         $data_type .= $2 if(defined $2);
 740     } elsif ( defined $size[0] && $size[0] > 0 ) {
 741         $data_type .= '(' . join( ',', @size ) . ')';
 742     }
 743
 744     #
 745     # Geography
 746     #
 747     if($data_type eq 'geography'){
 748         $data_type .= '('.$field->{extra}{geography_type}.','. $field->{extra}{srid} .')'
 749     }
 750
 751     return $data_type;
 752 }
 753
 754
 755 sub alter_field
 756 {
 757     my ($from_field, $to_field) = @_;
 758
 759     die "Can't alter field in another table"
 760         if($from_field->table->name ne $to_field->table->name);
 761
 762     my @out;
 763
 764     # drop geometry column and constraints
 765         push @out, drop_geometry_column($from_field) if is_geometry($from_field);
 766         push @out, drop_geometry_constraints($from_field) if is_geometry($from_field);
 767
 768     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL',
 769                        $to_field->table->name,
 770                        $to_field->name) if(!$to_field->is_nullable and
 771                                            $from_field->is_nullable);
 772
 773     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP NOT NULL',
 774                       $to_field->table->name,
 775                       $to_field->name)
 776        if ( !$from_field->is_nullable and $to_field->is_nullable );
 777
 778
 779     my $from_dt = convert_datatype($from_field);
 780     my $to_dt   = convert_datatype($to_field);
 781     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s',
 782                        $to_field->table->name,
 783                        $to_field->name,
 784                        $to_dt) if($to_dt ne $from_dt);
 785
 786     push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s',
 787                        $to_field->table->name,
 788                        $from_field->name,
 789                        $to_field->name) if($from_field->name ne $to_field->name);
 790
 791     my $old_default = $from_field->default_value;
 792     my $new_default = $to_field->default_value;
 793     my $default_value = $to_field->default_value;
 794
 795     # fixes bug where output like this was created:
 796     # ALTER TABLE users ALTER COLUMN column SET DEFAULT ThisIsUnescaped;
 797     if(ref $default_value eq "SCALAR" ) {
 798         $default_value = $$default_value;
 799     } elsif( defined $default_value && $to_dt =~ /^(character|text)/xsmi ) {
 800         $default_value =~ s/'/''/xsmg;
 801         $default_value = q(') . $default_value . q(');
 802     }
 803
 804     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
 805                        $to_field->table->name,
 806                        $to_field->name,
 807                        $default_value)
 808         if ( defined $new_default &&
 809              (!defined $old_default || $old_default ne $new_default) );
 810
 811      # fixes bug where removing the DEFAULT statement of a column
 812      # would result in no change
 813
 814      push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
 815                        $to_field->table->name,
 816                        $to_field->name)
 817         if ( !defined $new_default && defined $old_default );
 818
 819         # add geometry column and contraints
 820         push @out, add_geometry_column($to_field) if is_geometry($to_field);
 821         push @out, add_geometry_constraints($to_field) if is_geometry($to_field);
 822
 823     return wantarray ? @out : join("\n", @out);
 824 }
 825
 826 sub rename_field { alter_field(@_) }
 827
 828 sub add_field
 829 {
 830     my ($new_field) = @_;
 831
 832     my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
 833                       $new_field->table->name,
 834                       create_field($new_field));
 835     $out .= "\n".add_geometry_column($new_field) if is_geometry($new_field);
 836     $out .= "\n".add_geometry_constraints($new_field) if is_geometry($new_field);
 837     return $out;
 838
 839 }
 840
 841 sub drop_field
 842 {
 843     my ($old_field) = @_;
 844
 845     my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
 846                       $old_field->table->name,
 847                       $old_field->name);
 848         $out .= "\n".drop_geometry_column($old_field) if is_geometry($old_field);
 849     return $out;
 850 }
 851
 852 sub add_geometry_column{
 853         my ($field,$options) = @_;
 854
 855         my $out = sprintf("INSERT INTO geometry_columns VALUES ('%s','%s','%s','%s','%s','%s','%s')",
 856                                                 '',
 857                                                 $field->table->schema->name,
 858                                                 $options->{table} ? $options->{table} : $field->table->name,
 859                                                 $field->name,
 860                                                 $field->{extra}{dimensions},
 861                                                 $field->{extra}{srid},
 862                                                 $field->{extra}{geometry_type});
 863     return $out;
 864 }
 865
 866 sub drop_geometry_column
 867 {
 868         my $field = shift;
 869
 870         my $out = sprintf("DELETE FROM geometry_columns WHERE f_table_schema = '%s' AND f_table_name = '%s' AND f_geometry_column = '%s'",
 871                                                 $field->table->schema->name,
 872                                                 $field->table->name,
 873                                                 $field->name);
 874     return $out;
 875 }
 876
 877 sub add_geometry_constraints{
 878         my $field = shift;
 879
 880         my @constraints = create_geometry_constraints($field);
 881
 882         my $out = join("\n", map { alter_create_constraint($_); } @constraints);
 883
 884         return $out;
 885 }
 886
 887 sub drop_geometry_constraints{
 888         my $field = shift;
 889
 890         my @constraints = create_geometry_constraints($field);
 891
 892         my $out = join("\n", map { alter_drop_constraint($_); } @constraints);
 893
 894         return $out;
 895 }
 896
 897 sub alter_table {
 898     my ($to_table, $options) = @_;
 899     my $qt = $options->{quote_table_names} || '';
 900     my $out = sprintf('ALTER TABLE %s %s',
 901                       $qt . $to_table->name . $qt,
 902                       $options->{alter_table_action});
 903     $out .= "\n".$options->{geometry_changes} if $options->{geometry_changes};
 904     return $out;
 905 }
 906
 907 sub rename_table {
 908     my ($old_table, $new_table, $options) = @_;
 909     my $qt = $options->{quote_table_names} || '';
 910     $options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
 911
 912         my @geometry_changes;
 913         push @geometry_changes, map { drop_geometry_column($_); } grep { is_geometry($_) } $old_table->get_fields;
 914         push @geometry_changes, map { add_geometry_column($_, { table => $new_table }); } grep { is_geometry($_) } $old_table->get_fields;
 915
 916     $options->{geometry_changes} = join ("\n",@geometry_changes) if scalar(@geometry_changes);
 917
 918     return alter_table($old_table, $options);
 919 }
 920
 921 sub alter_create_index {
 922     my ($index, $options) = @_;
 923     my $qt = $options->{quote_table_names} || '';
 924     my $qf = $options->{quote_field_names} || '';
 925     my ($idef, $constraints) = create_index($index, {
 926         quote_field_names => $qf,
 927         quote_table_names => $qt,
 928         table_name => $index->table->name,
 929     });
 930     return $index->type eq NORMAL ? $idef
 931         : sprintf('ALTER TABLE %s ADD %s',
 932               $qt . $index->table->name . $qt,
 933               join(q{}, @$constraints)
 934           );
 935 }
 936
 937 sub alter_drop_index {
 938     my ($index, $options) = @_;
 939     my $index_name = $index->name;
 940     return "DROP INDEX $index_name";
 941 }
 942
 943 sub alter_drop_constraint {
 944     my ($c, $options) = @_;
 945     my $qt = $options->{quote_table_names} || '';
 946     my $qc = $options->{quote_field_names} || '';
 947     my $out = sprintf('ALTER TABLE %s DROP CONSTRAINT %s',
 948                       $qt . $c->table->name . $qt,
 949                       $qc . $c->name . $qc );
 950     return $out;
 951 }
 952
 953 sub alter_create_constraint {
 954     my ($index, $options) = @_;
 955     my $qt = $options->{quote_table_names} || '';
 956     my ($defs, $fks) = create_constraint(@_);
 957
 958     # return if there are no constraint definitions so we don't run
 959     # into output like this:
 960     # ALTER TABLE users ADD ;
 961
 962     return unless(@{$defs} || @{$fks});
 963     return $index->type eq FOREIGN_KEY ? join(q{}, @{$fks})
 964         : join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
 965               'ADD', join(q{}, @{$defs}, @{$fks})
 966           );
 967 }
 968
 969 sub drop_table {
 970     my ($table, $options) = @_;
 971     my $qt = $options->{quote_table_names} || '';
 972     my $out = "DROP TABLE $qt$table$qt CASCADE";
 973
 974     my @geometry_drops = map { drop_geometry_column($_); } grep { is_geometry($_) } $table->get_fields;
 975
 976     $out .= "\n".join("\n",@geometry_drops) if scalar(@geometry_drops);
 977     return $out;
 978 }
 979
 980 1;
 981
 982 # -------------------------------------------------------------------
 983 # Life is full of misery, loneliness, and suffering --
 984 # and it's all over much too soon.
 985 # Woody Allen
 986 # -------------------------------------------------------------------
 987
 988 =pod
 989
 990 =head1 SEE ALSO
 991
 992 SQL::Translator, SQL::Translator::Producer::Oracle.
 993
 994 =head1 AUTHOR
 995
 996 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 997
 998 =cut