lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.3 2002-11-26 03:59:58 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License as
  11 # published by the Free Software Foundation; version 2.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  21 # 02111-1307  USA
  22 # -------------------------------------------------------------------
  23
  24 =head1 NAME
  25
  26 SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
  27
  28 =cut
  29
  30 use strict;
  31 use vars qw[ $DEBUG $WARN $VERSION ];
  32 $VERSION = sprintf "%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/;
  33 $DEBUG = 1 unless defined $DEBUG;
  34
  35 use Data::Dumper;
  36
  37 my %translate  = (
  38     #
  39     # MySQL types
  40     #
  41     bigint     => 'bigint',
  42     double     => 'double precision',
  43     decimal    => 'decimal',
  44     float      => 'double precision',
  45     int        => 'integer',
  46     mediumint  => 'integer',
  47     smallint   => 'smallint',
  48     tinyint    => 'smallint',
  49     char       => 'char',
  50     varchar    => 'varchar',
  51     longtext   => 'text',
  52     mediumtext => 'text',
  53     text       => 'text',
  54     tinytext   => 'text',
  55     tinyblob   => 'bytea',
  56     blob       => 'bytea',
  57     mediumblob => 'bytea',
  58     longblob   => 'bytea',
  59     enum       => 'varchar',
  60     set        => 'varchar',
  61     date       => 'date',
  62     datetime   => 'timestamp',
  63     time       => 'date',
  64     timestamp  => 'timestamp',
  65     year       => 'date',
  66
  67     #
  68     # Oracle types
  69     #
  70     number     => 'integer',
  71     char       => 'char',
  72     varchar2   => 'varchar',
  73     long       => 'text',
  74     CLOB       => 'bytea',
  75     date       => 'date',
  76
  77     #
  78     # Sybase types
  79     #
  80     int        => 'integer',
  81     money      => 'money',
  82     varchar    => 'varchar',
  83     datetime   => 'timestamp',
  84     text       => 'text',
  85     real       => 'double precision',
  86     comment    => 'text',
  87     bit        => 'bit',
  88     tinyint    => 'smallint',
  89     float      => 'double precision',
  90 );
  91
  92 my %reserved = map { $_, 1 } qw[
  93     ALL ANALYSE ANALYZE AND ANY AS ASC
  94     BETWEEN BINARY BOTH
  95     CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
  96     CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
  97     DEFAULT DEFERRABLE DESC DISTINCT DO
  98     ELSE END EXCEPT
  99     FALSE FOR FOREIGN FREEZE FROM FULL
 100     GROUP HAVING
 101     ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
 102     JOIN LEADING LEFT LIKE LIMIT
 103     NATURAL NEW NOT NOTNULL NULL
 104     OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
 105     PRIMARY PUBLIC REFERENCES RIGHT
 106     SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
 107     UNION UNIQUE USER USING VERBOSE WHEN WHERE
 108 ];
 109
 110 my $max_id_length    = 30;
 111 my %used_identifiers = ();
 112 my %global_names;
 113 my %unreserve;
 114 my %truncated;
 115
 116 =pod
 117
 118 =head1 PostgreSQL Create Table Syntax
 119
 120   CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
 121       { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
 122       | table_constraint }  [, ... ]
 123   )
 124   [ INHERITS ( parent_table [, ... ] ) ]
 125   [ WITH OIDS | WITHOUT OIDS ]
 126
 127 where column_constraint is:
 128
 129   [ CONSTRAINT constraint_name ]
 130   { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
 131     CHECK (expression) |
 132     REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
 133       [ ON DELETE action ] [ ON UPDATE action ] }
 134   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 135
 136 and table_constraint is:
 137
 138   [ CONSTRAINT constraint_name ]
 139   { UNIQUE ( column_name [, ... ] ) |
 140     PRIMARY KEY ( column_name [, ... ] ) |
 141     CHECK ( expression ) |
 142     FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
 143       [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
 144   [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
 145
 146 =cut
 147
 148 # -------------------------------------------------------------------
 149 sub produce {
 150     my ( $translator, $data ) = @_;
 151     $DEBUG                    = $translator->debug;
 152     $WARN                     = $translator->show_warnings;
 153     my $no_comments           = $translator->no_comments;
 154     my $add_drop_table        = $translator->add_drop_table;
 155
 156     my $create;
 157     unless ( $no_comments ) {
 158         $create .=  sprintf
 159             "--\n-- Created by %s\n-- Created on %s\n--\n\n",
 160             __PACKAGE__, scalar localtime;
 161     }
 162
 163     for my $table (
 164         map  { $_->[1] }
 165         sort { $a->[0] <=> $b->[0] }
 166         map  { [ $_->{'order'}, $_ ] }
 167         values %$data
 168    ) {
 169         my $table_name = $table->{'table_name'};
 170         my @fields     =
 171             map  { $_->[1] }
 172             sort { $a->[0] <=> $b->[0] }
 173             map  { [ $_->{'order'}, $_ ] }
 174             values %{ $table->{'fields'} };
 175
 176         $create .= "--\n-- Table: $table_name\n--\n" unless $no_comments;
 177         $create  = "DROP TABLE $table_name;\n" if $add_drop_table;
 178         $create .= "CREATE TABLE $table_name (\n";
 179
 180         #
 181         # Fields
 182         #
 183         my %field_name_scope;
 184         my @field_statements;
 185         for my $field ( @fields ) {
 186             my @fdata = ("", $field);
 187
 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_str     = $field_name_ur;
 193
 194             # data type and size
 195             push @fdata, sprintf "%s%s",
 196                 $field->{'data_type'},
 197                 ( defined $field->{'size'} )
 198                     ? "($field->{'size'})" : '';
 199
 200             # Null?
 201             push @fdata, "NOT NULL" unless $field->{'null'};
 202
 203             # Default?  XXX Need better quoting!
 204             my $default = $field->{'default'};
 205             if ( defined $default ) {
 206                 push @fdata, "DEFAULT '$default'";
 207 #                if (int $default eq "$default") {
 208 #                    push @fdata, "DEFAULT $default";
 209 #                } else {
 210 #                    push @fdata, "DEFAULT '$default'";
 211 #                }
 212             }
 213
 214             # auto_increment?
 215             push @fdata, "auto_increment" if $field->{'is_auto_inc'};
 216
 217             # primary key?
 218             push @fdata, "PRIMARY KEY" if $field->{'is_primary_key'};
 219
 220             push @field_statements, join( " ", @fdata );
 221
 222         }
 223         $create .= join( ",\n", @field_statements );
 224
 225         #
 226         # Other keys
 227         #
 228         my @indices = @{ $table->{'indices'} || [] };
 229         for ( my $i = 0; $i <= $#indices; $i++ ) {
 230             $create .= ",\n";
 231             my $key = $indices[$i];
 232             my ( $name, $type, $fields ) = @{ $key }{ qw( name type fields ) };
 233             if ( $type eq 'primary_key' ) {
 234                 $create .= " PRIMARY KEY (@{$fields})"
 235             }
 236             else {
 237                 local $" = ", ";
 238                 $create .= " KEY $name (@{$fields})"
 239             }
 240         }
 241
 242         #
 243         # Footer
 244         #
 245         $create .= "\n);\n\n";
 246     }
 247
 248     return $create;
 249 }
 250
 251 # -------------------------------------------------------------------
 252 sub mk_name {
 253     my ($basename, $type, $scope, $critical) = @_;
 254     my $basename_orig = $basename;
 255     my $max_name      = $max_id_length - (length($type) + 1);
 256     $basename         = substr( $basename, 0, $max_name )
 257                         if length( $basename ) > $max_name;
 258     my $name          = $type ? "${type}_$basename" : $basename;
 259
 260     if ( $basename ne $basename_orig and $critical ) {
 261         my $show_type = $type ? "+'$type'" : "";
 262         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 263             "character limit to make '$name'\n" if $WARN;
 264         $truncated{ $basename_orig } = $name;
 265     }
 266
 267     $scope ||= \%global_names;
 268     if ( my $prev = $scope->{ $name } ) {
 269         my $name_orig = $name;
 270         $name        .= sprintf( "%02d", ++$prev );
 271         substr($name, $max_id_length - 3) = "00"
 272             if length( $name ) > $max_id_length;
 273
 274         warn "The name '$name_orig' has been changed to ",
 275              "'$name' to make it unique.\n" if $WARN;
 276
 277         $scope->{ $name_orig }++;
 278     }
 279
 280     $scope->{ $name }++;
 281     return $name;
 282 }
 283
 284 # -------------------------------------------------------------------
 285 sub unreserve {
 286     my ( $name, $schema_obj_name ) = @_;
 287     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 288
 289     # also trap fields that don't begin with a letter
 290     return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 291
 292     if ( $schema_obj_name ) {
 293         ++$unreserve{"$schema_obj_name.$name"};
 294     }
 295     else {
 296         ++$unreserve{"$name (table name)"};
 297     }
 298
 299     my $unreserve = sprintf '%s_', $name;
 300     return $unreserve.$suffix;
 301 }
 302
 303 1;
 304
 305 # -------------------------------------------------------------------
 306 # Life is full of misery, loneliness, and suffering --
 307 # and it's all over much too soon.
 308 # Woody Allen
 309 # -------------------------------------------------------------------
 310
 311 =pod
 312
 313 =head1 AUTHOR
 314
 315 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 316
 317 =cut