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 =cut
 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 =cut
 422
 423         #
 424         # Not null constraint
 425         #
 426         $field_def .= ' NOT NULL' unless $field->is_nullable;
 427
 428         return $field_def;
 429     }
 430 }
 431
 432 method create_index(Index $index, $options?) {
 433     my $qt = $options->{quote_table_names} ||'';
 434     my $qf = $options->{quote_field_names} ||'';
 435     my $table_name = $index->table->name;
 436 #        my $table_name_ur = $qt ? $self->unreserve($table_name) : $table_name;
 437
 438     my ($index_def, @constraint_defs);
 439
 440     my $name = $self->next_unused_name(
 441         $index->name
 442         || join('_', $table_name, 'idx', ++$index_name{ $table_name })
 443     );
 444
 445     my $type = $index->type || NORMAL;
 446     my @fields     =
 447         map { $_ =~ s/\(.+\)//; $_ }
 448     map { $qt ? $_ : $self->unreserve($_, $table_name ) }
 449     $index->fields;
 450     return ('', []) unless @fields;
 451
 452     my $def_start = qq[CONSTRAINT "$name" ];
 453     if ( $type eq PRIMARY_KEY ) {
 454         push @constraint_defs, "${def_start}PRIMARY KEY ".
 455             '(' .$qf . join( $qf. ', '.$qf, @fields ) . $qf . ')';
 456     }
 457     elsif ( $type eq UNIQUE ) {
 458         push @constraint_defs, "${def_start}UNIQUE " .
 459             '(' . $qf . join( $qf. ', '.$qf, @fields ) . $qf.')';
 460     }
 461     elsif ( $type eq NORMAL ) {
 462         $index_def =
 463             "CREATE INDEX ${qf}${name}${qf} on ${qt}${table_name}${qt} (".
 464             join( ', ', map { qq[$qf$_$qf] } @fields ).
 465             ')'
 466             ;
 467     }
 468     else {
 469 #        warn "Unknown index type ($type) on table $table_name.\n"
 470 #            if $WARN;
 471     }
 472
 473     return $index_def, \@constraint_defs;
 474 }
 475
 476 method create_constraint(Constraint $c, $options?) {
 477     my $qf = $options->{quote_field_names} ||'';
 478     my $qt = $options->{quote_table_names} ||'';
 479     my $table_name = $c->table->name;
 480     my (@constraint_defs, @fks);
 481
 482     my $name = $c->name || '';
 483     if ( $name ) {
 484         $name = $self->next_unused_name($name);
 485     }
 486
 487     my @fields     =
 488         map { $_ =~ s/\(.+\)//; $_ }
 489     map { $qt ? $_ : $self->unreserve( $_, $table_name )}
 490     $c->fields;
 491     my @rfields     =
 492         map { $_ =~ s/\(.+\)//; $_ }
 493     map { $qt ? $_ : $self->unreserve( $_, $table_name )}
 494     $c->reference_fields;
 495     return ([], []) if !@fields && $c->type ne CHECK_C;
 496
 497     my $def_start = $name ? qq[CONSTRAINT "$name" ] : '';
 498     if ( $c->type eq PRIMARY_KEY ) {
 499         push @constraint_defs, "${def_start}PRIMARY KEY ".
 500             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 501     }
 502     elsif ( $c->type eq UNIQUE ) {
 503         $name = $self->next_unused_name($name);
 504         push @constraint_defs, "${def_start}UNIQUE " .
 505             '('.$qf . join( $qf.', '.$qf, @fields ) . $qf.')';
 506     }
 507     elsif ( $c->type eq CHECK_C ) {
 508         my $expression = $c->expression;
 509         push @constraint_defs, "${def_start}CHECK ($expression)";
 510     }
 511     elsif ( $c->type eq FOREIGN_KEY ) {
 512         my $def .= "ALTER TABLE ${qt}${table_name}${qt} ADD FOREIGN KEY (" .
 513             join( ', ', map { qq[$qf$_$qf] } @fields ) . ')' .
 514             "\n  REFERENCES " . $qt . $c->reference_table . $qt;
 515
 516         if ( @rfields ) {
 517             $def .= ' ('.$qf . join( $qf.', '.$qf, @rfields ) . $qf.')';
 518         }
 519
 520         if ( $c->match_type ) {
 521             $def .= ' MATCH ' . ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 522         }
 523
 524 =cut
 525         if ( $c->on_delete ) {
 526             $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 527         }
 528
 529         if ( $c->on_update ) {
 530             $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 531         }
 532 =cut
 533         if ( $c->deferrable ) {
 534             $def .= ' DEFERRABLE';
 535         }
 536
 537         push @fks, "$def";
 538     }
 539
 540     return \@constraint_defs, \@fks;
 541 }
 542
 543 method convert_datatype(Column $field) {
 544     my @size      = $field->size;
 545     my $data_type = lc $field->data_type;
 546
 547     if ( $data_type eq 'enum' ) {
 548 #        my $len = 0;
 549 #        $len = ($len < length($_)) ? length($_) : $len for (@$list);
 550 #        my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 551 #        push @$constraint_defs,
 552 #        qq[CONSTRAINT "$chk_name" CHECK ($qf$field_name$qf ].
 553 #           qq[IN ($commalist))];
 554         $data_type = 'character varying';
 555     }
 556     elsif ( $data_type eq 'set' ) {
 557         $data_type = 'character varying';
 558     }
 559     elsif ( $field->is_auto_increment ) {
 560         if ( defined $size[0] && $size[0] > 11 ) {
 561             $data_type = 'bigserial';
 562         }
 563         else {
 564             $data_type = 'serial';
 565         }
 566         undef @size;
 567     }
 568     else {
 569         $data_type  = defined $translate{ $data_type } ?
 570             $translate{ $data_type } :
 571             $data_type;
 572     }
 573
 574     if ( $data_type =~ /^time/i || $data_type =~ /^interval/i ) {
 575         if ( defined $size[0] && $size[0] > 6 ) {
 576             $size[0] = 6;
 577         }
 578     }
 579
 580     if ( $data_type eq 'integer' ) {
 581         if ( defined $size[0] && $size[0] > 0) {
 582             if ( $size[0] > 10 ) {
 583                 $data_type = 'bigint';
 584             }
 585             elsif ( $size[0] < 5 ) {
 586                 $data_type = 'smallint';
 587             }
 588             else {
 589                 $data_type = 'integer';
 590             }
 591         }
 592         else {
 593             $data_type = 'integer';
 594         }
 595     }
 596
 597     my $type_with_size = join('|',
 598         'bit', 'varbit', 'character', 'bit varying', 'character varying',
 599         'time', 'timestamp', 'interval'
 600     );
 601
 602     if ( $data_type !~ /$type_with_size/ ) {
 603         @size = ();
 604     }
 605
 606     if (defined $size[0] && $size[0] > 0 && $data_type =~ /^time/i ) {
 607         $data_type =~ s/^(time.*?)( with.*)?$/$1($size[0])/;
 608         $data_type .= $2 if(defined $2);
 609     } elsif ( defined $size[0] && $size[0] > 0 ) {
 610         $data_type .= '(' . join( ',', @size ) . ')';
 611     }
 612
 613     return $data_type;
 614 }
 615
 616
 617 method alter_field(Column $from_field, Column $to_field) {
 618     die "Can't alter field in another table"
 619         if($from_field->table->name ne $to_field->table->name);
 620
 621     my @out;
 622     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET NOT NULL',
 623                        $to_field->table->name,
 624                        $to_field->name) if(!$to_field->is_nullable and
 625                                            $from_field->is_nullable);
 626
 627     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP NOT NULL',
 628                       $to_field->table->name,
 629                       $to_field->name)
 630        if ( !$from_field->is_nullable and $to_field->is_nullable );
 631
 632
 633     my $from_dt = $self->convert_datatype($from_field);
 634     my $to_dt   = $self->convert_datatype($to_field);
 635     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s TYPE %s',
 636                        $to_field->table->name,
 637                        $to_field->name,
 638                        $to_dt) if($to_dt ne $from_dt);
 639
 640     push @out, sprintf('ALTER TABLE %s RENAME COLUMN %s TO %s',
 641                        $to_field->table->name,
 642                        $from_field->name,
 643                        $to_field->name) if($from_field->name ne $to_field->name);
 644
 645     my $old_default = $from_field->default_value;
 646     my $new_default = $to_field->default_value;
 647     my $default_value = $to_field->default_value;
 648
 649     # fixes bug where output like this was created:
 650     # ALTER TABLE users ALTER COLUMN column SET DEFAULT ThisIsUnescaped;
 651     if(ref $default_value eq "SCALAR" ) {
 652         $default_value = $$default_value;
 653     } elsif( defined $default_value && $to_dt =~ /^(character|text)/xsmi ) {
 654         $default_value =~ s/'/''/xsmg;
 655         $default_value = q(') . $default_value . q(');
 656     }
 657
 658     push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s SET DEFAULT %s',
 659                        $to_field->table->name,
 660                        $to_field->name,
 661                        $default_value)
 662         if ( defined $new_default &&
 663              (!defined $old_default || $old_default ne $new_default) );
 664
 665      # fixes bug where removing the DEFAULT statement of a column
 666      # would result in no change
 667
 668      push @out, sprintf('ALTER TABLE %s ALTER COLUMN %s DROP DEFAULT',
 669                        $to_field->table->name,
 670                        $to_field->name)
 671         if ( !defined $new_default && defined $old_default );
 672
 673
 674     return wantarray ? @out : join("\n", @out);
 675 }
 676
 677 method rename_field(@args) { $self->alter_field(@args) }
 678
 679 method add_field(Column $new_field) {
 680     my $out = sprintf('ALTER TABLE %s ADD COLUMN %s',
 681                       $new_field->table->name,
 682                       $self->create_field($new_field));
 683     return $out;
 684
 685 }
 686
 687 method drop_field(Column $old_field) {
 688     my $out = sprintf('ALTER TABLE %s DROP COLUMN %s',
 689                       $old_field->table->name,
 690                       $old_field->name);
 691
 692     return $out;
 693 }
 694
 695 method alter_table(Column $to_table, $options?) {
 696     my $qt = $options->{quote_table_names} || '';
 697     my $out = sprintf('ALTER TABLE %s %s',
 698                       $qt . $to_table->name . $qt,
 699                       $options->{alter_table_action});
 700     return $out;
 701 }
 702
 703 method rename_table(Table $old_table, Table $new_table, $options?) {
 704     my $qt = $options->{quote_table_names} || '';
 705     $options->{alter_table_action} = "RENAME TO $qt$new_table$qt";
 706     return alter_table($old_table, $options);
 707 }
 708
 709 method alter_create_index(Index $index, $options?) {
 710     my $qt = $options->{quote_table_names} || '';
 711     my $qf = $options->{quote_field_names} || '';
 712     my ($idef, $constraints) = create_index($index, {
 713         quote_field_names => $qf,
 714         quote_table_names => $qt,
 715         table_name => $index->table->name,
 716     });
 717     return $index->type eq NORMAL ? $idef
 718         : sprintf('ALTER TABLE %s ADD %s',
 719               $qt . $index->table->name . $qt,
 720               join(q{}, @$constraints)
 721           );
 722 }
 723
 724 method alter_drop_index(Index $index, $options?) {
 725     my $index_name = $index->name;
 726     return "DROP INDEX $index_name";
 727 }
 728
 729 method alter_drop_constraint(Constraint $c, $options?) {
 730     my $qt = $options->{quote_table_names} || '';
 731     my $qc = $options->{quote_field_names} || '';
 732     my $out = sprintf('ALTER TABLE %s DROP CONSTRAINT %s',
 733                       $qt . $c->table->name . $qt,
 734                       $qc . $c->name . $qc );
 735     return $out;
 736 }
 737
 738 method alter_create_constraint(Index $index, $options?) {
 739     my $qt = $options->{quote_table_names} || '';
 740     my ($defs, $fks) = create_constraint(@_);
 741
 742     # return if there are no constraint definitions so we don't run
 743     # into output like this:
 744     # ALTER TABLE users ADD ;
 745
 746     return unless(@{$defs} || @{$fks});
 747     return $index->type eq FOREIGN_KEY ? join(q{}, @{$fks})
 748         : join( ' ', 'ALTER TABLE', $qt.$index->table->name.$qt,
 749               'ADD', join(q{}, @{$defs}, @{$fks})
 750           );
 751 }
 752
 753 method drop_table(Str $table, $options?) {
 754     my $qt = $options->{quote_table_names} || '';
 755     return "DROP TABLE $qt$table$qt CASCADE";
 756 }
 757
 758     method header_comment($producer?, $comment_char?) {
 759         $producer ||= caller;
 760         my $now = scalar localtime;
 761         my $DEFAULT_COMMENT = '-- ';
 762
 763         $comment_char = $DEFAULT_COMMENT
 764             unless defined $comment_char;
 765
 766         my $header_comment =<<"HEADER_COMMENT";
 767             ${comment_char}
 768             ${comment_char}Created by $producer
 769             ${comment_char}Created on $now
 770             ${comment_char}
 771 HEADER_COMMENT
 772
 773         # Any additional stuff passed in
 774         for my $additional_comment (@_) {
 775             $header_comment .= "${comment_char}${additional_comment}\n";
 776         }
 777
 778         return $header_comment;
 779     }
 780 }