lib/SQL/Translator/Producer/PostgreSQL.pm

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