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
 300     my $temporary = "";
 301
 302     if(exists $table->{extra}{temporary}) {
 303         $temporary = $table->{extra}{temporary} ? "TEMPORARY " : "";
 304     }
 305
 306     my $create_statement;
 307     $create_statement = join("\n", @comments);
 308     if ($add_drop_table) {
 309         if ($postgres_version >= 8.2) {
 310             $create_statement .= qq[DROP TABLE IF EXISTS $qt$table_name_ur$qt CASCADE;\n];
 311             $create_statement .= join (";\n", @type_drops) . ";\n"
 312                 if $postgres_version >= 8.3 && scalar @type_drops;
 313         } else {
 314             $create_statement .= qq[DROP TABLE $qt$table_name_ur$qt CASCADE;\n];
 315         }
 316     }
 317     $create_statement .= join(";\n", @type_defs) . ";\n"
 318         if $postgres_version >= 8.3 && scalar @type_defs;
 319     $create_statement .= qq[CREATE ${temporary}TABLE $qt$table_name_ur$qt (\n].
 320                             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 321                             "\n)"
 322                             ;
 323     $create_statement .= @index_defs ? ';' : q{};
 324     $create_statement .= ( $create_statement =~ /;$/ ? "\n" : q{} )
 325         . join(";\n", @index_defs);
 326
 327     return $create_statement, \@fks;
 328 }
 329
 330 method create_view(View $view, $options?) {
 331     my $qt = $options->{quote_table_names} || '';
 332     my $qf = $options->{quote_field_names} || '';
 333     my $add_drop_view = $options->{add_drop_view};
 334
 335     my $view_name = $view->name;
 336 #    debug("PKG: Looking at view '${view_name}'\n");
 337
 338     my $create = '';
 339     $create .= "--\n-- View: ${qt}${view_name}${qt}\n--\n"
 340         unless $options->{no_comments};
 341     $create .= "DROP VIEW ${qt}${view_name}${qt};\n" if $add_drop_view;
 342     $create .= 'CREATE';
 343
 344     my $extra = $view->extra;
 345     $create .= " TEMPORARY" if exists($extra->{temporary}) && $extra->{temporary};
 346     $create .= " VIEW ${qt}${view_name}${qt}";
 347
 348     if ( my @fields = $view->fields ) {
 349         my $field_list = join ', ', map { "${qf}${_}${qf}" } @fields;
 350         $create .= " ( ${field_list} )";
 351     }
 352
 353     if ( my $sql = $view->sql ) {
 354         $create .= " AS\n    ${sql}\n";
 355     }
 356
 357     if ( $extra->{check_option} ) {
 358         $create .= ' WITH ' . uc $extra->{check_option} . ' CHECK OPTION';
 359     }
 360
 361     return $create;
 362 }
 363
 364 {
 365
 366     my %field_name_scope;
 367
 368     method create_field(Column $field, $options?) {
 369         my $qt = $options->{quote_table_names} || '';
 370         my $qf = $options->{quote_field_names} || '';
 371         my $table_name = $field->table->name;
 372         my $constraint_defs = $options->{constraint_defs} || [];
 373         my $postgres_version = $options->{postgres_version} || 0;
 374         my $type_defs = $options->{type_defs} || [];
 375         my $type_drops = $options->{type_drops} || [];
 376
 377         $field_name_scope{$table_name} ||= {};
 378         my $field_name    = $field->name;
 379         my $field_name_ur = $qf ? $field_name : $self->unreserve($field_name, $table_name );
 380         $field->name($field_name_ur);
 381         my $field_comments = $field->comments
 382             ? "-- " . $field->comments . "\n  "
 383             : '';
 384
 385         my $field_def     = $field_comments.qq[$qf$field_name_ur$qf];
 386
 387         #
 388         # Datatype
 389         #
 390         my @size      = $field->size;
 391         my $data_type = lc $field->data_type;
 392         my %extra     = $field->extra;
 393         my $list      = $extra{'list'} || [];
 394         # todo deal with embedded quotes
 395         my $commalist = join( ', ', map { qq['$_'] } @$list );
 396
 397         if ($postgres_version >= 8.3 && $field->data_type eq 'enum') {
 398             my $type_name = $field->table->name . '_' . $field->name . '_type';
 399             $field_def .= ' '. $type_name;
 400             push @$type_defs, "CREATE TYPE $type_name AS ENUM ($commalist)";
 401             push @$type_drops, "DROP TYPE IF EXISTS $type_name";
 402         } else {
 403             $field_def .= ' '. $self->convert_datatype($field);
 404         }
 405
 406         #
 407         # Default value
 408         #
 409         my $default = $field->default_value;
 410 =cut
 411         if ( defined $default ) {
 412             SQL::Translator::Producer->_apply_default_value(
 413               \$field_def,
 414               $default,
 415               [
 416                 'NULL'              => \'NULL',
 417                 'now()'             => 'now()',
 418                 'CURRENT_TIMESTAMP' => 'CURRENT_TIMESTAMP',
 419               ],
 420             );
 421         }
 422 =cut
 423
 424         #
 425         # Not null constraint
 426         #
 427         $field_def .= ' NOT NULL' unless $field->is_nullable;
 428
 429         return $field_def;
 430     }
 431 }
 432
 433 method create_index(Index $index, $options?) {
 434     my $qt = $options->{quote_table_names} ||'';
 435     my $qf = $options->{quote_field_names} ||'';
 436     my $table_name = $index->table->name;
 437 #        my $table_name_ur = $qt ? $self->unreserve($table_name) : $table_name;
 438
 439     my ($index_def, @constraint_defs);
 440
 441     my $name = $self->next_unused_name(
 442         $index->name
 443         || join('_', $table_name, 'idx', ++$index_name{ $table_name })
 444     );
 445
 446     my $type = $index->type || NORMAL;
 447     my @fields     =
 448         map { $_ =~ s/\(.+\)//; $_ }
 449     map { $qt ? $_ : $self->unreserve($_, $table_name ) }
 450     $index->fields;
 451     return ('', []) unless @fields;
 452
 453     my $def_start = qq[CONSTRAINT "$name" ];
 454     if ( $type eq PRIMARY_KEY ) {
 455         push @constraint_defs, "${def_start}PRIMARY KEY ".
 456             '(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
 457     }
 458     elsif ( $type eq UNIQUE ) {
 459         push @constraint_defs, "${def_start}UNIQUE " .
 460             '(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
 461     }
 462     elsif ( $type eq NORMAL ) {
 463         $index_def =
 464             "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
 465             join( ', ', map { qq[$qf$_$qf] } @fields ).
 466             ')'
 467             ;
 468     }
 469     else {
 470 #        warn "Unknown index type ($type) on table $table_name.\n"
 471 #            if $WARN;
 472     }
 473
 474     return $index_def, \@constraint_defs;
 475 }
 476
 477 method create_constraint(Constraint $c, $options?) {
 478     my $qf = $options->{quote_field_names} ||'';
 479     my $qt = $options->{quote_table_names} ||'';
 480     my $table_name = $c->table->name;
 481     my (@constraint_defs, @fks);
 482
 483     my $name = $c->name || '';
 484     if ( $name ) {
 485         $name = $self->next_unused_name($name);
 486     }
 487
 488     my @fields     =
 489         map { $_ =~ s/\(.+\)//; $_ }
 490     map { $qt ? $_ : $self->unreserve( $_, $table_name )}
 491     $c->fields;
 492
 493     my @rfields     =
 494         map { $_ =~ s/\(.+\)//; $_ }
 495     map { $qt ? $_ : $self->unreserve( $_, $table_name )}
 496     $c->reference_fields;
 497
 498     return ([], []) if !@fields && $c->type ne CHECK_C;
 499     my $def_start = $name ? qq[CONSTRAINT "$name" ] : '';
 500     if ( $c->type eq PRIMARY_KEY ) {
 501         push @constraint_defs, "${def_start}PRIMARY KEY ".
 502             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 503     }
 504     elsif ( $c->type eq UNIQUE ) {
 505         $name = $self->next_unused_name($name);
 506         push @constraint_defs, "${def_start}UNIQUE " .
 507             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 508     }
 509     elsif ( $c->type eq CHECK_C ) {
 510         my $expression = $c->expression;
 511         push @constraint_defs, "${def_start}CHECK ($expression)";
 512     }
 513     elsif ( $c->type eq FOREIGN_KEY ) {
 514         my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" .
 515             join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
 516             "\n  REFERENCES " . $qt . $c->reference_table . $qt;
 517
 518         if ( @rfields ) {
 519             $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
 520         }
 521
 522         if ( $c->match_type ) {
 523             $def .= ' MATCH ' .
 524                 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 525         }
 526
 527         if ( $c->on_delete ) {
 528             $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 529         }
 530
 531         if ( $c->on_update ) {
 532             $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 533         }
 534
 535         if ( $c->deferrable ) {
 536             $def .= ' DEFERRABLE';
 537         }
 538
 539         push @fks, "$def";
 540     }
 541
 542     return \@constraint_defs, \@fks;
 543 }
 544
 545 method convert_datatype(Column $field) {
 546     my @size      = $field->size;
 547     my $data_type = lc $field->data_type;
 548
 549     if ( $data_type eq 'enum' ) {
 550 #        my $len = 0;
 551 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 552 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 553 #        push @$constraint_defs,
 554 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 555 #           qq[IN ($commalist))];
 556         $data_type = 'character varying';
 557     }
 558     elsif ( $data_type eq 'set' ) {
 559         $data_type = 'character varying';
 560     }
 561     elsif ( $field->is_auto_increment ) {
 562         if ( defined $size[0] && $size[0] > 11 ) {
 563             $data_type = 'bigserial';
 564         }
 565         else {
 566             $data_type = 'serial';
 567         }
 568         undef @size;
 569     }
 570     else {
 571         $data_type  = defined $translate{ $data_type } ?
 572             $translate{ $data_type } :
 573             $data_type;
 574     }
 575
 576     if ( $data_type =~ /^time/i || $data_type =~ /^interval/i ) {
 577         if ( defined $size[0] && $size[0] > 6 ) {
 578             $size[0] = 6;
 579         }
 580     }
 581
 582     if ( $data_type eq 'integer' ) {
 583         if ( defined $size[0] && $size[0] > 0) {
 584             if ( $size[0] > 10 ) {
 585                 $data_type = 'bigint';
 586             }
 587             elsif ( $size[0] < 5 ) {
 588                 $data_type = 'smallint';
 589             }
 590             else {
 591                 $data_type = 'integer';
 592             }
 593         }
 594         else {
 595             $data_type = 'integer';
 596         }
 597     }
 598
 599     my $type_with_size = join('|',
 600         'bit', 'varbit', 'character', 'bit varying', 'character varying',
 601         'time', 'timestamp', 'interval'
 602     );
 603
 604     if ( $data_type !~ /$type_with_size/ ) {
 605         @size = ();
 606     }
 607
 608     if (defined $size[0] && $size[0] > 0 && $data_type =~ /^time/i ) {
 609         $data_type =~ s/^(time.*?)( with.*)?$/$1($size[0])/;
 610         $data_type .= $2 if(defined $2);
 611     } elsif ( defined $size[0] && $size[0] > 0 ) {
 612         $data_type .= '(' . join( ',', @size ) . ')';
 613     }
 614
 615     return $data_type;
 616 }
 617
 618
 619 method alter_field(Column $from_field, Column $to_field) {
 620     die "Can't alter field in another table"
 621         if($from_field->table->name ne $to_field->table->name);
 622
 623     my @out;
 624     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL',
 625                        $to_field->table->name,
 626                        $to_field->name) if(!$to_field->is_nullable and
 627                                            $from_field->is_nullable);
 628
 629     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP NOT NULL',
 630                       $to_field->table->name,
 631                       $to_field->name)
 632        if ( !$from_field->is_nullable and $to_field->is_nullable );
 633
 634
 635     my $from_dt = $self->convert_datatype($from_field);
 636     my $to_dt   = $self->convert_datatype($to_field);
 637     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s',
 638                        $to_field->table->name,
 639                        $to_field->name,
 640                        $to_dt) if($to_dt ne $from_dt);
 641
 642     push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s',
 643                        $to_field->table->name,
 644                        $from_field->name,
 645                        $to_field->name) if($from_field->name ne $to_field->name);
 646
 647     my $old_default = $from_field->default_value;
 648     my $new_default = $to_field->default_value;
 649     my $default_value = $to_field->default_value;
 650
 651     # fixes bug where output like this was created:
 652     # ALTER TABLE users ALTER COLUMN column SET DEFAULT ThisIsUnescaped;
 653     if(ref $default_value eq "SCALAR" ) {
 654         $default_value = $$default_value;
 655     } elsif( defined $default_value && $to_dt =~ /^(character|text)/xsmi ) {
 656         $default_value =~ s/'/''/xsmg;
 657         $default_value = q(') . $default_value . q(');
 658     }
 659
 660     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
 661                        $to_field->table->name,
 662                        $to_field->name,
 663                        $default_value)
 664         if ( defined $new_default &&
 665              (!defined $old_default || $old_default ne $new_default) );
 666
 667      # fixes bug where removing the DEFAULT statement of a column
 668      # would result in no change
 669
 670      push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
 671                        $to_field->table->name,
 672                        $to_field->name)
 673         if ( !defined $new_default && defined $old_default );
 674
 675
 676     return wantarray ? @out : join("\n", @out);
 677 }
 678
 679 method rename_field(@args) { $self->alter_field(@args) }
 680
 681 method add_field(Column $new_field) {
 682     my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
 683                       $new_field->table->name,
 684                       $self->create_field($new_field));
 685     return $out;
 686
 687 }
 688
 689 method drop_field(Column $old_field) {
 690     my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
 691                       $old_field->table->name,
 692                       $old_field->name);
 693
 694     return $out;
 695 }
 696
 697 method alter_table(Column $to_table, $options?) {
 698     my $qt = $options->{quote_table_names} || '';
 699     my $out = sprintf('ALTER TABLE %s %s',
 700                       $qt . $to_table->name . $qt,
 701                       $options->{alter_table_action});
 702     return $out;
 703 }
 704
 705 method rename_table(Table $old_table, Table $new_table, $options?) {
 706     my $qt = $options->{quote_table_names} || '';
 707     $options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
 708     return alter_table($old_table, $options);
 709 }
 710
 711 method alter_create_index(Index $index, $options?) {
 712     my $qt = $options->{quote_table_names} || '';
 713     my $qf = $options->{quote_field_names} || '';
 714     my ($idef, $constraints) = create_index($index, {
 715         quote_field_names => $qf,
 716         quote_table_names => $qt,
 717         table_name => $index->table->name,
 718     });
 719     return $index->type eq NORMAL ? $idef
 720         : sprintf('ALTER TABLE %s ADD %s',
 721               $qt . $index->table->name . $qt,
 722               join(q{}, @$constraints)
 723           );
 724 }
 725
 726 method alter_drop_index(Index $index, $options?) {
 727     my $index_name = $index->name;
 728     return "DROP INDEX $index_name";
 729 }
 730
 731 method alter_drop_constraint(Constraint $c, $options?) {
 732     my $qt = $options->{quote_table_names} || '';
 733     my $qc = $options->{quote_field_names} || '';
 734     my $out = sprintf('ALTER TABLE %s DROP CONSTRAINT %s',
 735                       $qt . $c->table->name . $qt,
 736                       $qc . $c->name . $qc );
 737     return $out;
 738 }
 739
 740 method alter_create_constraint(Index $index, $options?) {
 741     my $qt = $options->{quote_table_names} || '';
 742     my ($defs, $fks) = create_constraint(@_);
 743
 744     # return if there are no constraint definitions so we don't run
 745     # into output like this:
 746     # ALTER TABLE users ADD ;
 747
 748     return unless(@{$defs} || @{$fks});
 749     return $index->type eq FOREIGN_KEY ? join(q{}, @{$fks})
 750         : join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
 751               'ADD', join(q{}, @{$defs}, @{$fks})
 752           );
 753 }
 754
 755 method drop_table(Str $table, $options?) {
 756     my $qt = $options->{quote_table_names} || '';
 757     return "DROP TABLE $qt$table$qt CASCADE";
 758 }
 759
 760     method header_comment($producer?, $comment_char?) {
 761         $producer ||= caller;
 762         my $now = scalar localtime;
 763         my $DEFAULT_COMMENT = '-- ';
 764
 765         $comment_char = $DEFAULT_COMMENT
 766             unless defined $comment_char;
 767
 768         my $header_comment =<<"HEADER_COMMENT";
 769             ${comment_char}
 770             ${comment_char}Created by $producer
 771             ${comment_char}Created on $now
 772             ${comment_char}
 773 HEADER_COMMENT
 774
 775         # Any additional stuff passed in
 776         for my $additional_comment (@_) {
 777             $header_comment .= "${comment_char}${additional_comment}\n";
 778         }
 779
 780         return $header_comment;
 781     }
 782 }