lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.13 2003-08-17 00:46:23 rossta 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.13 $ =~ /(\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("','", @$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 $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 208                 push @constraint_defs,
 209                 "CONSTRAINT $check_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 unless @fields;
 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 FOREIGN_KEY ) {
 369                 my $def = join(' ',
 370                     map { $_ || () } 'FOREIGN KEY', $c->name
 371                 );
 372
 373                 $def .= ' ("' . join( '", "', @fields ) . '")';
 374
 375                 $def .= ' REFERENCES ' . $c->reference_table;
 376
 377                 if ( @rfields ) {
 378                     $def .= ' ("' . join( '", "', @rfields ) . '")';
 379                 }
 380
 381                 if ( $c->match_type ) {
 382                     $def .= ' MATCH ' .
 383                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 384                 }
 385
 386                 if ( $c->on_delete ) {
 387                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 388                 }
 389
 390                 if ( $c->on_update ) {
 391                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 392                 }
 393
 394                 push @constraint_defs, $def;
 395             }
 396         }
 397
 398         my $create_statement;
 399         $create_statement  = qq[DROP TABLE "$table_name_ur";\n]
 400             if $add_drop_table;
 401         $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
 402             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 403             "\n);"
 404         ;
 405
 406         $output .= join( "\n\n",
 407             @comments,
 408             @sequence_defs,
 409             $create_statement,
 410             @index_defs,
 411             ''
 412         );
 413     }
 414
 415     if ( $WARN ) {
 416         if ( %truncated ) {
 417             warn "Truncated " . keys( %truncated ) . " names:\n";
 418             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 419         }
 420
 421         if ( %unreserve ) {
 422             warn "Encounted " . keys( %unreserve ) .
 423                 " unsafe names in schema (reserved or invalid):\n";
 424             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 425         }
 426     }
 427
 428     return $output;
 429 }
 430
 431 # -------------------------------------------------------------------
 432 sub mk_name {
 433     my $basename      = shift || '';
 434     my $type          = shift || '';
 435     my $scope         = shift || '';
 436     my $critical      = shift || '';
 437     my $basename_orig = $basename;
 438     my $max_name      = $type
 439                         ? $max_id_length - (length($type) + 1)
 440                         : $max_id_length;
 441     $basename         = substr( $basename, 0, $max_name )
 442                         if length( $basename ) > $max_name;
 443     my $name          = $type ? "${type}_$basename" : $basename;
 444
 445     if ( $basename ne $basename_orig and $critical ) {
 446         my $show_type = $type ? "+'$type'" : "";
 447         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 448             "character limit to make '$name'\n" if $WARN;
 449         $truncated{ $basename_orig } = $name;
 450     }
 451
 452     $scope ||= \%global_names;
 453     if ( my $prev = $scope->{ $name } ) {
 454         my $name_orig = $name;
 455         $name        .= sprintf( "%02d", ++$prev );
 456         substr($name, $max_id_length - 3) = "00"
 457             if length( $name ) > $max_id_length;
 458
 459         warn "The name '$name_orig' has been changed to ",
 460              "'$name' to make it unique.\n" if $WARN;
 461
 462         $scope->{ $name_orig }++;
 463     }
 464
 465     $scope->{ $name }++;
 466     return $name;
 467 }
 468
 469 # -------------------------------------------------------------------
 470 sub unreserve {
 471     my $name            = shift || '';
 472     my $schema_obj_name = shift || '';
 473
 474     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 475
 476     # also trap fields that don't begin with a letter
 477     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 478
 479     if ( $schema_obj_name ) {
 480         ++$unreserve{"$schema_obj_name.$name"};
 481     }
 482     else {
 483         ++$unreserve{"$name (table name)"};
 484     }
 485
 486     my $unreserve = sprintf '%s_', $name;
 487     return $unreserve.$suffix;
 488 }
 489
 490 # -------------------------------------------------------------------
 491 sub next_unused_name {
 492     my $name       = shift || '';
 493     my $used_names = shift || '';
 494
 495     my %used_names = %$used_names;
 496
 497     if ( !defined($used_names{$name}) ) {
 498         $used_names{$name} = $name;
 499         return $name;
 500     }
 501
 502     my $i = 2;
 503     while ( defined($used_names{$name . $i}) ) {
 504         ++$i;
 505     }
 506     $name .= $i;
 507     $used_names{$name} = $name;
 508     return $name;
 509 }
 510
 511 1;
 512
 513 # -------------------------------------------------------------------
 514 # Life is full of misery, loneliness, and suffering --
 515 # and it's all over much too soon.
 516 # Woody Allen
 517 # -------------------------------------------------------------------
 518
 519 =pod
 520
 521 =head1 AUTHOR
 522
 523 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 524
 525 =cut