lib/SQL/Translator/Producer/SQL/PostgreSQL.pm

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