lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.20 2003-10-15 19:07:13 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 =head1 SYNOPSIS
  30
  31   my $t = SQL::Translator->new( parser => '...', producer => 'PostgreSQL' );
  32   $t->translate;
  33
  34 =head1 DESCRIPTION
  35
  36 Creates a DDL suitable for PostgreSQL.  Very heavily based on the Oracle
  37 producer.
  38
  39 =cut
  40
  41 use strict;
  42 use vars qw[ $DEBUG $WARN $VERSION ];
  43 $VERSION = sprintf "%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/;
  44 $DEBUG = 1 unless defined $DEBUG;
  45
  46 use SQL::Translator::Schema::Constants;
  47 use SQL::Translator::Utils qw(header_comment);
  48 use Data::Dumper;
  49
  50 my %translate  = (
  51     #
  52     # MySQL types
  53     #
  54     bigint     => 'bigint',
  55     double     => 'numeric',
  56     decimal    => 'numeric',
  57     float      => 'numeric',
  58     int        => 'integer',
  59     mediumint  => 'integer',
  60     smallint   => 'smallint',
  61     tinyint    => 'smallint',
  62     char       => 'character',
  63     varchar    => 'character varying',
  64     longtext   => 'text',
  65     mediumtext => 'text',
  66     text       => 'text',
  67     tinytext   => 'text',
  68     tinyblob   => 'bytea',
  69     blob       => 'bytea',
  70     mediumblob => 'bytea',
  71     longblob   => 'bytea',
  72     enum       => 'character varying',
  73     set        => 'character varying',
  74     date       => 'date',
  75     datetime   => 'timestamp',
  76     time       => 'date',
  77     timestamp  => 'timestamp',
  78     year       => 'date',
  79
  80     #
  81     # Oracle types
  82     #
  83     number     => 'integer',
  84     char       => 'character',
  85     varchar2   => 'character varying',
  86     long       => 'text',
  87     CLOB       => 'bytea',
  88     date       => 'date',
  89
  90     #
  91     # Sybase types
  92     #
  93     int        => 'integer',
  94     money      => 'money',
  95     varchar    => 'character varying',
  96     datetime   => 'timestamp',
  97     text       => 'text',
  98     real       => 'numeric',
  99     comment    => 'text',
 100     bit        => 'bit',
 101     tinyint    => 'smallint',
 102     float      => 'numeric',
 103 );
 104
 105 my %reserved = map { $_, 1 } qw[
 106     ALL ANALYSE ANALYZE AND ANY AS ASC
 107     BETWEEN BINARY BOTH
 108     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
 109     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
 110     DEFAULT DEFERRABLE DESC DISTINCT DO
 111     ELSE END EXCEPT
 112     FALSE FOR FOREIGN FREEZE FROM FULL
 113     GROUP HAVING
 114     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
 115     JOIN LEADING LEFT LIKE LIMIT
 116     NATURAL NEW NOT NOTNULL NULL
 117     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
 118     PRIMARY PUBLIC REFERENCES RIGHT
 119     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
 120     UNION UNIQUE USER USING VERBOSE WHEN WHERE
 121 ];
 122
 123 my $max_id_length    = 30;
 124 my %used_identifiers = ();
 125 my %global_names;
 126 my %unreserve;
 127 my %truncated;
 128
 129 =pod
 130
 131 =head1 PostgreSQL Create Table Syntax
 132
 133   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
 134       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
 135       | table_constraint }  [, ... ]
 136   )
 137   [ INHERITS ( parent_table [, ... ] ) ]
 138   [ WITH OIDS | WITHOUT OIDS ]
 139
 140 where column_constraint is:
 141
 142   [ CONSTRAINT constraint_name ]
 143   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
 144     CHECK (expression) |
 145     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
 146       [ ON DELETE action ] [ ON UPDATE action ] }
 147   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 148
 149 and table_constraint is:
 150
 151   [ CONSTRAINT constraint_name ]
 152   { UNIQUE ( column_name [, ... ] ) |
 153     PRIMARY KEY ( column_name [, ... ] ) |
 154     CHECK ( expression ) |
 155     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 156       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 157   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 158
 159 =head1 Create Index Syntax
 160
 161   CREATE [ UNIQUE ] INDEX index_name ON table
 162       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 163       [ WHERE predicate ]
 164   CREATE [ UNIQUE ] INDEX index_name ON table
 165       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 166       [ WHERE predicate ]
 167
 168 =cut
 169
 170 # -------------------------------------------------------------------
 171 sub produce {
 172     my $translator     = shift;
 173     $DEBUG             = $translator->debug;
 174     $WARN              = $translator->show_warnings;
 175     my $no_comments    = $translator->no_comments;
 176     my $add_drop_table = $translator->add_drop_table;
 177     my $schema         = $translator->schema;
 178
 179     my $output;
 180     $output .= header_comment unless ($no_comments);
 181     my %used_index_names;
 182
 183     my @fks;
 184     for my $table ( $schema->get_tables ) {
 185         my $table_name    = $table->name or next;
 186         $table_name       = mk_name( $table_name, '', undef, 1 );
 187         my $table_name_ur = unreserve($table_name);
 188
 189         my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
 190
 191         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 192
 193         #
 194         # Fields
 195         #
 196         my %field_name_scope;
 197         for my $field ( $table->get_fields ) {
 198             my $field_name    = mk_name(
 199                 $field->name, '', \%field_name_scope, 1
 200             );
 201             my $field_name_ur = unreserve( $field_name, $table_name );
 202             my $field_def     = qq["$field_name_ur"];
 203
 204             #
 205             # Datatype
 206             #
 207             my @size      = $field->size;
 208             my $data_type = lc $field->data_type;
 209             my %extra     = $field->extra;
 210             my $list      = $extra{'list'} || [];
 211             # todo deal with embedded quotes
 212             my $commalist = join( ', ', map { qq['$_'] } @$list );
 213             my $seq_name;
 214
 215             if ( $data_type eq 'enum' ) {
 216                 my $len = 0;
 217                 $len = ($len < length($_)) ? length($_) : $len for (@$list);
 218                 my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 219                 push @constraint_defs,
 220                     qq[Constraint "$chk_name" CHECK ("$field_name" ].
 221                     qq[IN ($commalist))];
 222                 $data_type = 'character varying';
 223             }
 224             elsif ( $data_type eq 'set' ) {
 225                 $data_type = 'character varying';
 226             }
 227             elsif ( $field->is_auto_increment ) {
 228                 if ( defined $size[0] && $size[0] > 11 ) {
 229                     $data_type = 'bigserial';
 230                 }
 231                 else {
 232                     $data_type = 'serial';
 233                 }
 234                 undef @size;
 235             }
 236             else {
 237                 $data_type  = defined $translate{ $data_type } ?
 238                               $translate{ $data_type } :
 239                               $data_type;
 240             }
 241
 242             if ( $data_type =~ /timestamp/i ) {
 243                 if ( defined $size[0] && $size[0] > 6 ) {
 244                     $size[0] = 6;
 245                 }
 246             }
 247
 248             if ( $data_type eq 'integer' ) {
 249                 if ( defined $size[0] ) {
 250                     if ( $size[0] > 10 ) {
 251                         $data_type = 'bigint';
 252                     }
 253                     elsif ( $size[0] < 5 ) {
 254                         $data_type = 'smallint';
 255                     }
 256                     else {
 257                         $data_type = 'integer';
 258                     }
 259                 }
 260                 else {
 261                     $data_type = 'integer';
 262                 }
 263             }
 264
 265             #
 266             # PG doesn't need a size for integers or text
 267             #
 268             undef @size if $data_type =~ m/(integer|smallint|bigint|text)/;
 269
 270             $field_def .= " $data_type";
 271
 272             if ( defined $size[0] && $size[0] > 0 ) {
 273                 $field_def .= '(' . join( ',', @size ) . ')';
 274             }
 275
 276             #
 277             # Default value -- disallow for timestamps
 278             #
 279             my $default = $data_type =~ /(timestamp|date)/i
 280                 ? undef : $field->default_value;
 281             if ( defined $default ) {
 282                 $field_def .= sprintf( ' DEFAULT %s',
 283                     ( $field->is_auto_increment && $seq_name )
 284                     ? qq[nextval('"$seq_name"'::text)] :
 285                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 286                 );
 287             }
 288
 289             #
 290             # Not null constraint
 291             #
 292             $field_def .= ' NOT NULL' unless $field->is_nullable;
 293
 294             push @field_defs, $field_def;
 295         }
 296
 297         #
 298         # Index Declarations
 299         #
 300         my @index_defs = ();
 301         my $idx_name_default;
 302         for my $index ( $table->get_indices ) {
 303             my $name = $index->name || '';
 304             if ( $name ) {
 305                 $name = next_unused_name($name, \%used_index_names);
 306                 $used_index_names{$name} = $name;
 307             }
 308
 309             my $type = $index->type || NORMAL;
 310             my @fields     =
 311                 map { $_ =~ s/\(.+\)//; $_ }
 312                 map { unreserve( $_, $table_name ) }
 313                 $index->fields;
 314             next unless @fields;
 315
 316             my $def_start = qq[Constraint "$name" ];
 317             if ( $type eq PRIMARY_KEY ) {
 318                 push @constraint_defs, "${def_start}PRIMARY KEY ".
 319                     '("' . join( '", "', @fields ) . '")';
 320             }
 321             elsif ( $type eq UNIQUE ) {
 322                 push @constraint_defs, "${def_start}UNIQUE " .
 323                     '("' . join( '", "', @fields ) . '")';
 324             }
 325             elsif ( $type eq NORMAL ) {
 326                 push @index_defs,
 327                     'CREATE INDEX "' . $name . "\" on $table_name_ur (".
 328                         join( ', ', map { qq["$_"] } @fields ).
 329                     ');'
 330                 ;
 331             }
 332             else {
 333                 warn "Unknown index type ($type) on table $table_name.\n"
 334                     if $WARN;
 335             }
 336         }
 337
 338         #
 339         # Table constraints
 340         #
 341         my $c_name_default;
 342         for my $c ( $table->get_constraints ) {
 343             my $name = $c->name || '';
 344             if ( $name ) {
 345                 $name = next_unused_name($name, \%used_index_names);
 346                 $used_index_names{$name} = $name;
 347             }
 348
 349             my @fields     =
 350                 map { $_ =~ s/\(.+\)//; $_ }
 351                 map { unreserve( $_, $table_name ) }
 352                 $c->fields;
 353
 354             my @rfields     =
 355                 map { $_ =~ s/\(.+\)//; $_ }
 356                 map { unreserve( $_, $table_name ) }
 357                 $c->reference_fields;
 358
 359             next if !@fields && $c->type ne CHECK_C;
 360
 361             my $def_start = $name ? qq[Constraint "$name" ] : '';
 362             if ( $c->type eq PRIMARY_KEY ) {
 363                 push @constraint_defs, "${def_start}PRIMARY KEY ".
 364                     '("' . join( '", "', @fields ) . '")';
 365             }
 366             elsif ( $c->type eq UNIQUE ) {
 367                 $name = next_unused_name($name, \%used_index_names);
 368                 $used_index_names{$name} = $name;
 369                 push @constraint_defs, "${def_start}UNIQUE " .
 370                     '("' . join( '", "', @fields ) . '")';
 371             }
 372             elsif ( $c->type eq CHECK_C ) {
 373                 my $expression = $c->expression;
 374                 push @constraint_defs, "${def_start}CHECK ($expression)";
 375             }
 376             elsif ( $c->type eq FOREIGN_KEY ) {
 377                 my $def .= "ALTER TABLE $table_name ADD FOREIGN KEY (" .
 378                     join( ', ', map { qq["$_"] } @fields ) . ')' .
 379                     "\n  REFERENCES " . $c->reference_table;
 380
 381                 if ( @rfields ) {
 382                     $def .= ' ("' . join( '", "', @rfields ) . '")';
 383                 }
 384
 385                 if ( $c->match_type ) {
 386                     $def .= ' MATCH ' .
 387                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 388                 }
 389
 390                 if ( $c->on_delete ) {
 391                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 392                 }
 393
 394                 if ( $c->on_update ) {
 395                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 396                 }
 397
 398                 push @fks, "$def;";
 399             }
 400         }
 401
 402         my $create_statement;
 403         $create_statement  = qq[DROP TABLE "$table_name_ur";\n]
 404             if $add_drop_table;
 405         $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
 406             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 407             "\n);"
 408         ;
 409
 410         $output .= join( "\n\n",
 411             @comments,
 412             @sequence_defs,
 413             $create_statement,
 414             @index_defs,
 415             ''
 416         );
 417     }
 418
 419     if ( @fks ) {
 420         $output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
 421         $output .= join( "\n\n", @fks );
 422     }
 423
 424     if ( $WARN ) {
 425         if ( %truncated ) {
 426             warn "Truncated " . keys( %truncated ) . " names:\n";
 427             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 428         }
 429
 430         if ( %unreserve ) {
 431             warn "Encounted " . keys( %unreserve ) .
 432                 " unsafe names in schema (reserved or invalid):\n";
 433             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 434         }
 435     }
 436
 437     return $output;
 438 }
 439
 440 # -------------------------------------------------------------------
 441 sub mk_name {
 442     my $basename      = shift || '';
 443     my $type          = shift || '';
 444     my $scope         = shift || '';
 445     my $critical      = shift || '';
 446     my $basename_orig = $basename;
 447     my $max_name      = $type
 448                         ? $max_id_length - (length($type) + 1)
 449                         : $max_id_length;
 450     $basename         = substr( $basename, 0, $max_name )
 451                         if length( $basename ) > $max_name;
 452     my $name          = $type ? "${type}_$basename" : $basename;
 453
 454     if ( $basename ne $basename_orig and $critical ) {
 455         my $show_type = $type ? "+'$type'" : "";
 456         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 457             "character limit to make '$name'\n" if $WARN;
 458         $truncated{ $basename_orig } = $name;
 459     }
 460
 461     $scope ||= \%global_names;
 462     if ( my $prev = $scope->{ $name } ) {
 463         my $name_orig = $name;
 464         $name        .= sprintf( "%02d", ++$prev );
 465         substr($name, $max_id_length - 3) = "00"
 466             if length( $name ) > $max_id_length;
 467
 468         warn "The name '$name_orig' has been changed to ",
 469              "'$name' to make it unique.\n" if $WARN;
 470
 471         $scope->{ $name_orig }++;
 472     }
 473
 474     $scope->{ $name }++;
 475     return $name;
 476 }
 477
 478 # -------------------------------------------------------------------
 479 sub unreserve {
 480     my $name            = shift || '';
 481     my $schema_obj_name = shift || '';
 482
 483     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 484
 485     # also trap fields that don't begin with a letter
 486     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 487
 488     if ( $schema_obj_name ) {
 489         ++$unreserve{"$schema_obj_name.$name"};
 490     }
 491     else {
 492         ++$unreserve{"$name (table name)"};
 493     }
 494
 495     my $unreserve = sprintf '%s_', $name;
 496     return $unreserve.$suffix;
 497 }
 498
 499 # -------------------------------------------------------------------
 500 sub next_unused_name {
 501     my $name       = shift || '';
 502     my $used_names = shift || '';
 503
 504     my %used_names = %$used_names;
 505
 506     if ( !defined($used_names{$name}) ) {
 507         $used_names{$name} = $name;
 508         return $name;
 509     }
 510
 511     my $i = 2;
 512     while ( defined($used_names{$name . $i}) ) {
 513         ++$i;
 514     }
 515     $name .= $i;
 516     $used_names{$name} = $name;
 517     return $name;
 518 }
 519
 520 1;
 521
 522 # -------------------------------------------------------------------
 523 # Life is full of misery, loneliness, and suffering --
 524 # and it's all over much too soon.
 525 # Woody Allen
 526 # -------------------------------------------------------------------
 527
 528 =pod
 529
 530 =head1 SEE ALSO
 531
 532 SQL::Translator, SQL::Translator::Producer::Oracle.
 533
 534 =head1 AUTHOR
 535
 536 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 537
 538 =cut