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