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