lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.17 2003-09-26 22:35:23 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.17 $ =~ /(\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     => 'numeric',
  46     decimal    => 'numeric',
  47     float      => 'numeric',
  48     int        => 'integer',
  49     mediumint  => 'integer',
  50     smallint   => 'smallint',
  51     tinyint    => 'smallint',
  52     char       => 'character',
  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       => 'character',
  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       => 'numeric',
  89     comment    => 'text',
  90     bit        => 'bit',
  91     tinyint    => 'smallint',
  92     float      => 'numeric',
  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" ].
 210                     qq[IN ($commalist))];
 211                 $data_type = 'character varying';
 212             }
 213             elsif ( $data_type eq 'set' ) {
 214                 # XXX add a CHECK constraint maybe
 215                 # (trickier and slower, than enum :)
 216 #                my $len     = length $commalist;
 217 #                $field_def .= " character varying($len) /* set $commalist */";
 218                 $data_type = 'character varying';
 219             }
 220             elsif ( $field->is_auto_increment ) {
 221                 if ( defined $size[0] && $size[0] > 11 ) {
 222                     $data_type = 'bigserial';
 223                 }
 224                 else {
 225                     $data_type = 'serial';
 226                 }
 227                 undef @size;
 228
 229 #                $seq_name   = mk_name( $table_name.'_'.$field_name, 'sq' );
 230 #                push @sequence_defs, qq[DROP SEQUENCE "$seq_name";];
 231 #                push @sequence_defs, qq[CREATE SEQUENCE "$seq_name";];
 232             }
 233             else {
 234                 $data_type  = defined $translate{ $data_type } ?
 235                               $translate{ $data_type } :
 236                               $data_type;
 237             }
 238
 239             if ( $data_type =~ /timestamp/i ) {
 240                 if ( defined $size[0] && $size[0] > 6 ) {
 241                     $size[0] = 6;
 242                 }
 243             }
 244
 245             if ( $data_type eq 'integer' ) {
 246                 if ( defined $size[0] ) {
 247                     if ( $size[0] > 10 ) {
 248                         $data_type = 'bigint';
 249                     }
 250                     elsif ( $size[0] < 5 ) {
 251                         $data_type = 'smallint';
 252                     }
 253                     else {
 254                         $data_type = 'integer';
 255                     }
 256                 }
 257                 else {
 258                     $data_type = 'integer';
 259                 }
 260             }
 261
 262             #
 263             # PG doesn't need a size for integers or text
 264             #
 265             undef @size if $data_type =~ m/(integer|smallint|bigint|text)/;
 266
 267             $field_def .= " $data_type";
 268
 269             if ( defined $size[0] && $size[0] > 0 ) {
 270                 $field_def .= '(' . join( ',', @size ) . ')';
 271             }
 272
 273             #
 274             # Default value -- disallow for timestamps
 275             #
 276             my $default = $data_type =~ /(timestamp|date)/i
 277                 ? undef : $field->default_value;
 278             if ( defined $default ) {
 279                 $field_def .= sprintf( ' DEFAULT %s',
 280                     ( $field->is_auto_increment && $seq_name )
 281                     ? qq[nextval('"$seq_name"'::text)] :
 282                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 283                 );
 284             }
 285
 286             #
 287             # Not null constraint
 288             #
 289             $field_def .= ' NOT NULL' unless $field->is_nullable;
 290
 291             push @field_defs, $field_def;
 292         }
 293
 294         #
 295         # Index Declarations
 296         #
 297         my @index_defs = ();
 298         my $idx_name_default;
 299         for my $index ( $table->get_indices ) {
 300             my $name = $index->name || '';
 301             if ( $name ) {
 302                 $name = next_unused_name($name, \%used_index_names);
 303                 $used_index_names{$name} = $name;
 304             }
 305
 306             my $type = $index->type || NORMAL;
 307             my @fields     =
 308                 map { $_ =~ s/\(.+\)//; $_ }
 309                 map { unreserve( $_, $table_name ) }
 310                 $index->fields;
 311             next unless @fields;
 312
 313             my $def_start = qq[Constraint "$name" ];
 314             if ( $type eq PRIMARY_KEY ) {
 315                 push @constraint_defs, "${def_start}PRIMARY KEY ".
 316                     '("' . join( '", "', @fields ) . '")';
 317             }
 318             elsif ( $type eq UNIQUE ) {
 319                 push @constraint_defs, "${def_start}UNIQUE " .
 320                     '("' . join( '", "', @fields ) . '")';
 321             }
 322             elsif ( $type eq NORMAL ) {
 323                 push @index_defs,
 324                     'CREATE INDEX "' . $name . "\" on $table_name_ur (".
 325                         join( ', ', map { qq["$_"] } @fields ).
 326                     ');'
 327                 ;
 328             }
 329             else {
 330                 warn "Unknown index type ($type) on table $table_name.\n"
 331                     if $WARN;
 332             }
 333         }
 334
 335         #
 336         # Table constraints
 337         #
 338         my $c_name_default;
 339         for my $c ( $table->get_constraints ) {
 340             my $name = $c->name || '';
 341             if ( $name ) {
 342                 $name = next_unused_name($name, \%used_index_names);
 343                 $used_index_names{$name} = $name;
 344             }
 345
 346             my @fields     =
 347                 map { $_ =~ s/\(.+\)//; $_ }
 348                 map { unreserve( $_, $table_name ) }
 349                 $c->fields;
 350
 351             my @rfields     =
 352                 map { $_ =~ s/\(.+\)//; $_ }
 353                 map { unreserve( $_, $table_name ) }
 354                 $c->reference_fields;
 355
 356             next if !@fields && $c->type ne CHECK_C;
 357
 358             my $def_start = $name ? qq[Constraint "$name" ] : '';
 359             if ( $c->type eq PRIMARY_KEY ) {
 360                 push @constraint_defs, "${def_start}PRIMARY KEY ".
 361                     '("' . join( '", "', @fields ) . '")';
 362             }
 363             elsif ( $c->type eq UNIQUE ) {
 364                 $name = next_unused_name($name, \%used_index_names);
 365                 $used_index_names{$name} = $name;
 366                 push @constraint_defs, "${def_start}UNIQUE " .
 367                     '("' . join( '", "', @fields ) . '")';
 368             }
 369             elsif ( $c->type eq CHECK_C ) {
 370                 my $expression = $c->expression;
 371                 push @constraint_defs, "${def_start}CHECK ($expression)";
 372             }
 373             elsif ( $c->type eq FOREIGN_KEY ) {
 374 #                my $def = join(' ',
 375 #                    map { $_ || () } 'FOREIGN KEY', $c->name
 376 #                );
 377 #
 378                 my $def .= 'FOREIGN KEY ("' . join( '", "', @fields ) . '")';
 379
 380                 $def .= ' REFERENCES ' . $c->reference_table;
 381
 382                 if ( @rfields ) {
 383                     $def .= ' ("' . join( '", "', @rfields ) . '")';
 384                 }
 385
 386                 if ( $c->match_type ) {
 387                     $def .= ' MATCH ' .
 388                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 389                 }
 390
 391                 if ( $c->on_delete ) {
 392                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 393                 }
 394
 395                 if ( $c->on_update ) {
 396                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 397                 }
 398
 399                 push @constraint_defs, $def;
 400             }
 401         }
 402
 403         my $create_statement;
 404         $create_statement  = qq[DROP TABLE "$table_name_ur";\n]
 405             if $add_drop_table;
 406         $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
 407             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 408             "\n);"
 409         ;
 410
 411         $output .= join( "\n\n",
 412             @comments,
 413             @sequence_defs,
 414             $create_statement,
 415             @index_defs,
 416             ''
 417         );
 418     }
 419
 420     if ( $WARN ) {
 421         if ( %truncated ) {
 422             warn "Truncated " . keys( %truncated ) . " names:\n";
 423             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 424         }
 425
 426         if ( %unreserve ) {
 427             warn "Encounted " . keys( %unreserve ) .
 428                 " unsafe names in schema (reserved or invalid):\n";
 429             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 430         }
 431     }
 432
 433     return $output;
 434 }
 435
 436 # -------------------------------------------------------------------
 437 sub mk_name {
 438     my $basename      = shift || '';
 439     my $type          = shift || '';
 440     my $scope         = shift || '';
 441     my $critical      = shift || '';
 442     my $basename_orig = $basename;
 443     my $max_name      = $type
 444                         ? $max_id_length - (length($type) + 1)
 445                         : $max_id_length;
 446     $basename         = substr( $basename, 0, $max_name )
 447                         if length( $basename ) > $max_name;
 448     my $name          = $type ? "${type}_$basename" : $basename;
 449
 450     if ( $basename ne $basename_orig and $critical ) {
 451         my $show_type = $type ? "+'$type'" : "";
 452         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 453             "character limit to make '$name'\n" if $WARN;
 454         $truncated{ $basename_orig } = $name;
 455     }
 456
 457     $scope ||= \%global_names;
 458     if ( my $prev = $scope->{ $name } ) {
 459         my $name_orig = $name;
 460         $name        .= sprintf( "%02d", ++$prev );
 461         substr($name, $max_id_length - 3) = "00"
 462             if length( $name ) > $max_id_length;
 463
 464         warn "The name '$name_orig' has been changed to ",
 465              "'$name' to make it unique.\n" if $WARN;
 466
 467         $scope->{ $name_orig }++;
 468     }
 469
 470     $scope->{ $name }++;
 471     return $name;
 472 }
 473
 474 # -------------------------------------------------------------------
 475 sub unreserve {
 476     my $name            = shift || '';
 477     my $schema_obj_name = shift || '';
 478
 479     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 480
 481     # also trap fields that don't begin with a letter
 482     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 483
 484     if ( $schema_obj_name ) {
 485         ++$unreserve{"$schema_obj_name.$name"};
 486     }
 487     else {
 488         ++$unreserve{"$name (table name)"};
 489     }
 490
 491     my $unreserve = sprintf '%s_', $name;
 492     return $unreserve.$suffix;
 493 }
 494
 495 # -------------------------------------------------------------------
 496 sub next_unused_name {
 497     my $name       = shift || '';
 498     my $used_names = shift || '';
 499
 500     my %used_names = %$used_names;
 501
 502     if ( !defined($used_names{$name}) ) {
 503         $used_names{$name} = $name;
 504         return $name;
 505     }
 506
 507     my $i = 2;
 508     while ( defined($used_names{$name . $i}) ) {
 509         ++$i;
 510     }
 511     $name .= $i;
 512     $used_names{$name} = $name;
 513     return $name;
 514 }
 515
 516 1;
 517
 518 # -------------------------------------------------------------------
 519 # Life is full of misery, loneliness, and suffering --
 520 # and it's all over much too soon.
 521 # Woody Allen
 522 # -------------------------------------------------------------------
 523
 524 =pod
 525
 526 =head1 AUTHOR
 527
 528 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 529
 530 =cut