lib/SQL/Translator/Producer/PostgreSQL.pm

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