lib/SQL/Translator/Producer/PostgreSQL.pm

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