lib/SQL/Translator/Producer/PostgreSQL.pm

   1 package SQL::Translator::Producer::PostgreSQL;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: PostgreSQL.pm,v 1.7 2003-03-07 16:08:22 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.7 $ =~ /(\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     =
 284                 map { $_ =~ s/\(.+\)//; $_ }
 285                 map { unreserve( $_, $table_name ) }
 286                 @{ $index->{'fields'} };
 287             next unless @fields;
 288
 289             if ( $index_type eq 'primary_key' ) {
 290                 $index_name = mk_name( $table_name, 'pk' );
 291                 push @constraints, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 292                     '(' . join( ', ', @fields ) . ')';
 293             }
 294             elsif ( $index_type eq 'unique' ) {
 295                 $index_name = mk_name(
 296                     $table_name, $index_name || ++$idx_name_default
 297                 );
 298                 push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 299                     '(' . join( ', ', @fields ) . ')';
 300             }
 301             elsif ( $index_type eq 'normal' ) {
 302                 $index_name = mk_name(
 303                     $table_name, $index_name || ++$idx_name_default
 304                 );
 305                 push @index_decs,
 306                     qq[CREATE INDEX "$index_name" on $table_name_ur (].
 307                         join( ', ', @fields ).
 308                     ');';
 309             }
 310             else {
 311                 warn "Unknown index type ($index_type) on table $table_name.\n"
 312                     if $WARN;
 313             }
 314         }
 315
 316         my $create_statement;
 317         $create_statement  = qq[DROP TABLE "$table_name_ur";\n]
 318             if $add_drop_table;
 319         $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
 320             join( ",\n", map { "  $_" } @field_decs, @constraints ).
 321             "\n);"
 322         ;
 323
 324         $output .= join( "\n\n",
 325             @comments,
 326             @sequence_decs,
 327             $create_statement,
 328             @index_decs,
 329             ''
 330         );
 331     }
 332
 333     if ( $WARN ) {
 334         if ( %truncated ) {
 335             warn "Truncated " . keys( %truncated ) . " names:\n";
 336             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 337         }
 338
 339         if ( %unreserve ) {
 340             warn "Encounted " . keys( %unreserve ) .
 341                 " unsafe names in schema (reserved or invalid):\n";
 342             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 343         }
 344     }
 345
 346     return $output;
 347 }
 348
 349 # -------------------------------------------------------------------
 350 sub mk_name {
 351     my ($basename, $type, $scope, $critical) = @_;
 352     my $basename_orig = $basename;
 353     my $max_name      = $type
 354                         ? $max_id_length - (length($type) + 1)
 355                         : $max_id_length;
 356     $basename         = substr( $basename, 0, $max_name )
 357                         if length( $basename ) > $max_name;
 358     my $name          = $type ? "${type}_$basename" : $basename;
 359
 360     if ( $basename ne $basename_orig and $critical ) {
 361         my $show_type = $type ? "+'$type'" : "";
 362         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 363             "character limit to make '$name'\n" if $WARN;
 364         $truncated{ $basename_orig } = $name;
 365     }
 366
 367     $scope ||= \%global_names;
 368     if ( my $prev = $scope->{ $name } ) {
 369         my $name_orig = $name;
 370         $name        .= sprintf( "%02d", ++$prev );
 371         substr($name, $max_id_length - 3) = "00"
 372             if length( $name ) > $max_id_length;
 373
 374         warn "The name '$name_orig' has been changed to ",
 375              "'$name' to make it unique.\n" if $WARN;
 376
 377         $scope->{ $name_orig }++;
 378     }
 379
 380     $scope->{ $name }++;
 381     return $name;
 382 }
 383
 384 # -------------------------------------------------------------------
 385 sub unreserve {
 386     my ( $name, $schema_obj_name ) = @_;
 387     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 388
 389     # also trap fields that don't begin with a letter
 390     return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
 391
 392     if ( $schema_obj_name ) {
 393         ++$unreserve{"$schema_obj_name.$name"};
 394     }
 395     else {
 396         ++$unreserve{"$name (table name)"};
 397     }
 398
 399     my $unreserve = sprintf '%s_', $name;
 400     return $unreserve.$suffix;
 401 }
 402
 403 1;
 404
 405 # -------------------------------------------------------------------
 406 # Life is full of misery, loneliness, and suffering --
 407 # and it's all over much too soon.
 408 # Woody Allen
 409 # -------------------------------------------------------------------
 410
 411 =pod
 412
 413 =head1 AUTHOR
 414
 415 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 416
 417 =cut