1 package SQL::Translator::Producer::PostgreSQL;
3 # -------------------------------------------------------------------
4 # $Id: PostgreSQL.pm,v 1.12 2003-08-16 20:12:09 rossta 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.12 $ =~ /(\d+)\.(\d+)/;
34 $DEBUG = 1 unless defined $DEBUG;
36 use SQL::Translator::Schema::Constants;
37 use SQL::Translator::Utils qw(header_comment);
45 double => 'double precision',
47 float => 'double precision',
49 mediumint => 'integer',
50 smallint => 'smallint',
51 tinyint => 'smallint',
53 varchar => 'character varying',
60 mediumblob => 'bytea',
62 enum => 'character varying',
63 set => 'character varying',
65 datetime => 'timestamp',
67 timestamp => 'timestamp',
75 varchar2 => 'character varying',
85 varchar => 'character varying',
86 datetime => 'timestamp',
88 real => 'double precision',
91 tinyint => 'smallint',
92 float => 'double precision',
95 my %reserved = map { $_, 1 } qw[
96 ALL ANALYSE ANALYZE AND ANY AS ASC
98 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
99 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
100 DEFAULT DEFERRABLE DESC DISTINCT DO
102 FALSE FOR FOREIGN FREEZE FROM FULL
104 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
105 JOIN LEADING LEFT LIKE LIMIT
106 NATURAL NEW NOT NOTNULL NULL
107 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
108 PRIMARY PUBLIC REFERENCES RIGHT
109 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
110 UNION UNIQUE USER USING VERBOSE WHEN WHERE
113 my $max_id_length = 30;
114 my %used_identifiers = ();
121 =head1 PostgreSQL Create Table Syntax
123 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
124 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
125 | table_constraint } [, ... ]
127 [ INHERITS ( parent_table [, ... ] ) ]
128 [ WITH OIDS | WITHOUT OIDS ]
130 where column_constraint is:
132 [ CONSTRAINT constraint_name ]
133 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
135 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
136 [ ON DELETE action ] [ ON UPDATE action ] }
137 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
139 and table_constraint is:
141 [ CONSTRAINT constraint_name ]
142 { UNIQUE ( column_name [, ... ] ) |
143 PRIMARY KEY ( column_name [, ... ] ) |
144 CHECK ( expression ) |
145 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
146 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
147 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
149 =head1 Create Index Syntax
151 CREATE [ UNIQUE ] INDEX index_name ON table
152 [ USING acc_method ] ( column [ ops_name ] [, ...] )
154 CREATE [ UNIQUE ] INDEX index_name ON table
155 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
160 # -------------------------------------------------------------------
162 my $translator = shift;
163 $DEBUG = $translator->debug;
164 $WARN = $translator->show_warnings;
165 my $no_comments = $translator->no_comments;
166 my $add_drop_table = $translator->add_drop_table;
167 my $schema = $translator->schema;
170 $output .= header_comment unless ($no_comments);
172 for my $table ( $schema->get_tables ) {
173 my $table_name = $table->name or next;
174 $table_name = mk_name( $table_name, '', undef, 1 );
175 my $table_name_ur = unreserve($table_name);
177 my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
179 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
184 my %field_name_scope;
185 for my $field ( $table->get_fields ) {
186 my $field_name = mk_name(
187 $field->name, '', \%field_name_scope, 1
189 my $field_name_ur = unreserve( $field_name, $table_name );
190 my $field_def = qq["$field_name_ur"];
195 my @size = $field->size;
196 my $data_type = lc $field->data_type;
197 my %extra = $field->extra;
198 my $list = $extra{'list'} || [];
199 # \todo deal with embedded quotes
200 my $commalist = "'" . join("','", @$list) . "'";
203 if ( $data_type eq 'enum' ) {
205 $len = ($len < length($_)) ? length($_) : $len for (@$list);
206 my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
207 push @constraint_defs,
208 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
209 $data_type = 'character varying';
211 elsif ( $data_type eq 'set' ) {
212 # XXX add a CHECK constraint maybe
213 # (trickier and slower, than enum :)
214 # my $len = length $commalist;
215 # $field_def .= " character varying($len) /* set $commalist */";
216 $data_type = 'character varying';
218 elsif ( $field->is_auto_increment ) {
219 $field_def .= ' serial';
220 # $seq_name = mk_name( $table_name.'_'.$field_name, 'sq' );
221 # push @sequence_defs, qq[DROP SEQUENCE "$seq_name";];
222 # push @sequence_defs, qq[CREATE SEQUENCE "$seq_name";];
225 $data_type = defined $translate{ $data_type } ?
226 $translate{ $data_type } :
230 $field_def .= " $data_type";
232 if ( defined $size[0] && $size[0] > 0 ) {
233 $field_def .= '(' . join( ', ', @size ) . ')';
239 my $default = $field->default_value;
240 if ( defined $default ) {
241 $field_def .= sprintf( ' DEFAULT %s',
242 ( $field->is_auto_increment && $seq_name )
243 ? qq[nextval('"$seq_name"'::text)] :
244 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
249 # Not null constraint
251 $field_def .= ' NOT NULL' unless $field->is_nullable;
253 push @field_defs, $field_def;
260 my $idx_name_default;
261 for my $index ( $table->get_indices ) {
262 my $name = $index->name || '';
263 my $type = $index->type || NORMAL;
265 map { $_ =~ s/\(.+\)//; $_ }
266 map { unreserve( $_, $table_name ) }
270 if ( $type eq PRIMARY_KEY ) {
271 $name ||= mk_name( $table_name, 'pk' );
272 push @constraint_defs, 'CONSTRAINT '.$name.' PRIMARY KEY '.
273 '(' . join( ', ', @fields ) . ')';
275 elsif ( $type eq UNIQUE ) {
277 $table_name, $name || ++$idx_name_default
279 push @constraint_defs, 'CONSTRAINT ' . $name . ' UNIQUE ' .
280 '(' . join( ', ', @fields ) . ')';
282 elsif ( $type eq NORMAL ) {
284 $table_name, $name || ++$idx_name_default
287 qq[CREATE INDEX "$name" on $table_name_ur (].
288 join( ', ', @fields ).
292 warn "Unknown index type ($type) on table $table_name.\n"
301 for my $c ( $table->get_constraints ) {
302 my $name = $c->name || '';
304 map { $_ =~ s/\(.+\)//; $_ }
305 map { unreserve( $_, $table_name ) }
308 map { $_ =~ s/\(.+\)//; $_ }
309 map { unreserve( $_, $table_name ) }
310 $c->reference_fields;
313 if ( $c->type eq PRIMARY_KEY ) {
314 $name ||= mk_name( $table_name, 'pk' );
315 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
316 '(' . join( ', ', @fields ) . ')';
318 elsif ( $c->type eq UNIQUE ) {
320 $table_name, $name || ++$c_name_default
322 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
323 '(' . join( ', ', @fields ) . ')';
325 elsif ( $c->type eq FOREIGN_KEY ) {
327 map { $_ || () } 'FOREIGN KEY', $c->name
330 $def .= ' (' . join( ', ', @fields ) . ')';
332 $def .= ' REFERENCES ' . $c->reference_table;
335 $def .= ' (' . join( ', ', @rfields ) . ')';
338 if ( $c->match_type ) {
340 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
343 if ( $c->on_delete ) {
344 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
347 if ( $c->on_update ) {
348 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
351 push @constraint_defs, $def;
355 my $create_statement;
356 $create_statement = qq[DROP TABLE "$table_name_ur";\n]
358 $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
359 join( ",\n", map { " $_" } @field_defs, @constraint_defs ).
363 $output .= join( "\n\n",
374 warn "Truncated " . keys( %truncated ) . " names:\n";
375 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
379 warn "Encounted " . keys( %unreserve ) .
380 " unsafe names in schema (reserved or invalid):\n";
381 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
388 # -------------------------------------------------------------------
390 my $basename = shift || '';
391 my $type = shift || '';
392 my $scope = shift || '';
393 my $critical = shift || '';
394 my $basename_orig = $basename;
396 ? $max_id_length - (length($type) + 1)
398 $basename = substr( $basename, 0, $max_name )
399 if length( $basename ) > $max_name;
400 my $name = $type ? "${type}_$basename" : $basename;
402 if ( $basename ne $basename_orig and $critical ) {
403 my $show_type = $type ? "+'$type'" : "";
404 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
405 "character limit to make '$name'\n" if $WARN;
406 $truncated{ $basename_orig } = $name;
409 $scope ||= \%global_names;
410 if ( my $prev = $scope->{ $name } ) {
411 my $name_orig = $name;
412 $name .= sprintf( "%02d", ++$prev );
413 substr($name, $max_id_length - 3) = "00"
414 if length( $name ) > $max_id_length;
416 warn "The name '$name_orig' has been changed to ",
417 "'$name' to make it unique.\n" if $WARN;
419 $scope->{ $name_orig }++;
426 # -------------------------------------------------------------------
428 my $name = shift || '';
429 my $schema_obj_name = shift || '';
431 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
433 # also trap fields that don't begin with a letter
434 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
436 if ( $schema_obj_name ) {
437 ++$unreserve{"$schema_obj_name.$name"};
440 ++$unreserve{"$name (table name)"};
443 my $unreserve = sprintf '%s_', $name;
444 return $unreserve.$suffix;
449 # -------------------------------------------------------------------
450 # Life is full of misery, loneliness, and suffering --
451 # and it's all over much too soon.
453 # -------------------------------------------------------------------
459 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>