1 package SQL::Translator::Producer::PostgreSQL;
3 # -------------------------------------------------------------------
4 # $Id: PostgreSQL.pm,v 1.8 2003-04-25 11:47:25 dlc 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.8 $ =~ /(\d+)\.(\d+)/;
34 $DEBUG = 1 unless defined $DEBUG;
36 use SQL::Translator::Utils qw(header_comment);
44 double => 'double precision',
46 float => 'double precision',
48 mediumint => 'integer',
49 smallint => 'smallint',
50 tinyint => 'smallint',
52 varchar => 'character varying',
59 mediumblob => 'bytea',
61 enum => 'character varying',
62 set => 'character varying',
64 datetime => 'timestamp',
66 timestamp => 'timestamp',
74 varchar2 => 'character varying',
84 varchar => 'character varying',
85 datetime => 'timestamp',
87 real => 'double precision',
90 tinyint => 'smallint',
91 float => 'double precision',
94 my %reserved = map { $_, 1 } qw[
95 ALL ANALYSE ANALYZE AND ANY AS ASC
97 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
98 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
99 DEFAULT DEFERRABLE DESC DISTINCT DO
101 FALSE FOR FOREIGN FREEZE FROM FULL
103 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
104 JOIN LEADING LEFT LIKE LIMIT
105 NATURAL NEW NOT NOTNULL NULL
106 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
107 PRIMARY PUBLIC REFERENCES RIGHT
108 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
109 UNION UNIQUE USER USING VERBOSE WHEN WHERE
112 my $max_id_length = 30;
113 my %used_identifiers = ();
120 =head1 PostgreSQL Create Table Syntax
122 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
123 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
124 | table_constraint } [, ... ]
126 [ INHERITS ( parent_table [, ... ] ) ]
127 [ WITH OIDS | WITHOUT OIDS ]
129 where column_constraint is:
131 [ CONSTRAINT constraint_name ]
132 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
134 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
135 [ ON DELETE action ] [ ON UPDATE action ] }
136 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
138 and table_constraint is:
140 [ CONSTRAINT constraint_name ]
141 { UNIQUE ( column_name [, ... ] ) |
142 PRIMARY KEY ( column_name [, ... ] ) |
143 CHECK ( expression ) |
144 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
145 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
146 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
148 =head1 Create Index Syntax
150 CREATE [ UNIQUE ] INDEX index_name ON table
151 [ USING acc_method ] ( column [ ops_name ] [, ...] )
153 CREATE [ UNIQUE ] INDEX index_name ON table
154 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
159 # -------------------------------------------------------------------
161 my ( $translator, $data ) = @_;
162 $DEBUG = $translator->debug;
163 $WARN = $translator->show_warnings;
164 my $no_comments = $translator->no_comments;
165 my $add_drop_table = $translator->add_drop_table;
168 $output .= header_comment unless ($no_comments);
172 sort { $a->[0] <=> $b->[0] }
173 map { [ $_->{'order'}, $_ ] }
176 my $table_name = $table->{'table_name'};
177 $table_name = mk_name( $table_name, '', undef, 1 );
178 my $table_name_ur = unreserve($table_name);
180 my ( @comments, @field_decs, @sequence_decs, @constraints );
182 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
187 my %field_name_scope;
190 sort { $a->[0] <=> $b->[0] }
191 map { [ $_->{'order'}, $_ ] }
192 values %{ $table->{'fields'} }
194 my $field_name = mk_name(
195 $field->{'name'}, '', \%field_name_scope, 1
197 my $field_name_ur = unreserve( $field_name, $table_name );
198 my $field_str = qq["$field_name_ur"];
203 my $data_type = lc $field->{'data_type'};
204 my $list = $field->{'list'} || [];
205 my $commalist = join ",", @$list;
208 if ( $data_type eq 'enum' ) {
210 $len = ($len < length($_)) ? length($_) : $len for (@$list);
211 my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
213 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
214 $field_str .= " character varying($len)";
216 elsif ( $data_type eq 'set' ) {
217 # XXX add a CHECK constraint maybe
218 # (trickier and slower, than enum :)
219 my $len = length $commalist;
220 $field_str .= " character varying($len) /* set $commalist */";
222 elsif ( $field->{'is_auto_inc'} ) {
223 $field_str .= ' serial';
224 $seq_name = mk_name( $table_name.'_'.$field_name, 'sq' );
225 push @sequence_decs, qq[DROP SEQUENCE "$seq_name";];
226 push @sequence_decs, qq[CREATE SEQUENCE "$seq_name";];
229 $data_type = defined $translate{ $data_type } ?
230 $translate{ $data_type } :
231 die "Unknown datatype: $data_type\n";
232 $field_str .= ' '.$data_type;
233 if ( $data_type =~ /(char|varbit|numeric|decimal)/i ) {
234 $field_str .= '('.join(',', @{ $field->{'size'} }).')'
235 if @{ $field->{'size'} || [] };
242 if ( defined $field->{'default'} ) {
243 $field_str .= sprintf( ' DEFAULT %s',
244 ( $field->{'is_auto_inc'} && $seq_name )
245 ? qq[nextval('"$seq_name"'::text)] :
246 ( $field->{'default'} =~ m/null/i )
248 "'".$field->{'default'}."'"
253 # Not null constraint
255 unless ( $field->{'null'} ) {
256 my $constraint_name = mk_name($field_name_ur, 'nn');
257 # $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
258 $field_str .= ' NOT NULL';
264 # if ( $field->{'is_primary_key'} ) {
265 # my $constraint_name = mk_name($field_name_ur, 'pk');
266 # $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
269 push @field_decs, $field_str;
276 my $idx_name_default;
277 for my $index ( @{ $table->{'indices'} } ) {
278 my $index_name = $index->{'name'} || '';
279 my $index_type = $index->{'type'} || 'normal';
281 map { $_ =~ s/\(.+\)//; $_ }
282 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>