lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.16 2003-09-04 15:33:24 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.16 $ =~ /(\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       => '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       => '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] > 13 ) {
 241                     $size[0] = 13;
 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
 275             #
 276             my $default = $field->default_value;
 277             if ( defined $default ) {
 278                 $field_def .= sprintf( ' DEFAULT %s',
 279                     ( $field->is_auto_increment && $seq_name )
 280                     ? qq[nextval('"$seq_name"'::text)] :
 281                     ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
 282                 );
 283             }
 284
 285             #
 286             # Not null constraint
 287             #
 288             $field_def .= ' NOT NULL' unless $field->is_nullable;
 289
 290             push @field_defs, $field_def;
 291         }
 292
 293         #
 294         # Index Declarations
 295         #
 296         my @index_defs = ();
 297         my $idx_name_default;
 298         for my $index ( $table->get_indices ) {
 299             my $name = $index->name || '';
 300             my $type = $index->type || NORMAL;
 301             my @fields     =
 302                 map { $_ =~ s/\(.+\)//; $_ }
 303                 map { unreserve( $_, $table_name ) }
 304                 $index->fields;
 305             next unless @fields;
 306
 307             if ( $type eq PRIMARY_KEY ) {
 308                 $name ||= mk_name( $table_name, 'pk' );
 309                 $name = next_unused_name($name, \%used_index_names);
 310                 # how do I get next_unused_name() to do: ?
 311                 $used_index_names{$name} = $name;
 312                 push @constraint_defs, 'Constraint "'.$name.'" PRIMARY KEY '.
 313                     '("' . join( '", "', @fields ) . '")';
 314             }
 315             elsif ( $type eq UNIQUE ) {
 316                 $name ||= mk_name(
 317                     $table_name, $name || ++$idx_name_default
 318                 );
 319                 $name = next_unused_name($name, \%used_index_names);
 320                 $used_index_names{$name} = $name;
 321                 push @constraint_defs, 'Constraint "' . $name . '" UNIQUE ' .
 322                     '("' . join( '", "', @fields ) . '")';
 323             }
 324             elsif ( $type eq NORMAL ) {
 325                 $name ||= mk_name(
 326                     $table_name, $name || ++$idx_name_default
 327                 );
 328                 $name = next_unused_name($name, \%used_index_names);
 329                 $used_index_names{$name} = $name;
 330                 push @index_defs,
 331                     qq[CREATE INDEX "$name" on $table_name_ur ("].
 332                         join( '", "', @fields ).
 333                     '");';
 334             }
 335             else {
 336                 warn "Unknown index type ($type) on table $table_name.\n"
 337                     if $WARN;
 338             }
 339         }
 340
 341         #
 342         # Table constraints
 343         #
 344         my $c_name_default;
 345         for my $c ( $table->get_constraints ) {
 346             my $name = $c->name || '';
 347             my @fields     =
 348                 map { $_ =~ s/\(.+\)//; $_ }
 349                 map { unreserve( $_, $table_name ) }
 350                 $c->fields;
 351             my @rfields     =
 352                 map { $_ =~ s/\(.+\)//; $_ }
 353                 map { unreserve( $_, $table_name ) }
 354                 $c->reference_fields;
 355             next if !@fields && $c->type ne CHECK_C;
 356
 357             if ( $c->type eq PRIMARY_KEY ) {
 358                 $name ||= mk_name( $table_name, 'pk' );
 359                 $name = next_unused_name($name, \%used_index_names);
 360                 $used_index_names{$name} = $name;
 361                 push @constraint_defs, qq[Constraint "$name" PRIMARY KEY ].
 362                     '("' . join( '", "', @fields ) . '")';
 363             }
 364             elsif ( $c->type eq UNIQUE ) {
 365                 $name ||= mk_name(
 366                     $table_name, $name || ++$c_name_default
 367                 );
 368                 $name = next_unused_name($name, \%used_index_names);
 369                 $used_index_names{$name} = $name;
 370                 push @constraint_defs, qq[Constraint "$name" UNIQUE ] .
 371                     '("' . join( '", "', @fields ) . '")';
 372             }
 373             elsif ( $c->type eq CHECK_C ) {
 374                 my $s;
 375                 if ( $name ) {
 376                     $name ||= mk_name(
 377                         $table_name, $name || ++$c_name_default
 378                     );
 379                     $name = next_unused_name($name, \%used_index_names);
 380                     $used_index_names{$name} = $name;
 381                     $s = 'Constraint "$name" ';
 382                 }
 383                 my $expression = $c->expression;
 384                 push @constraint_defs, "${s}CHECK ($expression)";
 385             }
 386             elsif ( $c->type eq FOREIGN_KEY ) {
 387                 my $def = join(' ',
 388                     map { $_ || () } 'FOREIGN KEY', $c->name
 389                 );
 390
 391                 $def .= ' ("' . join( '", "', @fields ) . '")';
 392
 393                 $def .= ' REFERENCES ' . $c->reference_table;
 394
 395                 if ( @rfields ) {
 396                     $def .= ' ("' . join( '", "', @rfields ) . '")';
 397                 }
 398
 399                 if ( $c->match_type ) {
 400                     $def .= ' MATCH ' .
 401                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 402                 }
 403
 404                 if ( $c->on_delete ) {
 405                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 406                 }
 407
 408                 if ( $c->on_update ) {
 409                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 410                 }
 411
 412                 push @constraint_defs, $def;
 413             }
 414         }
 415
 416         my $create_statement;
 417         $create_statement  = qq[DROP TABLE "$table_name_ur";\n]
 418             if $add_drop_table;
 419         $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
 420             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
 421             "\n);"
 422         ;
 423
 424         $output .= join( "\n\n",
 425             @comments,
 426             @sequence_defs,
 427             $create_statement,
 428             @index_defs,
 429             ''
 430         );
 431     }
 432
 433     if ( $WARN ) {
 434         if ( %truncated ) {
 435             warn "Truncated " . keys( %truncated ) . " names:\n";
 436             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 437         }
 438
 439         if ( %unreserve ) {
 440             warn "Encounted " . keys( %unreserve ) .
 441                 " unsafe names in schema (reserved or invalid):\n";
 442             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 443         }
 444     }
 445
 446     return $output;
 447 }
 448
 449 # -------------------------------------------------------------------
 450 sub mk_name {
 451     my $basename      = shift || '';
 452     my $type          = shift || '';
 453     my $scope         = shift || '';
 454     my $critical      = shift || '';
 455     my $basename_orig = $basename;
 456     my $max_name      = $type
 457                         ? $max_id_length - (length($type) + 1)
 458                         : $max_id_length;
 459     $basename         = substr( $basename, 0, $max_name )
 460                         if length( $basename ) > $max_name;
 461     my $name          = $type ? "${type}_$basename" : $basename;
 462
 463     if ( $basename ne $basename_orig and $critical ) {
 464         my $show_type = $type ? "+'$type'" : "";
 465         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 466             "character limit to make '$name'\n" if $WARN;
 467         $truncated{ $basename_orig } = $name;
 468     }
 469
 470     $scope ||= \%global_names;
 471     if ( my $prev = $scope->{ $name } ) {
 472         my $name_orig = $name;
 473         $name        .= sprintf( "%02d", ++$prev );
 474         substr($name, $max_id_length - 3) = "00"
 475             if length( $name ) > $max_id_length;
 476
 477         warn "The name '$name_orig' has been changed to ",
 478              "'$name' to make it unique.\n" if $WARN;
 479
 480         $scope->{ $name_orig }++;
 481     }
 482
 483     $scope->{ $name }++;
 484     return $name;
 485 }
 486
 487 # -------------------------------------------------------------------
 488 sub unreserve {
 489     my $name            = shift || '';
 490     my $schema_obj_name = shift || '';
 491
 492     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 493
 494     # also trap fields that don't begin with a letter
 495     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 496
 497     if ( $schema_obj_name ) {
 498         ++$unreserve{"$schema_obj_name.$name"};
 499     }
 500     else {
 501         ++$unreserve{"$name (table name)"};
 502     }
 503
 504     my $unreserve = sprintf '%s_', $name;
 505     return $unreserve.$suffix;
 506 }
 507
 508 # -------------------------------------------------------------------
 509 sub next_unused_name {
 510     my $name       = shift || '';
 511     my $used_names = shift || '';
 512
 513     my %used_names = %$used_names;
 514
 515     if ( !defined($used_names{$name}) ) {
 516         $used_names{$name} = $name;
 517         return $name;
 518     }
 519
 520     my $i = 2;
 521     while ( defined($used_names{$name . $i}) ) {
 522         ++$i;
 523     }
 524     $name .= $i;
 525     $used_names{$name} = $name;
 526     return $name;
 527 }
 528
 529 1;
 530
 531 # -------------------------------------------------------------------
 532 # Life is full of misery, loneliness, and suffering --
 533 # and it's all over much too soon.
 534 # Woody Allen
 535 # -------------------------------------------------------------------
 536
 537 =pod
 538
 539 =head1 AUTHOR
 540
 541 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 542
 543 =cut