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