lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.18 2003-09-26 22:48:53 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.18 $ =~ /(\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     $output .= join( "\n\n", @fks );
 410
 411     if ( $WARN ) {
 412         if ( %truncated ) {
 413             warn "Truncated " . keys( %truncated ) . " names:\n";
 414             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 415         }
 416
 417         if ( %unreserve ) {
 418             warn "Encounted " . keys( %unreserve ) .
 419                 " unsafe names in schema (reserved or invalid):\n";
 420             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 421         }
 422     }
 423
 424     return $output;
 425 }
 426
 427 # -------------------------------------------------------------------
 428 sub mk_name {
 429     my $basename      = shift || '';
 430     my $type          = shift || '';
 431     my $scope         = shift || '';
 432     my $critical      = shift || '';
 433     my $basename_orig = $basename;
 434     my $max_name      = $type
 435                         ? $max_id_length - (length($type) + 1)
 436                         : $max_id_length;
 437     $basename         = substr( $basename, 0, $max_name )
 438                         if length( $basename ) > $max_name;
 439     my $name          = $type ? "${type}_$basename" : $basename;
 440
 441     if ( $basename ne $basename_orig and $critical ) {
 442         my $show_type = $type ? "+'$type'" : "";
 443         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 444             "character limit to make '$name'\n" if $WARN;
 445         $truncated{ $basename_orig } = $name;
 446     }
 447
 448     $scope ||= \%global_names;
 449     if ( my $prev = $scope->{ $name } ) {
 450         my $name_orig = $name;
 451         $name        .= sprintf( "%02d", ++$prev );
 452         substr($name, $max_id_length - 3) = "00"
 453             if length( $name ) > $max_id_length;
 454
 455         warn "The name '$name_orig' has been changed to ",
 456              "'$name' to make it unique.\n" if $WARN;
 457
 458         $scope->{ $name_orig }++;
 459     }
 460
 461     $scope->{ $name }++;
 462     return $name;
 463 }
 464
 465 # -------------------------------------------------------------------
 466 sub unreserve {
 467     my $name            = shift || '';
 468     my $schema_obj_name = shift || '';
 469
 470     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 471
 472     # also trap fields that don't begin with a letter
 473     return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 474
 475     if ( $schema_obj_name ) {
 476         ++$unreserve{"$schema_obj_name.$name"};
 477     }
 478     else {
 479         ++$unreserve{"$name (table name)"};
 480     }
 481
 482     my $unreserve = sprintf '%s_', $name;
 483     return $unreserve.$suffix;
 484 }
 485
 486 # -------------------------------------------------------------------
 487 sub next_unused_name {
 488     my $name       = shift || '';
 489     my $used_names = shift || '';
 490
 491     my %used_names = %$used_names;
 492
 493     if ( !defined($used_names{$name}) ) {
 494         $used_names{$name} = $name;
 495         return $name;
 496     }
 497
 498     my $i = 2;
 499     while ( defined($used_names{$name . $i}) ) {
 500         ++$i;
 501     }
 502     $name .= $i;
 503     $used_names{$name} = $name;
 504     return $name;
 505 }
 506
 507 1;
 508
 509 # -------------------------------------------------------------------
 510 # Life is full of misery, loneliness, and suffering --
 511 # and it's all over much too soon.
 512 # Woody Allen
 513 # -------------------------------------------------------------------
 514
 515 =pod
 516
 517 =head1 AUTHOR
 518
 519 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 520
 521 =cut