lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.15 2003-08-21 18:10:14 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>,
   8 #                    Chris Mungall <cjm@fruitfly.org>
   9 #
  10 # This program is free software; you can redistribute it and/or
  11 # modify it under the terms of the GNU General Public License as
  12 # published by the Free Software Foundation; version 2.
  13 #
  14 # This program is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 # General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program; if not, write to the Free Software
  21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  22 # 02111-1307  USA
  23 # -------------------------------------------------------------------
  24
  25 =head1 NAME
  26
  27 SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
  28
  29 =cut
  30
  31 use strict;
  32 use vars qw[ $DEBUG $WARN $VERSION ];
  33 $VERSION = sprintf "%d.%02d", q$Revision: 1.15 $ =~ /(\d+)\.(\d+)/;
  34 $DEBUG = 1 unless defined $DEBUG;
  35
  36 use SQL::Translator::Schema::Constants;
  37 use SQL::Translator::Utils qw(header_comment);
  38 use Data::Dumper;
  39
  40 my %translate  = (
  41     #
  42     # MySQL types
  43     #
  44     bigint     => 'bigint',
  45     double     => 'double precision',
  46     decimal    => 'decimal',
  47     float      => 'double precision',
  48     int        => 'integer',
  49     mediumint  => 'integer',
  50     smallint   => 'smallint',
  51     tinyint    => 'smallint',
  52     char       => 'char',
  53     varchar    => 'character varying',
  54     longtext   => 'text',
  55     mediumtext => 'text',
  56     text       => 'text',
  57     tinytext   => 'text',
  58     tinyblob   => 'bytea',
  59     blob       => 'bytea',
  60     mediumblob => 'bytea',
  61     longblob   => 'bytea',
  62     enum       => 'character varying',
  63     set        => 'character varying',
  64     date       => 'date',
  65     datetime   => 'timestamp',
  66     time       => 'date',
  67     timestamp  => 'timestamp',
  68     year       => 'date',
  69
  70     #
  71     # Oracle types
  72     #
  73     number     => 'integer',
  74     char       => 'char',
  75     varchar2   => 'character varying',
  76     long       => 'text',
  77     CLOB       => 'bytea',
  78     date       => 'date',
  79
  80     #
  81     # Sybase types
  82     #
  83     int        => 'integer',
  84     money      => 'money',
  85     varchar    => 'character varying',
  86     datetime   => 'timestamp',
  87     text       => 'text',
  88     real       => 'double precision',
  89     comment    => 'text',
  90     bit        => 'bit',
  91     tinyint    => 'smallint',
  92     float      => 'double precision',
  93 );
  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    = 30;
 114 my %used_identifiers = ();
 115 my %global_names;
 116 my %unreserve;
 117 my %truncated;
 118
 119 =pod
 120
 121 =head1 PostgreSQL Create Table Syntax
 122
 123   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
 124       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
 125       | table_constraint }  [, ... ]
 126   )
 127   [ INHERITS ( parent_table [, ... ] ) ]
 128   [ WITH OIDS | WITHOUT OIDS ]
 129
 130 where column_constraint is:
 131
 132   [ CONSTRAINT constraint_name ]
 133   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
 134     CHECK (expression) |
 135     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
 136       [ ON DELETE action ] [ ON UPDATE action ] }
 137   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 138
 139 and table_constraint is:
 140
 141   [ CONSTRAINT constraint_name ]
 142   { UNIQUE ( column_name [, ... ] ) |
 143     PRIMARY KEY ( column_name [, ... ] ) |
 144     CHECK ( expression ) |
 145     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 146       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 147   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 148
 149 =head1 Create Index Syntax
 150
 151   CREATE [ UNIQUE ] INDEX index_name ON table
 152       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 153       [ WHERE predicate ]
 154   CREATE [ UNIQUE ] INDEX index_name ON table
 155       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 156       [ WHERE predicate ]
 157
 158 =cut
 159
 160 # -------------------------------------------------------------------
 161 sub produce {
 162     my $translator     = shift;
 163     $DEBUG             = $translator->debug;
 164     $WARN              = $translator->show_warnings;
 165     my $no_comments    = $translator->no_comments;
 166     my $add_drop_table = $translator->add_drop_table;
 167     my $schema         = $translator->schema;
 168
 169     my $output;
 170     $output .= header_comment unless ($no_comments);
 171     my %used_index_names;
 172
 173     for my $table ( $schema->get_tables ) {
 174         my $table_name    = $table->name or next;
 175         $table_name       = mk_name( $table_name, '', undef, 1 );
 176         my $table_name_ur = unreserve($table_name);
 177
 178         my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
 179
 180         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 181
 182         #
 183         # Fields
 184         #
 185         my %field_name_scope;
 186         for my $field ( $table->get_fields ) {
 187             my $field_name    = mk_name(
 188                 $field->name, '', \%field_name_scope, 1
 189             );
 190             my $field_name_ur = unreserve( $field_name, $table_name );
 191             my $field_def     = qq["$field_name_ur"];
 192
 193             #
 194             # Datatype
 195             #
 196             my @size      = $field->size;
 197             my $data_type = lc $field->data_type;
 198             my %extra     = $field->extra;
 199             my $list      = $extra{'list'} || [];
 200             # todo deal with embedded quotes
 201             my $commalist = join( ', ', map { qq['$_'] } @$list );
 202             my $seq_name;
 203
 204             if ( $data_type eq 'enum' ) {
 205                 my $len = 0;
 206                 $len = ($len < length($_)) ? length($_) : $len for (@$list);
 207                 my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 208                 push @constraint_defs,
 209                 qq[CONSTRAINT $chk_name CHECK ("$field_name" IN ($commalist))];
 210                 $data_type = 'character varying';
 211             }
 212             elsif ( $data_type eq 'set' ) {
 213                 # XXX add a CHECK constraint maybe
 214                 # (trickier and slower, than enum :)
 215 #                my $len     = length $commalist;
 216 #                $field_def .= " character varying($len) /* set $commalist */";
 217                 $data_type = 'character varying';
 218             }
 219             elsif ( $field->is_auto_increment ) {
 220                 if ( defined $size[0] && $size[0] > 11 ) {
 221                     $data_type = ' bigserial';
 222                 }
 223                 else {
 224                     $data_type = ' serial';
 225                 }
 226                 undef @size;
 227
 228 #                $seq_name   = mk_name( $table_name.'_'.$field_name, 'sq' );
 229 #                push @sequence_defs, qq[DROP SEQUENCE "$seq_name";];
 230 #                push @sequence_defs, qq[CREATE SEQUENCE "$seq_name";];
 231             }
 232             else {
 233                 $data_type  = defined $translate{ $data_type } ?
 234                               $translate{ $data_type } :
 235                               $data_type;
 236             }
 237
 238             if ( $data_type =~ /timestamp/i ) {
 239                 if ( defined $size[0] && $size[0] > 13 ) {
 240                     $size[0] = 13;
 241                 }
 242             }
 243
 244             if ( $data_type eq 'integer' ) {
 245                 if ( defined $size[0] ) {
 246                     if ( $size[0] > 10 ) { #
 247                         $data_type = ' bigint';
 248                     }
 249                     elsif ( $size[0] < 5 ) {
 250                         $data_type = ' smallint';
 251                     }
 252                     else {
 253                         $data_type = ' integer';
 254                     }
 255                 }
 256                 else {
 257                     $data_type = ' integer';
 258                 }
 259                 undef @size;
 260             }
 261
 262             $field_def .= " $data_type";
 263
 264             if ( defined $size[0] && $size[0] > 0 ) {
 265                 $field_def .= '(' . join( ', ', @size ) . ')';
 266             }
 267
 268             #
 269             # Default value
 270             #
 271             my $default = $field->default_value;
 272             if ( defined $default ) {
 273                 $field_def .= sprintf( ' DEFAULT %s',
 274                     ( $field->is_auto_increment && $seq_name )
 275                     ? qq[nextval('"$seq_name"'::text)] :
 276                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 277                 );
 278             }
 279
 280             #
 281             # Not null constraint
 282             #
 283             $field_def .= ' NOT NULL' unless $field->is_nullable;
 284
 285             push @field_defs, $field_def;
 286         }
 287
 288         #
 289         # Index Declarations
 290         #
 291         my @index_defs = ();
 292         my $idx_name_default;
 293         for my $index ( $table->get_indices ) {
 294             my $name = $index->name || '';
 295             my $type = $index->type || NORMAL;
 296             my @fields     =
 297                 map { $_ =~ s/\(.+\)//; $_ }
 298                 map { unreserve( $_, $table_name ) }
 299                 $index->fields;
 300             next unless @fields;
 301
 302             if ( $type eq PRIMARY_KEY ) {
 303                 $name ||= mk_name( $table_name, 'pk' );
 304                 $name = next_unused_name($name, \%used_index_names);
 305                 # how do I get next_unused_name() to do: ?
 306                 $used_index_names{$name} = $name;
 307                 push @constraint_defs, 'CONSTRAINT '.$name.' PRIMARY KEY '.
 308                     '("' . join( '", "', @fields ) . '")';
 309             }
 310             elsif ( $type eq UNIQUE ) {
 311                 $name ||= mk_name(
 312                     $table_name, $name || ++$idx_name_default
 313                 );
 314                 $name = next_unused_name($name, \%used_index_names);
 315                 $used_index_names{$name} = $name;
 316                 push @constraint_defs, 'CONSTRAINT ' . $name . ' UNIQUE ' .
 317                     '("' . join( '", "', @fields ) . '")';
 318             }
 319             elsif ( $type eq NORMAL ) {
 320                 $name ||= mk_name(
 321                     $table_name, $name || ++$idx_name_default
 322                 );
 323                 $name = next_unused_name($name, \%used_index_names);
 324                 $used_index_names{$name} = $name;
 325                 push @index_defs,
 326                     qq[CREATE INDEX "$name" on $table_name_ur ("].
 327                         join( '", "', @fields ).
 328                     '");';
 329             }
 330             else {
 331                 warn "Unknown index type ($type) on table $table_name.\n"
 332                     if $WARN;
 333             }
 334         }
 335
 336         #
 337         # Table constraints
 338         #
 339         my $c_name_default;
 340         for my $c ( $table->get_constraints ) {
 341             my $name = $c->name || '';
 342             my @fields     =
 343                 map { $_ =~ s/\(.+\)//; $_ }
 344                 map { unreserve( $_, $table_name ) }
 345                 $c->fields;
 346             my @rfields     =
 347                 map { $_ =~ s/\(.+\)//; $_ }
 348                 map { unreserve( $_, $table_name ) }
 349                 $c->reference_fields;
 350             next if !@fields && $c->type ne CHECK_C;
 351
 352             if ( $c->type eq PRIMARY_KEY ) {
 353                 $name ||= mk_name( $table_name, 'pk' );
 354                 $name = next_unused_name($name, \%used_index_names);
 355                 $used_index_names{$name} = $name;
 356                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 357                     '("' . join( '", "', @fields ) . '")';
 358             }
 359             elsif ( $c->type eq UNIQUE ) {
 360                 $name ||= mk_name(
 361                     $table_name, $name || ++$c_name_default
 362                 );
 363                 $name = next_unused_name($name, \%used_index_names);
 364                 $used_index_names{$name} = $name;
 365                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 366                     '("' . join( '", "', @fields ) . '")';
 367             }
 368             elsif ( $c->type eq CHECK_C ) {
 369                 my $s;
 370                 if ( $name ) {
 371                     $name ||= mk_name(
 372                         $table_name, $name || ++$c_name_default
 373                     );
 374                     $name = next_unused_name($name, \%used_index_names);
 375                     $used_index_names{$name} = $name;
 376                     $s = 'CONSTRAINT $name ';
 377                 }
 378                 my $expression = $c->expression;
 379                 push @constraint_defs, "${s}CHECK ($expression)";
 380             }
 381             elsif ( $c->type eq FOREIGN_KEY ) {
 382                 my $def = join(' ',
 383                     map { $_ || () } 'FOREIGN KEY', $c->name
 384                 );
 385
 386                 $def .= ' ("' . join( '", "', @fields ) . '")';
 387
 388                 $def .= ' REFERENCES ' . $c->reference_table;
 389
 390                 if ( @rfields ) {
 391                     $def .= ' ("' . join( '", "', @rfields ) . '")';
 392                 }
 393
 394                 if ( $c->match_type ) {
 395                     $def .= ' MATCH ' .
 396                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 397                 }
 398
 399                 if ( $c->on_delete ) {
 400                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 401                 }
 402
 403                 if ( $c->on_update ) {
 404                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 405                 }
 406
 407                 push @constraint_defs, $def;
 408             }
 409         }
 410
 411         my $create_statement;
 412         $create_statement  = qq[DROP TABLE "$table_name_ur";\n]
 413             if $add_drop_table;
 414         $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
 415             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 416             "\n);"
 417         ;
 418
 419         $output .= join( "\n\n",
 420             @comments,
 421             @sequence_defs,
 422             $create_statement,
 423             @index_defs,
 424             ''
 425         );
 426     }
 427
 428     if ( $WARN ) {
 429         if ( %truncated ) {
 430             warn "Truncated " . keys( %truncated ) . " names:\n";
 431             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 432         }
 433
 434         if ( %unreserve ) {
 435             warn "Encounted " . keys( %unreserve ) .
 436                 " unsafe names in schema (reserved or invalid):\n";
 437             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 438         }
 439     }
 440
 441     return $output;
 442 }
 443
 444 # -------------------------------------------------------------------
 445 sub mk_name {
 446     my $basename      = shift || '';
 447     my $type          = shift || '';
 448     my $scope         = shift || '';
 449     my $critical      = shift || '';
 450     my $basename_orig = $basename;
 451     my $max_name      = $type
 452                         ? $max_id_length - (length($type) + 1)
 453                         : $max_id_length;
 454     $basename         = substr( $basename, 0, $max_name )
 455                         if length( $basename ) > $max_name;
 456     my $name          = $type ? "${type}_$basename" : $basename;
 457
 458     if ( $basename ne $basename_orig and $critical ) {
 459         my $show_type = $type ? "+'$type'" : "";
 460         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 461             "character limit to make '$name'\n" if $WARN;
 462         $truncated{ $basename_orig } = $name;
 463     }
 464
 465     $scope ||= \%global_names;
 466     if ( my $prev = $scope->{ $name } ) {
 467         my $name_orig = $name;
 468         $name        .= sprintf( "%02d", ++$prev );
 469         substr($name, $max_id_length - 3) = "00"
 470             if length( $name ) > $max_id_length;
 471
 472         warn "The name '$name_orig' has been changed to ",
 473              "'$name' to make it unique.\n" if $WARN;
 474
 475         $scope->{ $name_orig }++;
 476     }
 477
 478     $scope->{ $name }++;
 479     return $name;
 480 }
 481
 482 # -------------------------------------------------------------------
 483 sub unreserve {
 484     my $name            = shift || '';
 485     my $schema_obj_name = shift || '';
 486
 487     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 488
 489     # also trap fields that don't begin with a letter
 490     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 491
 492     if ( $schema_obj_name ) {
 493         ++$unreserve{"$schema_obj_name.$name"};
 494     }
 495     else {
 496         ++$unreserve{"$name (table name)"};
 497     }
 498
 499     my $unreserve = sprintf '%s_', $name;
 500     return $unreserve.$suffix;
 501 }
 502
 503 # -------------------------------------------------------------------
 504 sub next_unused_name {
 505     my $name       = shift || '';
 506     my $used_names = shift || '';
 507
 508     my %used_names = %$used_names;
 509
 510     if ( !defined($used_names{$name}) ) {
 511         $used_names{$name} = $name;
 512         return $name;
 513     }
 514
 515     my $i = 2;
 516     while ( defined($used_names{$name . $i}) ) {
 517         ++$i;
 518     }
 519     $name .= $i;
 520     $used_names{$name} = $name;
 521     return $name;
 522 }
 523
 524 1;
 525
 526 # -------------------------------------------------------------------
 527 # Life is full of misery, loneliness, and suffering --
 528 # and it's all over much too soon.
 529 # Woody Allen
 530 # -------------------------------------------------------------------
 531
 532 =pod
 533
 534 =head1 AUTHOR
 535
 536 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 537
 538 =cut