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