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