lib/SQL/Translator/Producer/PostgreSQL.pm

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