1 package SQL::Translator::Producer::PostgreSQL;
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>
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.
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.
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
23 # -------------------------------------------------------------------
27 SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
32 use vars qw[ $DEBUG $WARN $VERSION ];
33 $VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/;
34 $DEBUG = 1 unless defined $DEBUG;
43 double => 'double precision',
45 float => 'double precision',
47 mediumint => 'integer',
48 smallint => 'smallint',
49 tinyint => 'smallint',
51 varchar => 'character varying',
58 mediumblob => 'bytea',
60 enum => 'character varying',
61 set => 'character varying',
63 datetime => 'timestamp',
65 timestamp => 'timestamp',
73 varchar2 => 'character varying',
83 varchar => 'character varying',
84 datetime => 'timestamp',
86 real => 'double precision',
89 tinyint => 'smallint',
90 float => 'double precision',
93 my %reserved = map { $_, 1 } qw[
94 ALL ANALYSE ANALYZE AND ANY AS ASC
96 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
97 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
98 DEFAULT DEFERRABLE DESC DISTINCT DO
100 FALSE FOR FOREIGN FREEZE FROM FULL
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
111 my $max_id_length = 30;
112 my %used_identifiers = ();
119 =head1 PostgreSQL Create Table Syntax
121 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
122 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
123 | table_constraint } [, ... ]
125 [ INHERITS ( parent_table [, ... ] ) ]
126 [ WITH OIDS | WITHOUT OIDS ]
128 where column_constraint is:
130 [ CONSTRAINT constraint_name ]
131 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
133 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
134 [ ON DELETE action ] [ ON UPDATE action ] }
135 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
137 and table_constraint is:
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 ]
147 =head1 Create Index Syntax
149 CREATE [ UNIQUE ] INDEX index_name ON table
150 [ USING acc_method ] ( column [ ops_name ] [, ...] )
152 CREATE [ UNIQUE ] INDEX index_name ON table
153 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
158 # -------------------------------------------------------------------
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;
167 unless ( $no_comments ) {
169 "--\n-- Created by %s\n-- Created on %s\n--\n\n",
170 __PACKAGE__, scalar localtime;
175 sort { $a->[0] <=> $b->[0] }
176 map { [ $_->{'order'}, $_ ] }
179 my $table_name = $table->{'table_name'};
180 $table_name = mk_name( $table_name, '', undef, 1 );
181 my $table_name_ur = unreserve($table_name);
183 my ( @comments, @field_decs, @sequence_decs, @constraints );
185 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
190 my %field_name_scope;
193 sort { $a->[0] <=> $b->[0] }
194 map { [ $_->{'order'}, $_ ] }
195 values %{ $table->{'fields'} }
197 my $field_name = mk_name(
198 $field->{'name'}, '', \%field_name_scope, 1
200 my $field_name_ur = unreserve( $field_name, $table_name );
201 my $field_str = qq["$field_name_ur"];
206 my $data_type = lc $field->{'data_type'};
207 my $list = $field->{'list'} || [];
208 my $commalist = join ",", @$list;
211 if ( $data_type eq 'enum' ) {
213 $len = ($len < length($_)) ? length($_) : $len for (@$list);
214 my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
216 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
217 $field_str .= " character varying($len)";
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 */";
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";];
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'} || [] };
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 )
251 "'".$field->{'default'}."'"
256 # Not null constraint
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';
267 # if ( $field->{'is_primary_key'} ) {
268 # my $constraint_name = mk_name($field_name_ur, 'pk');
269 # $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
272 push @field_decs, $field_str;
279 my $idx_name_default;
280 for my $index ( @{ $table->{'indices'} } ) {
281 my $index_name = $index->{'name'} || '';
282 my $index_type = $index->{'type'} || 'normal';
284 map { $_ =~ s/\(.+\)//; $_ }
285 map { unreserve( $_, $table_name ) }
286 @{ $index->{'fields'} };
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 ) . ')';
294 elsif ( $index_type eq 'unique' ) {
295 $index_name = mk_name(
296 $table_name, $index_name || ++$idx_name_default
298 push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
299 '(' . join( ', ', @fields ) . ')';
301 elsif ( $index_type eq 'normal' ) {
302 $index_name = mk_name(
303 $table_name, $index_name || ++$idx_name_default
306 qq[CREATE INDEX "$index_name" on $table_name_ur (].
307 join( ', ', @fields ).
311 warn "Unknown index type ($index_type) on table $table_name.\n"
316 my $create_statement;
317 $create_statement = qq[DROP TABLE "$table_name_ur";\n]
319 $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
320 join( ",\n", map { " $_" } @field_decs, @constraints ).
324 $output .= join( "\n\n",
335 warn "Truncated " . keys( %truncated ) . " names:\n";
336 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
340 warn "Encounted " . keys( %unreserve ) .
341 " unsafe names in schema (reserved or invalid):\n";
342 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
349 # -------------------------------------------------------------------
351 my ($basename, $type, $scope, $critical) = @_;
352 my $basename_orig = $basename;
354 ? $max_id_length - (length($type) + 1)
356 $basename = substr( $basename, 0, $max_name )
357 if length( $basename ) > $max_name;
358 my $name = $type ? "${type}_$basename" : $basename;
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;
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;
374 warn "The name '$name_orig' has been changed to ",
375 "'$name' to make it unique.\n" if $WARN;
377 $scope->{ $name_orig }++;
384 # -------------------------------------------------------------------
386 my ( $name, $schema_obj_name ) = @_;
387 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
389 # also trap fields that don't begin with a letter
390 return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
392 if ( $schema_obj_name ) {
393 ++$unreserve{"$schema_obj_name.$name"};
396 ++$unreserve{"$name (table name)"};
399 my $unreserve = sprintf '%s_', $name;
400 return $unreserve.$suffix;
405 # -------------------------------------------------------------------
406 # Life is full of misery, loneliness, and suffering --
407 # and it's all over much too soon.
409 # -------------------------------------------------------------------
415 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>