lib/SQL/Translator/Producer/PostgreSQL.pm

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