lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
   6
   7 =head1 SYNOPSIS
   8
   9   my $t = SQL::Translator->new( parser => '...', producer => 'PostgreSQL' );
  10   $t->translate;
  11
  12 =head1 DESCRIPTION
  13
  14 Creates a DDL suitable for PostgreSQL.  Very heavily based on the Oracle
  15 producer.
  16
  17 Now handles PostGIS Geometry and Geography data types on table definitions.
  18 Does not yet support PostGIS Views.
  19
  20 =cut
  21
  22 use strict;
  23 use warnings;
  24 use vars qw[ $DEBUG $WARN $VERSION %used_names ];
  25 $VERSION = '1.59';
  26 $DEBUG = 0 unless defined $DEBUG;
  27
  28 use base qw(SQL::Translator::Producer);
  29 use SQL::Translator::Schema::Constants;
  30 use SQL::Translator::Utils qw(debug header_comment parse_dbms_version);
  31 use Data::Dumper;
  32
  33 my ( %translate, %index_name );
  34 my $max_id_length;
  35
  36 BEGIN {
  37
  38  %translate  = (
  39     #
  40     # MySQL types
  41     #
  42     bigint     => 'bigint',
  43     double     => 'numeric',
  44     decimal    => 'numeric',
  45     float      => 'numeric',
  46     int        => 'integer',
  47     mediumint  => 'integer',
  48     smallint   => 'smallint',
  49     tinyint    => 'smallint',
  50     char       => 'character',
  51     varchar    => 'character varying',
  52     longtext   => 'text',
  53     mediumtext => 'text',
  54     text       => 'text',
  55     tinytext   => 'text',
  56     tinyblob   => 'bytea',
  57     blob       => 'bytea',
  58     mediumblob => 'bytea',
  59     longblob   => 'bytea',
  60     enum       => 'character varying',
  61     set        => 'character varying',
  62     date       => 'date',
  63     datetime   => 'timestamp',
  64     time       => 'time',
  65     timestamp  => 'timestamp',
  66     year       => 'date',
  67
  68     #
  69     # Oracle types
  70     #
  71     number     => 'integer',
  72     char       => 'character',
  73     varchar2   => 'character varying',
  74     long       => 'text',
  75     CLOB       => 'bytea',
  76     date       => 'date',
  77
  78     #
  79     # Sybase types
  80     #
  81     int        => 'integer',
  82     money      => 'money',
  83     varchar    => 'character varying',
  84     datetime   => 'timestamp',
  85     text       => 'text',
  86     real       => 'numeric',
  87     comment    => 'text',
  88     bit        => 'bit',
  89     tinyint    => 'smallint',
  90     float      => 'numeric',
  91 );
  92
  93  $max_id_length = 62;
  94 }
  95 my %reserved = map { $_, 1 } qw[
  96     ALL ANALYSE ANALYZE AND ANY AS ASC
  97     BETWEEN BINARY BOTH
  98     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  99     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
 100     DEFAULT DEFERRABLE DESC DISTINCT DO
 101     ELSE END EXCEPT
 102     FALSE FOR FOREIGN FREEZE FROM FULL
 103     GROUP HAVING
 104     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
 105     JOIN LEADING LEFT LIKE LIMIT
 106     NATURAL NEW NOT NOTNULL NULL
 107     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
 108     PRIMARY PUBLIC REFERENCES RIGHT
 109     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
 110     UNION UNIQUE USER USING VERBOSE WHEN WHERE
 111 ];
 112
 113 # my $max_id_length    = 62;
 114 my %used_identifiers = ();
 115 my %global_names;
 116 my %unreserve;
 117 my %truncated;
 118
 119 =pod
 120
 121 =head1 PostgreSQL Create Table Syntax
 122
 123   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
 124       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
 125       | table_constraint }  [, ... ]
 126   )
 127   [ INHERITS ( parent_table [, ... ] ) ]
 128   [ WITH OIDS | WITHOUT OIDS ]
 129
 130 where column_constraint is:
 131
 132   [ CONSTRAINT constraint_name ]
 133   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
 134     CHECK (expression) |
 135     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
 136       [ ON DELETE action ] [ ON UPDATE action ] }
 137   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 138
 139 and table_constraint is:
 140
 141   [ CONSTRAINT constraint_name ]
 142   { UNIQUE ( column_name [, ... ] ) |
 143     PRIMARY KEY ( column_name [, ... ] ) |
 144     CHECK ( expression ) |
 145     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 146       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 147   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 148
 149 =head1 Create Index Syntax
 150
 151   CREATE [ UNIQUE ] INDEX index_name ON table
 152       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 153       [ WHERE predicate ]
 154   CREATE [ UNIQUE ] INDEX index_name ON table
 155       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 156       [ WHERE predicate ]
 157
 158 =cut
 159
 160 # -------------------------------------------------------------------
 161 sub produce {
 162     my $translator       = shift;
 163     local $DEBUG         = $translator->debug;
 164     local $WARN          = $translator->show_warnings;
 165     my $no_comments      = $translator->no_comments;
 166     my $add_drop_table   = $translator->add_drop_table;
 167     my $schema           = $translator->schema;
 168     my $pargs            = $translator->producer_args;
 169     my $postgres_version = parse_dbms_version(
 170         $pargs->{postgres_version}, 'perl'
 171     );
 172
 173     my $qt = $translator->quote_table_names ? q{"} : q{};
 174     my $qf = $translator->quote_field_names ? q{"} : q{};
 175
 176     my @output;
 177     push @output, header_comment unless ($no_comments);
 178
 179     my (@table_defs, @fks);
 180     my %type_defs;
 181     for my $table ( $schema->get_tables ) {
 182
 183         my ($table_def, $fks) = create_table($table, {
 184             quote_table_names => $qt,
 185             quote_field_names => $qf,
 186             no_comments       => $no_comments,
 187             postgres_version  => $postgres_version,
 188             add_drop_table    => $add_drop_table,
 189             type_defs         => \%type_defs,
 190         });
 191
 192         push @table_defs, $table_def;
 193         push @fks, @$fks;
 194     }
 195
 196     for my $view ( $schema->get_views ) {
 197       push @table_defs, create_view($view, {
 198         add_drop_view     => $add_drop_table,
 199         quote_table_names => $qt,
 200         quote_field_names => $qf,
 201         no_comments       => $no_comments,
 202       });
 203     }
 204
 205     push @output, map { "$_;\n\n" } values %type_defs;
 206     push @output, map { "$_;\n\n" } @table_defs;
 207     if ( @fks ) {
 208         push @output, "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
 209         push @output, map { "$_;\n\n" } @fks;
 210     }
 211
 212     if ( $WARN ) {
 213         if ( %truncated ) {
 214             warn "Truncated " . keys( %truncated ) . " names:\n";
 215             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 216         }
 217
 218         if ( %unreserve ) {
 219             warn "Encounted " . keys( %unreserve ) .
 220                 " unsafe names in schema (reserved or invalid):\n";
 221             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 222         }
 223     }
 224
 225     return wantarray
 226         ? @output
 227         : join ('', @output);
 228 }
 229
 230 # -------------------------------------------------------------------
 231 sub mk_name {
 232     my $basename      = shift || '';
 233     my $type          = shift || '';
 234     my $scope         = shift || '';
 235     my $critical      = shift || '';
 236     my $basename_orig = $basename;
 237 #    my $max_id_length = 62;
 238     my $max_name      = $type
 239                         ? $max_id_length - (length($type) + 1)
 240                         : $max_id_length;
 241     $basename         = substr( $basename, 0, $max_name )
 242                         if length( $basename ) > $max_name;
 243     my $name          = $type ? "${type}_$basename" : $basename;
 244
 245     if ( $basename ne $basename_orig and $critical ) {
 246         my $show_type = $type ? "+'$type'" : "";
 247         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 248             "character limit to make '$name'\n" if $WARN;
 249         $truncated{ $basename_orig } = $name;
 250     }
 251
 252     $scope ||= \%global_names;
 253     if ( my $prev = $scope->{ $name } ) {
 254         my $name_orig = $name;
 255         $name        .= sprintf( "%02d", ++$prev );
 256         substr($name, $max_id_length - 3) = "00"
 257             if length( $name ) > $max_id_length;
 258
 259         warn "The name '$name_orig' has been changed to ",
 260              "'$name' to make it unique.\n" if $WARN;
 261
 262         $scope->{ $name_orig }++;
 263     }
 264
 265     $scope->{ $name }++;
 266     return $name;
 267 }
 268
 269 # -------------------------------------------------------------------
 270 sub unreserve {
 271     my $name            = shift || '';
 272     my $schema_obj_name = shift || '';
 273
 274     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 275
 276     # also trap fields that don't begin with a letter
 277     return $name if (!$reserved{ uc $name }) && $name =~ /^[a-z]/i;
 278
 279     if ( $schema_obj_name ) {
 280         ++$unreserve{"$schema_obj_name.$name"};
 281     }
 282     else {
 283         ++$unreserve{"$name (table name)"};
 284     }
 285
 286     my $unreserve = sprintf '%s_', $name;
 287     return $unreserve.$suffix;
 288 }
 289
 290 # -------------------------------------------------------------------
 291 sub next_unused_name {
 292     my $orig_name = shift or return;
 293     my $name      = $orig_name;
 294
 295     my $suffix_gen = sub {
 296         my $suffix = 0;
 297         return ++$suffix ? '' : $suffix;
 298     };
 299
 300     for (;;) {
 301         $name = $orig_name . $suffix_gen->();
 302         last if $used_names{ $name }++;
 303     }
 304
 305     return $name;
 306 }
 307
 308 sub is_geometry
 309 {
 310         my $field = shift;
 311         return 1 if $field->data_type eq 'geometry';
 312 }
 313
 314 sub is_geography
 315 {
 316     my $field = shift;
 317     return 1 if $field->data_type eq 'geography';
 318 }
 319
 320 sub create_table
 321 {
 322     my ($table, $options) = @_;
 323
 324     my $qt = $options->{quote_table_names} || '';
 325     my $qf = $options->{quote_field_names} || '';
 326     my $no_comments = $options->{no_comments} || 0;
 327     my $add_drop_table = $options->{add_drop_table} || 0;
 328     my $postgres_version = $options->{postgres_version} || 0;
 329     my $type_defs = $options->{type_defs} || {};
 330
 331     my $table_name = $table->name or next;
 332     my ( $fql_tbl_name ) = ( $table_name =~ s/\W(.*)$// ) ? $1 : q{};
 333     my $table_name_ur = $qt ? $table_name
 334         : $fql_tbl_name ? join('.', $table_name, unreserve($fql_tbl_name))
 335         : unreserve($table_name);
 336     $table->name($table_name_ur);
 337
 338 # print STDERR "$table_name table_name\n";
 339     my ( @comments, @field_defs, @sequence_defs, @constraint_defs, @fks );
 340
 341     push @comments, "--\n-- Table: $table_name_ur\n--\n" unless $no_comments;
 342
 343     if ( $table->comments and !$no_comments ){
 344         my $c = "-- Comments: \n-- ";
 345         $c .= join "\n-- ",  $table->comments;
 346         $c .= "\n--\n";
 347         push @comments, $c;
 348     }
 349
 350     #
 351     # Fields
 352     #
 353     my %field_name_scope;
 354     for my $field ( $table->get_fields ) {
 355         push @field_defs, create_field($field, { quote_table_names => $qt,
 356                                                  quote_field_names => $qf,
 357                                                  table_name => $table_name_ur,
 358                                                  postgres_version => $postgres_version,
 359                                                  type_defs => $type_defs,
 360                                                  constraint_defs => \@constraint_defs,});
 361     }
 362
 363     #
 364     # Index Declarations
 365     #
 366     my @index_defs = ();
 367  #   my $idx_name_default;
 368     for my $index ( $table->get_indices ) {
 369         my ($idef, $constraints) = create_index($index,
 370                                               {
 371                                                   quote_field_names => $qf,
 372                                                   quote_table_names => $qt,
 373                                                   table_name => $table_name,
 374                                               });
 375         $idef and push @index_defs, $idef;
 376         push @constraint_defs, @$constraints;
 377     }
 378
 379     #
 380     # Table constraints
 381     #
 382     my $c_name_default;
 383     for my $c ( $table->get_constraints ) {
 384         my ($cdefs, $fks) = create_constraint($c,
 385                                               {
 386                                                   quote_field_names => $qf,
 387                                                   quote_table_names => $qt,
 388                                                   table_name => $table_name,
 389                                               });
 390         push @constraint_defs, @$cdefs;
 391         push @fks, @$fks;
 392     }
 393
 394
 395     my $temporary = "";
 396
 397     if(exists $table->{extra}{temporary}) {
 398         $temporary = $table->{extra}{temporary} ? "TEMPORARY " : "";
 399     }
 400
 401     my $create_statement;
 402     $create_statement = join("\n", @comments);
 403     if ($add_drop_table) {
 404         if ($postgres_version >= 8.002) {
 405             $create_statement .= qq[DROP TABLE IF EXISTS $qt$table_name_ur$qt CASCADE;\n];
 406         } else {
 407             $create_statement .= qq[DROP TABLE $qt$table_name_ur$qt CASCADE;\n];
 408         }
 409     }
 410     $create_statement .= qq[CREATE ${temporary}TABLE $qt$table_name_ur$qt (\n].
 411                             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 412                             "\n)"
 413                             ;
 414     $create_statement .= @index_defs ? ';' : q{};
 415     $create_statement .= ( $create_statement =~ /;$/ ? "\n" : q{} )
 416         . join(";\n", @index_defs);
 417
 418         #
 419         # Geometry
 420         #
 421         if(grep { is_geometry($_) } $table->get_fields){
 422         $create_statement .= ";";
 423         my @geometry_columns;
 424         foreach my $col ($table->get_fields) { push(@geometry_columns,$col) if is_geometry($col); }
 425                 $create_statement .= "\n".join("\n", map{ drop_geometry_column($_) } @geometry_columns) if $options->{add_drop_table};
 426                 $create_statement .= "\n".join("\n", map{ add_geometry_column($_) } @geometry_columns);
 427         }
 428
 429     return $create_statement, \@fks;
 430 }
 431
 432 sub create_view {
 433     my ($view, $options) = @_;
 434     my $qt = $options->{quote_table_names} || '';
 435     my $qf = $options->{quote_field_names} || '';
 436     my $add_drop_view = $options->{add_drop_view};
 437
 438     my $view_name = $view->name;
 439     debug("PKG: Looking at view '${view_name}'\n");
 440
 441     my $create = '';
 442     $create .= "--\n-- View: ${qt}${view_name}${qt}\n--\n"
 443         unless $options->{no_comments};
 444     $create .= "DROP VIEW ${qt}${view_name}${qt};\n" if $add_drop_view;
 445     $create .= 'CREATE';
 446
 447     my $extra = $view->extra;
 448     $create .= " TEMPORARY" if exists($extra->{temporary}) && $extra->{temporary};
 449     $create .= " VIEW ${qt}${view_name}${qt}";
 450
 451     if ( my @fields = $view->fields ) {
 452         my $field_list = join ', ', map { "${qf}${_}${qf}" } @fields;
 453         $create .= " ( ${field_list} )";
 454     }
 455
 456     if ( my $sql = $view->sql ) {
 457         $create .= " AS\n    ${sql}\n";
 458     }
 459
 460     if ( $extra->{check_option} ) {
 461         $create .= ' WITH ' . uc $extra->{check_option} . ' CHECK OPTION';
 462     }
 463
 464     return $create;
 465 }
 466
 467 {
 468
 469     my %field_name_scope;
 470
 471     sub create_field
 472     {
 473         my ($field, $options) = @_;
 474
 475         my $qt = $options->{quote_table_names} || '';
 476         my $qf = $options->{quote_field_names} || '';
 477         my $table_name = $field->table->name;
 478         my $constraint_defs = $options->{constraint_defs} || [];
 479         my $postgres_version = $options->{postgres_version} || 0;
 480         my $type_defs = $options->{type_defs} || {};
 481
 482         $field_name_scope{$table_name} ||= {};
 483         my $field_name    = $field->name;
 484         my $field_name_ur = $qf ? $field_name : unreserve($field_name, $table_name );
 485         $field->name($field_name_ur);
 486         my $field_comments = $field->comments
 487             ? "-- " . $field->comments . "\n  "
 488             : '';
 489
 490         my $field_def     = $field_comments.qq[$qf$field_name_ur$qf];
 491
 492         #
 493         # Datatype
 494         #
 495         my @size      = $field->size;
 496         my $data_type = lc $field->data_type;
 497         my %extra     = $field->extra;
 498         my $list      = $extra{'list'} || [];
 499         # todo deal with embedded quotes
 500         my $commalist = join( ', ', map { qq['$_'] } @$list );
 501
 502         if ($postgres_version >= 8.003 && $field->data_type eq 'enum') {
 503             my $type_name = $extra{'custom_type_name'} || $field->table->name . '_' . $field->name . '_type';
 504             $field_def .= ' '. $type_name;
 505             my $new_type_def = "DROP TYPE IF EXISTS $type_name CASCADE;\n" .
 506                                "CREATE TYPE $type_name AS ENUM ($commalist)";
 507             if (! exists $type_defs->{$type_name} ) {
 508                 $type_defs->{$type_name} = $new_type_def;
 509             } elsif ( $type_defs->{$type_name} ne $new_type_def ) {
 510                 die "Attempted to redefine type name '$type_name' as a different type.\n";
 511             }
 512         } else {
 513             $field_def .= ' '. convert_datatype($field);
 514         }
 515
 516         #
 517         # Default value
 518         #
 519         SQL::Translator::Producer->_apply_default_value(
 520           $field,
 521           \$field_def,
 522           [
 523             'NULL'              => \'NULL',
 524             'now()'             => 'now()',
 525             'CURRENT_TIMESTAMP' => 'CURRENT_TIMESTAMP',
 526           ],
 527         );
 528
 529         #
 530         # Not null constraint
 531         #
 532         $field_def .= ' NOT NULL' unless $field->is_nullable;
 533
 534                 #
 535                 # Geometry constraints
 536                 #
 537                 if(is_geometry($field)){
 538                         foreach ( create_geometry_constraints($field) ) {
 539                                 my ($cdefs, $fks) = create_constraint($_,
 540                                                                                                           {
 541                                                                                                                   quote_field_names => $qf,
 542                                                                                                                   quote_table_names => $qt,
 543                                                                                                                   table_name => $table_name,
 544                                                                                                           });
 545                                 push @$constraint_defs, @$cdefs;
 546                                 push @$fks, @$fks;
 547                         }
 548         }
 549
 550         return $field_def;
 551     }
 552 }
 553
 554 sub create_geometry_constraints{
 555         my $field = shift;
 556
 557         my @constraints;
 558         push @constraints, SQL::Translator::Schema::Constraint->new(
 559                                                         name       => "enforce_dims_".$field->name,
 560                                                         expression => "(st_ndims($field) = ".$field->{extra}{dimensions}.")",
 561                                                         table      => $field->table,
 562                                                         type       => CHECK_C,
 563                                                 );
 564
 565         push @constraints, SQL::Translator::Schema::Constraint->new(
 566                                                         name       => "enforce_srid_".$field->name,
 567                                                         expression => "(st_srid($field) = ".$field->{extra}{srid}.")",
 568                                                         table      => $field->table,
 569                                                         type       => CHECK_C,
 570                                                 );
 571         push @constraints, SQL::Translator::Schema::Constraint->new(
 572                                                         name       => "enforce_geotype_".$field->name,
 573                                                         expression => "(geometrytype($field) = '".$field->{extra}{geometry_type}."'::text OR $field IS NULL)",
 574                                                         table      => $field->table,
 575                                                         type       => CHECK_C,
 576                                                 );
 577
 578         return @constraints;
 579 }
 580
 581 sub create_index
 582 {
 583     my ($index, $options) = @_;
 584
 585     my $qt = $options->{quote_table_names} ||'';
 586     my $qf = $options->{quote_field_names} ||'';
 587     my $table_name = $index->table->name;
 588 #        my $table_name_ur = $qt ? unreserve($table_name) : $table_name;
 589
 590     my ($index_def, @constraint_defs);
 591
 592     my $name = next_unused_name(
 593         $index->name
 594         || join('_', $table_name, 'idx', ++$index_name{ $table_name })
 595     );
 596
 597     my $type = $index->type || NORMAL;
 598     my @fields     =
 599         map { $_ =~ s/\(.+\)//; $_ }
 600     map { $qt ? $_ : unreserve($_, $table_name ) }
 601     $index->fields;
 602     next unless @fields;
 603
 604     my $def_start = qq[CONSTRAINT "$name" ];
 605     if ( $type eq PRIMARY_KEY ) {
 606         push @constraint_defs, "${def_start}PRIMARY KEY ".
 607             '(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
 608     }
 609     elsif ( $type eq UNIQUE ) {
 610         push @constraint_defs, "${def_start}UNIQUE " .
 611             '(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
 612     }
 613     elsif ( $type eq NORMAL ) {
 614         $index_def =
 615             "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
 616             join( ', ', map { qq[$qf$_$qf] } @fields ).
 617             ')'
 618             ;
 619     }
 620     else {
 621         warn "Unknown index type ($type) on table $table_name.\n"
 622             if $WARN;
 623     }
 624
 625     return $index_def, \@constraint_defs;
 626 }
 627
 628 sub create_constraint
 629 {
 630     my ($c, $options) = @_;
 631
 632     my $qf = $options->{quote_field_names} ||'';
 633     my $qt = $options->{quote_table_names} ||'';
 634     my $table_name = $c->table->name;
 635     my (@constraint_defs, @fks);
 636
 637     my $name = $c->name || '';
 638     if ( $name ) {
 639         $name = next_unused_name($name);
 640     }
 641
 642     my @fields     =
 643         map { $_ =~ s/\(.+\)//; $_ }
 644     map { $qt ? $_ : unreserve( $_, $table_name )}
 645     $c->fields;
 646
 647     my @rfields     =
 648         map { $_ =~ s/\(.+\)//; $_ }
 649     map { $qt ? $_ : unreserve( $_, $table_name )}
 650     $c->reference_fields;
 651
 652     next if !@fields && $c->type ne CHECK_C;
 653     my $def_start = $name ? qq[CONSTRAINT "$name" ] : '';
 654     if ( $c->type eq PRIMARY_KEY ) {
 655         push @constraint_defs, "${def_start}PRIMARY KEY ".
 656             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 657     }
 658     elsif ( $c->type eq UNIQUE ) {
 659         $name = next_unused_name($name);
 660         push @constraint_defs, "${def_start}UNIQUE " .
 661             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 662     }
 663     elsif ( $c->type eq CHECK_C ) {
 664         my $expression = $c->expression;
 665         push @constraint_defs, "${def_start}CHECK ($expression)";
 666     }
 667     elsif ( $c->type eq FOREIGN_KEY ) {
 668         my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" .
 669             join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
 670             "\n  REFERENCES " . $qt . $c->reference_table . $qt;
 671
 672         if ( @rfields ) {
 673             $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
 674         }
 675
 676         if ( $c->match_type ) {
 677             $def .= ' MATCH ' .
 678                 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 679         }
 680
 681         if ( $c->on_delete ) {
 682             $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 683         }
 684
 685         if ( $c->on_update ) {
 686             $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 687         }
 688
 689         if ( $c->deferrable ) {
 690             $def .= ' DEFERRABLE';
 691         }
 692
 693         push @fks, "$def";
 694     }
 695
 696     return \@constraint_defs, \@fks;
 697 }
 698
 699 sub convert_datatype
 700 {
 701     my ($field) = @_;
 702
 703     my @size      = $field->size;
 704     my $data_type = lc $field->data_type;
 705
 706     if ( $data_type eq 'enum' ) {
 707 #        my $len = 0;
 708 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 709 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 710 #        push @$constraint_defs,
 711 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 712 #           qq[IN ($commalist))];
 713         $data_type = 'character varying';
 714     }
 715     elsif ( $data_type eq 'set' ) {
 716         $data_type = 'character varying';
 717     }
 718     elsif ( $field->is_auto_increment ) {
 719         if ( defined $size[0] && $size[0] > 11 ) {
 720             $data_type = 'bigserial';
 721         }
 722         else {
 723             $data_type = 'serial';
 724         }
 725         undef @size;
 726     }
 727     else {
 728         $data_type  = defined $translate{ $data_type } ?
 729             $translate{ $data_type } :
 730             $data_type;
 731     }
 732
 733     if ( $data_type =~ /^time/i || $data_type =~ /^interval/i ) {
 734         if ( defined $size[0] && $size[0] > 6 ) {
 735             $size[0] = 6;
 736         }
 737     }
 738
 739     if ( $data_type eq 'integer' ) {
 740         if ( defined $size[0] && $size[0] > 0) {
 741             if ( $size[0] > 10 ) {
 742                 $data_type = 'bigint';
 743             }
 744             elsif ( $size[0] < 5 ) {
 745                 $data_type = 'smallint';
 746             }
 747             else {
 748                 $data_type = 'integer';
 749             }
 750         }
 751         else {
 752             $data_type = 'integer';
 753         }
 754     }
 755
 756     my $type_with_size = join('|',
 757         'bit', 'varbit', 'character', 'bit varying', 'character varying',
 758         'time', 'timestamp', 'interval', 'numeric'
 759     );
 760
 761     if ( $data_type !~ /$type_with_size/ ) {
 762         @size = ();
 763     }
 764
 765     if (defined $size[0] && $size[0] > 0 && $data_type =~ /^time/i ) {
 766         $data_type =~ s/^(time.*?)( with.*)?$/$1($size[0])/;
 767         $data_type .= $2 if(defined $2);
 768     } elsif ( defined $size[0] && $size[0] > 0 ) {
 769         $data_type .= '(' . join( ',', @size ) . ')';
 770     }
 771
 772     #
 773     # Geography
 774     #
 775     if($data_type eq 'geography'){
 776         $data_type .= '('.$field->{extra}{geography_type}.','. $field->{extra}{srid} .')'
 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