1 package SQL::Translator::Producer::PostgreSQL;
3 # -------------------------------------------------------------------
4 # $Id: PostgreSQL.pm,v 1.5 2003-01-02 17:47:59 kycl4rk Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
7 # darren chamberlain <darren@cpan.org>
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.
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.
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
22 # -------------------------------------------------------------------
26 SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
31 use vars qw[ $DEBUG $WARN $VERSION ];
32 $VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
33 $DEBUG = 1 unless defined $DEBUG;
42 double => 'double precision',
44 float => 'double precision',
46 mediumint => 'integer',
47 smallint => 'smallint',
48 tinyint => 'smallint',
50 varchar => 'character varying',
57 mediumblob => 'bytea',
59 enum => 'character varying',
60 set => 'character varying',
62 datetime => 'timestamp',
64 timestamp => 'timestamp',
72 varchar2 => 'character varying',
82 varchar => 'character varying',
83 datetime => 'timestamp',
85 real => 'double precision',
88 tinyint => 'smallint',
89 float => 'double precision',
92 my %reserved = map { $_, 1 } qw[
93 ALL ANALYSE ANALYZE AND ANY AS ASC
95 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
96 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
97 DEFAULT DEFERRABLE DESC DISTINCT DO
99 FALSE FOR FOREIGN FREEZE FROM FULL
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
110 my $max_id_length = 30;
111 my %used_identifiers = ();
118 =head1 PostgreSQL Create Table Syntax
120 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
121 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
122 | table_constraint } [, ... ]
124 [ INHERITS ( parent_table [, ... ] ) ]
125 [ WITH OIDS | WITHOUT OIDS ]
127 where column_constraint is:
129 [ CONSTRAINT constraint_name ]
130 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
132 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
133 [ ON DELETE action ] [ ON UPDATE action ] }
134 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
136 and table_constraint is:
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 ]
146 =head1 Create Index Syntax
148 CREATE [ UNIQUE ] INDEX index_name ON table
149 [ USING acc_method ] ( column [ ops_name ] [, ...] )
151 CREATE [ UNIQUE ] INDEX index_name ON table
152 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
157 # -------------------------------------------------------------------
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;
166 unless ( $no_comments ) {
168 "--\n-- Created by %s\n-- Created on %s\n--\n\n",
169 __PACKAGE__, scalar localtime;
174 sort { $a->[0] <=> $b->[0] }
175 map { [ $_->{'order'}, $_ ] }
178 my $table_name = $table->{'table_name'};
179 $table_name = mk_name( $table_name, '', undef, 1 );
180 my $table_name_ur = unreserve($table_name);
182 my ( @comments, @field_decs, @sequence_decs, @constraints );
184 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
189 my %field_name_scope;
192 sort { $a->[0] <=> $b->[0] }
193 map { [ $_->{'order'}, $_ ] }
194 values %{ $table->{'fields'} }
196 my $field_name = mk_name(
197 $field->{'name'}, '', \%field_name_scope, 1
199 my $field_name_ur = unreserve( $field_name, $table_name );
200 my $field_str = qq["$field_name_ur"];
205 my $data_type = lc $field->{'data_type'};
206 my $list = $field->{'list'} || [];
207 my $commalist = join ",", @$list;
210 if ( $data_type eq 'enum' ) {
212 $len = ($len < length($_)) ? length($_) : $len for (@$list);
213 my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
215 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
216 $field_str .= " character varying($len)";
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 */";
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";];
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'} || [] };
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 )
250 "'".$field->{'default'}."'"
255 # Not null constraint
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';
266 # if ( $field->{'is_primary_key'} ) {
267 # my $constraint_name = mk_name($field_name_ur, 'pk');
268 # $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
271 push @field_decs, $field_str;
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'} };
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 ) . ')';
291 elsif ( $index_type eq 'unique' ) {
292 $index_name = mk_name(
293 $table_name, $index_name || ++$idx_name_default
295 push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
296 '(' . join( ', ', @fields ) . ')';
298 elsif ( $index_type eq 'normal' ) {
299 $index_name = mk_name(
300 $table_name, $index_name || ++$idx_name_default
303 qq[CREATE INDEX "$index_name" on $table_name_ur (].
304 join( ', ', @fields ).
308 warn "Unknown index type ($index_type) on table $table_name.\n"
313 my $create_statement;
314 $create_statement = qq[DROP TABLE "$table_name_ur";\n]
316 $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
317 join( ",\n", map { " $_" } @field_decs, @constraints ).
321 $output .= join( "\n\n",
332 warn "Truncated " . keys( %truncated ) . " names:\n";
333 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
337 warn "Encounted " . keys( %unreserve ) .
338 " unsafe names in schema (reserved or invalid):\n";
339 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
346 # -------------------------------------------------------------------
348 my ($basename, $type, $scope, $critical) = @_;
349 my $basename_orig = $basename;
351 ? $max_id_length - (length($type) + 1)
353 $basename = substr( $basename, 0, $max_name )
354 if length( $basename ) > $max_name;
355 my $name = $type ? "${type}_$basename" : $basename;
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;
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;
371 warn "The name '$name_orig' has been changed to ",
372 "'$name' to make it unique.\n" if $WARN;
374 $scope->{ $name_orig }++;
381 # -------------------------------------------------------------------
383 my ( $name, $schema_obj_name ) = @_;
384 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
386 # also trap fields that don't begin with a letter
387 return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
389 if ( $schema_obj_name ) {
390 ++$unreserve{"$schema_obj_name.$name"};
393 ++$unreserve{"$name (table name)"};
396 my $unreserve = sprintf '%s_', $name;
397 return $unreserve.$suffix;
402 # -------------------------------------------------------------------
403 # Life is full of misery, loneliness, and suffering --
404 # and it's all over much too soon.
406 # -------------------------------------------------------------------
412 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>