lib/SQL/Translator/Producer/PostgreSQL.pm

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