lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.8 2003-04-25 11:47:25 dlc 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.8 $ =~ /(\d+)\.(\d+)/;
  34 $DEBUG = 1 unless defined $DEBUG;
  35
  36 use SQL::Translator::Utils qw(header_comment);
  37 use Data::Dumper;
  38
  39 my %translate  = (
  40     #
  41     # MySQL types
  42     #
  43     bigint     => 'bigint',
  44     double     => 'double precision',
  45     decimal    => 'decimal',
  46     float      => 'double precision',
  47     int        => 'integer',
  48     mediumint  => 'integer',
  49     smallint   => 'smallint',
  50     tinyint    => 'smallint',
  51     char       => 'char',
  52     varchar    => 'character varying',
  53     longtext   => 'text',
  54     mediumtext => 'text',
  55     text       => 'text',
  56     tinytext   => 'text',
  57     tinyblob   => 'bytea',
  58     blob       => 'bytea',
  59     mediumblob => 'bytea',
  60     longblob   => 'bytea',
  61     enum       => 'character varying',
  62     set        => 'character varying',
  63     date       => 'date',
  64     datetime   => 'timestamp',
  65     time       => 'date',
  66     timestamp  => 'timestamp',
  67     year       => 'date',
  68
  69     #
  70     # Oracle types
  71     #
  72     number     => 'integer',
  73     char       => 'char',
  74     varchar2   => 'character varying',
  75     long       => 'text',
  76     CLOB       => 'bytea',
  77     date       => 'date',
  78
  79     #
  80     # Sybase types
  81     #
  82     int        => 'integer',
  83     money      => 'money',
  84     varchar    => 'character varying',
  85     datetime   => 'timestamp',
  86     text       => 'text',
  87     real       => 'double precision',
  88     comment    => 'text',
  89     bit        => 'bit',
  90     tinyint    => 'smallint',
  91     float      => 'double precision',
  92 );
  93
  94 my %reserved = map { $_, 1 } qw[
  95     ALL ANALYSE ANALYZE AND ANY AS ASC
  96     BETWEEN BINARY BOTH
  97     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  98     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  99     DEFAULT DEFERRABLE DESC DISTINCT DO
 100     ELSE END EXCEPT
 101     FALSE FOR FOREIGN FREEZE FROM FULL
 102     GROUP HAVING
 103     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
 104     JOIN LEADING LEFT LIKE LIMIT
 105     NATURAL NEW NOT NOTNULL NULL
 106     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
 107     PRIMARY PUBLIC REFERENCES RIGHT
 108     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
 109     UNION UNIQUE USER USING VERBOSE WHEN WHERE
 110 ];
 111
 112 my $max_id_length    = 30;
 113 my %used_identifiers = ();
 114 my %global_names;
 115 my %unreserve;
 116 my %truncated;
 117
 118 =pod
 119
 120 =head1 PostgreSQL Create Table Syntax
 121
 122   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
 123       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
 124       | table_constraint }  [, ... ]
 125   )
 126   [ INHERITS ( parent_table [, ... ] ) ]
 127   [ WITH OIDS | WITHOUT OIDS ]
 128
 129 where column_constraint is:
 130
 131   [ CONSTRAINT constraint_name ]
 132   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
 133     CHECK (expression) |
 134     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
 135       [ ON DELETE action ] [ ON UPDATE action ] }
 136   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 137
 138 and table_constraint is:
 139
 140   [ CONSTRAINT constraint_name ]
 141   { UNIQUE ( column_name [, ... ] ) |
 142     PRIMARY KEY ( column_name [, ... ] ) |
 143     CHECK ( expression ) |
 144     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 145       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 146   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 147
 148 =head1 Create Index Syntax
 149
 150   CREATE [ UNIQUE ] INDEX index_name ON table
 151       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 152       [ WHERE predicate ]
 153   CREATE [ UNIQUE ] INDEX index_name ON table
 154       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 155       [ WHERE predicate ]
 156
 157 =cut
 158
 159 # -------------------------------------------------------------------
 160 sub produce {
 161     my ( $translator, $data ) = @_;
 162     $DEBUG                    = $translator->debug;
 163     $WARN                     = $translator->show_warnings;
 164     my $no_comments           = $translator->no_comments;
 165     my $add_drop_table        = $translator->add_drop_table;
 166
 167     my $output;
 168     $output .= header_comment unless ($no_comments);
 169
 170     for my $table (
 171         map  { $_->[1] }
 172         sort { $a->[0] <=> $b->[0] }
 173         map  { [ $_->{'order'}, $_ ] }
 174         values %$data
 175    ) {
 176         my $table_name    = $table->{'table_name'};
 177         $table_name       = mk_name( $table_name, '', undef, 1 );
 178         my $table_name_ur = unreserve($table_name);
 179
 180         my ( @comments, @field_decs, @sequence_decs, @constraints );
 181
 182         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 183
 184         #
 185         # Fields
 186         #
 187         my %field_name_scope;
 188         for my $field (
 189             map  { $_->[1] }
 190             sort { $a->[0] <=> $b->[0] }
 191             map  { [ $_->{'order'}, $_ ] }
 192             values %{ $table->{'fields'} }
 193         ) {
 194             my $field_name    = mk_name(
 195                 $field->{'name'}, '', \%field_name_scope, 1
 196             );
 197             my $field_name_ur = unreserve( $field_name, $table_name );
 198             my $field_str     = qq["$field_name_ur"];
 199
 200             #
 201             # Datatype
 202             #
 203             my $data_type = lc $field->{'data_type'};
 204             my $list      = $field->{'list'} || [];
 205             my $commalist = join ",", @$list;
 206             my $seq_name;
 207
 208             if ( $data_type eq 'enum' ) {
 209                 my $len = 0;
 210                 $len = ($len < length($_)) ? length($_) : $len for (@$list);
 211                 my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 212                 push @constraints,
 213                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 214                 $field_str .= " character varying($len)";
 215             }
 216             elsif ( $data_type eq 'set' ) {
 217                 # XXX add a CHECK constraint maybe
 218                 # (trickier and slower, than enum :)
 219                 my $len     = length $commalist;
 220                 $field_str .= " character varying($len) /* set $commalist */";
 221             }
 222             elsif ( $field->{'is_auto_inc'} ) {
 223                 $field_str .= ' serial';
 224                 $seq_name   = mk_name( $table_name.'_'.$field_name, 'sq' );
 225                 push @sequence_decs, qq[DROP SEQUENCE "$seq_name";];
 226                 push @sequence_decs, qq[CREATE SEQUENCE "$seq_name";];
 227             }
 228             else {
 229                 $data_type  = defined $translate{ $data_type } ?
 230                               $translate{ $data_type } :
 231                               die "Unknown datatype: $data_type\n";
 232                 $field_str .= ' '.$data_type;
 233                 if ( $data_type =~ /(char|varbit|numeric|decimal)/i ) {
 234                     $field_str .= '('.join(',', @{ $field->{'size'} }).')'
 235                         if @{ $field->{'size'} || [] };
 236                 }
 237             }
 238
 239             #
 240             # Default value
 241             #
 242             if ( defined $field->{'default'} ) {
 243                 $field_str .= sprintf( ' DEFAULT %s',
 244                     ( $field->{'is_auto_inc'} && $seq_name )
 245                     ? qq[nextval('"$seq_name"'::text)] :
 246                     ( $field->{'default'} =~ m/null/i )
 247                     ? 'NULL' :
 248                     "'".$field->{'default'}."'"
 249                 );
 250             }
 251
 252             #
 253             # Not null constraint
 254             #
 255             unless ( $field->{'null'} ) {
 256                 my $constraint_name = mk_name($field_name_ur, 'nn');
 257 #                $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
 258                 $field_str .= ' NOT NULL';
 259             }
 260
 261             #
 262             # Primary key
 263             #
 264 #            if ( $field->{'is_primary_key'} ) {
 265 #                my $constraint_name = mk_name($field_name_ur, 'pk');
 266 #                $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
 267 #            }
 268
 269             push @field_decs, $field_str;
 270         }
 271
 272         #
 273         # Index Declarations
 274         #
 275         my @index_decs = ();
 276         my $idx_name_default;
 277         for my $index ( @{ $table->{'indices'} } ) {
 278             my $index_name = $index->{'name'} || '';
 279             my $index_type = $index->{'type'} || 'normal';
 280             my @fields     =
 281                 map { $_ =~ s/\(.+\)//; $_ }
 282                 map { unreserve( $_, $table_name ) }
 283                 @{ $index->{'fields'} };
 284             next unless @fields;
 285
 286             if ( $index_type eq 'primary_key' ) {
 287                 $index_name = mk_name( $table_name, 'pk' );
 288                 push @constraints, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 289                     '(' . join( ', ', @fields ) . ')';
 290             }
 291             elsif ( $index_type eq 'unique' ) {
 292                 $index_name = mk_name(
 293                     $table_name, $index_name || ++$idx_name_default
 294                 );
 295                 push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 296                     '(' . join( ', ', @fields ) . ')';
 297             }
 298             elsif ( $index_type eq 'normal' ) {
 299                 $index_name = mk_name(
 300                     $table_name, $index_name || ++$idx_name_default
 301                 );
 302                 push @index_decs,
 303                     qq[CREATE INDEX "$index_name" on $table_name_ur (].
 304                         join( ', ', @fields ).
 305                     ');';
 306             }
 307             else {
 308                 warn "Unknown index type ($index_type) on table $table_name.\n"
 309                     if $WARN;
 310             }
 311         }
 312
 313         my $create_statement;
 314         $create_statement  = qq[DROP TABLE "$table_name_ur";\n]
 315             if $add_drop_table;
 316         $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
 317             join( ",\n", map { "  $_" } @field_decs, @constraints ).
 318             "\n);"
 319         ;
 320
 321         $output .= join( "\n\n",
 322             @comments,
 323             @sequence_decs,
 324             $create_statement,
 325             @index_decs,
 326             ''
 327         );
 328     }
 329
 330     if ( $WARN ) {
 331         if ( %truncated ) {
 332             warn "Truncated " . keys( %truncated ) . " names:\n";
 333             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 334         }
 335
 336         if ( %unreserve ) {
 337             warn "Encounted " . keys( %unreserve ) .
 338                 " unsafe names in schema (reserved or invalid):\n";
 339             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 340         }
 341     }
 342
 343     return $output;
 344 }
 345
 346 # -------------------------------------------------------------------
 347 sub mk_name {
 348     my ($basename, $type, $scope, $critical) = @_;
 349     my $basename_orig = $basename;
 350     my $max_name      = $type
 351                         ? $max_id_length - (length($type) + 1)
 352                         : $max_id_length;
 353     $basename         = substr( $basename, 0, $max_name )
 354                         if length( $basename ) > $max_name;
 355     my $name          = $type ? "${type}_$basename" : $basename;
 356
 357     if ( $basename ne $basename_orig and $critical ) {
 358         my $show_type = $type ? "+'$type'" : "";
 359         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 360             "character limit to make '$name'\n" if $WARN;
 361         $truncated{ $basename_orig } = $name;
 362     }
 363
 364     $scope ||= \%global_names;
 365     if ( my $prev = $scope->{ $name } ) {
 366         my $name_orig = $name;
 367         $name        .= sprintf( "%02d", ++$prev );
 368         substr($name, $max_id_length - 3) = "00"
 369             if length( $name ) > $max_id_length;
 370
 371         warn "The name '$name_orig' has been changed to ",
 372              "'$name' to make it unique.\n" if $WARN;
 373
 374         $scope->{ $name_orig }++;
 375     }
 376
 377     $scope->{ $name }++;
 378     return $name;
 379 }
 380
 381 # -------------------------------------------------------------------
 382 sub unreserve {
 383     my ( $name, $schema_obj_name ) = @_;
 384     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 385
 386     # also trap fields that don't begin with a letter
 387     return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 388
 389     if ( $schema_obj_name ) {
 390         ++$unreserve{"$schema_obj_name.$name"};
 391     }
 392     else {
 393         ++$unreserve{"$name (table name)"};
 394     }
 395
 396     my $unreserve = sprintf '%s_', $name;
 397     return $unreserve.$suffix;
 398 }
 399
 400 1;
 401
 402 # -------------------------------------------------------------------
 403 # Life is full of misery, loneliness, and suffering --
 404 # and it's all over much too soon.
 405 # Woody Allen
 406 # -------------------------------------------------------------------
 407
 408 =pod
 409
 410 =head1 AUTHOR
 411
 412 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 413
 414 =cut