lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.4 2002-12-04 01:53:51 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.4 $ =~ /(\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    => 'character varying',
  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       => 'character varying',
  60     set        => 'character varying',
  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   => 'character varying',
  73     long       => 'text',
  74     CLOB       => 'bytea',
  75     date       => 'date',
  76
  77     #
  78     # Sybase types
  79     #
  80     int        => 'integer',
  81     money      => 'money',
  82     varchar    => 'character varying',
  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 =head1 Create Index Syntax
 147
 148   CREATE [ UNIQUE ] INDEX index_name ON table
 149       [ USING acc_method ] ( column [ ops_name ] [, ...] )
 150       [ WHERE predicate ]
 151   CREATE [ UNIQUE ] INDEX index_name ON table
 152       [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
 153       [ WHERE predicate ]
 154
 155 =cut
 156
 157 # -------------------------------------------------------------------
 158 sub produce {
 159     my ( $translator, $data ) = @_;
 160     $DEBUG                    = $translator->debug;
 161     $WARN                     = $translator->show_warnings;
 162     my $no_comments           = $translator->no_comments;
 163     my $add_drop_table        = $translator->add_drop_table;
 164
 165     my $output;
 166     unless ( $no_comments ) {
 167         $output .=  sprintf
 168             "--\n-- Created by %s\n-- Created on %s\n--\n\n",
 169             __PACKAGE__, scalar localtime;
 170     }
 171
 172     for my $table (
 173         map  { $_->[1] }
 174         sort { $a->[0] <=> $b->[0] }
 175         map  { [ $_->{'order'}, $_ ] }
 176         values %$data
 177    ) {
 178         my $table_name    = $table->{'table_name'};
 179         $table_name       = mk_name( $table_name, '', undef, 1 );
 180         my $table_name_ur = unreserve($table_name);
 181
 182         my ( @comments, @field_decs, @sequence_decs, @constraints );
 183
 184         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 185
 186         #
 187         # Fields
 188         #
 189         my %field_name_scope;
 190         for my $field (
 191             map  { $_->[1] }
 192             sort { $a->[0] <=> $b->[0] }
 193             map  { [ $_->{'order'}, $_ ] }
 194             values %{ $table->{'fields'} }
 195         ) {
 196             my $field_name    = mk_name(
 197                 $field->{'name'}, '', \%field_name_scope, 1
 198             );
 199             my $field_name_ur = unreserve( $field_name, $table_name );
 200             my $field_str     = qq["$field_name_ur"];
 201
 202             #
 203             # Datatype
 204             #
 205             my $data_type = lc $field->{'data_type'};
 206             my $list      = $field->{'list'} || [];
 207             my $commalist = join ",", @$list;
 208             my $seq_name;
 209
 210             if ( $data_type eq 'enum' ) {
 211                 my $len = 0;
 212                 $len = ($len < length($_)) ? length($_) : $len for (@$list);
 213                 my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
 214                 push @constraints,
 215                 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
 216                 $field_str .= " character varying($len)";
 217             }
 218             elsif ( $data_type eq 'set' ) {
 219                 # XXX add a CHECK constraint maybe
 220                 # (trickier and slower, than enum :)
 221                 my $len     = length $commalist;
 222                 $field_str .= " character varying($len) /* set $commalist */";
 223             }
 224             elsif ( $field->{'is_auto_inc'} ) {
 225                 $field_str .= ' serial';
 226                 $seq_name   = mk_name( $table_name.'_'.$field_name, 'sq' );
 227                 push @sequence_decs, qq[DROP SEQUENCE "$seq_name";];
 228                 push @sequence_decs, qq[CREATE SEQUENCE "$seq_name";];
 229             }
 230             else {
 231                 $data_type  = defined $translate{ $data_type } ?
 232                               $translate{ $data_type } :
 233                               die "Unknown datatype: $data_type\n";
 234                 $field_str .= ' '.$data_type;
 235                 if ( $data_type =~ /(char|varbit|numeric|decimal)/i ) {
 236                     $field_str .= '('.join(',', @{ $field->{'size'} }).')'
 237                         if @{ $field->{'size'} || [] };
 238                 }
 239             }
 240
 241             #
 242             # Default value
 243             #
 244             if ( defined $field->{'default'} ) {
 245                 $field_str .= sprintf( ' DEFAULT %s',
 246                     ( $field->{'is_auto_inc'} && $seq_name )
 247                     ? qq[nextval('"$seq_name"'::text)] :
 248                     ( $field->{'default'} =~ m/null/i )
 249                     ? 'NULL' :
 250                     "'".$field->{'default'}."'"
 251                 );
 252             }
 253
 254             #
 255             # Not null constraint
 256             #
 257             unless ( $field->{'null'} ) {
 258                 my $constraint_name = mk_name($field_name_ur, 'nn');
 259 #                $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
 260                 $field_str .= ' NOT NULL';
 261             }
 262
 263             #
 264             # Primary key
 265             #
 266 #            if ( $field->{'is_primary_key'} ) {
 267 #                my $constraint_name = mk_name($field_name_ur, 'pk');
 268 #                $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
 269 #            }
 270
 271             push @field_decs, $field_str;
 272         }
 273
 274         #
 275         # Index Declarations
 276         #
 277         my @index_decs = ();
 278         my $idx_name_default;
 279         for my $index ( @{ $table->{'indices'} } ) {
 280             my $index_name = $index->{'name'} || '';
 281             my $index_type = $index->{'type'} || 'normal';
 282             my @fields     = 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      = $max_id_length - (length($type) + 1);
 351     $basename         = substr( $basename, 0, $max_name )
 352                         if length( $basename ) > $max_name;
 353     my $name          = $type ? "${type}_$basename" : $basename;
 354
 355     if ( $basename ne $basename_orig and $critical ) {
 356         my $show_type = $type ? "+'$type'" : "";
 357         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 358             "character limit to make '$name'\n" if $WARN;
 359         $truncated{ $basename_orig } = $name;
 360     }
 361
 362     $scope ||= \%global_names;
 363     if ( my $prev = $scope->{ $name } ) {
 364         my $name_orig = $name;
 365         $name        .= sprintf( "%02d", ++$prev );
 366         substr($name, $max_id_length - 3) = "00"
 367             if length( $name ) > $max_id_length;
 368
 369         warn "The name '$name_orig' has been changed to ",
 370              "'$name' to make it unique.\n" if $WARN;
 371
 372         $scope->{ $name_orig }++;
 373     }
 374
 375     $scope->{ $name }++;
 376     return $name;
 377 }
 378
 379 # -------------------------------------------------------------------
 380 sub unreserve {
 381     my ( $name, $schema_obj_name ) = @_;
 382     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 383
 384     # also trap fields that don't begin with a letter
 385     return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 386
 387     if ( $schema_obj_name ) {
 388         ++$unreserve{"$schema_obj_name.$name"};
 389     }
 390     else {
 391         ++$unreserve{"$name (table name)"};
 392     }
 393
 394     my $unreserve = sprintf '%s_', $name;
 395     return $unreserve.$suffix;
 396 }
 397
 398 1;
 399
 400 # -------------------------------------------------------------------
 401 # Life is full of misery, loneliness, and suffering --
 402 # and it's all over much too soon.
 403 # Woody Allen
 404 # -------------------------------------------------------------------
 405
 406 =pod
 407
 408 =head1 AUTHOR
 409
 410 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 411
 412 =cut