1 package SQL::Translator::Producer::PostgreSQL;
3 # -------------------------------------------------------------------
4 # $Id: PostgreSQL.pm,v 1.19 2003-09-26 22:54:48 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.19 $ =~ /(\d+)\.(\d+)/;
34 $DEBUG = 1 unless defined $DEBUG;
36 use SQL::Translator::Schema::Constants;
37 use SQL::Translator::Utils qw(header_comment);
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',
91 tinyint => 'smallint',
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);
171 my %used_index_names;
174 for my $table ( $schema->get_tables ) {
175 my $table_name = $table->name or next;
176 $table_name = mk_name( $table_name, '', undef, 1 );
177 my $table_name_ur = unreserve($table_name);
179 my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
181 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
186 my %field_name_scope;
187 for my $field ( $table->get_fields ) {
188 my $field_name = mk_name(
189 $field->name, '', \%field_name_scope, 1
191 my $field_name_ur = unreserve( $field_name, $table_name );
192 my $field_def = qq["$field_name_ur"];
197 my @size = $field->size;
198 my $data_type = lc $field->data_type;
199 my %extra = $field->extra;
200 my $list = $extra{'list'} || [];
201 # todo deal with embedded quotes
202 my $commalist = join( ', ', map { qq['$_'] } @$list );
205 if ( $data_type eq 'enum' ) {
207 $len = ($len < length($_)) ? length($_) : $len for (@$list);
208 my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
209 push @constraint_defs,
210 qq[Constraint "$chk_name" CHECK ("$field_name" ].
211 qq[IN ($commalist))];
212 $data_type = 'character varying';
214 elsif ( $data_type eq 'set' ) {
215 $data_type = 'character varying';
217 elsif ( $field->is_auto_increment ) {
218 if ( defined $size[0] && $size[0] > 11 ) {
219 $data_type = 'bigserial';
222 $data_type = 'serial';
227 $data_type = defined $translate{ $data_type } ?
228 $translate{ $data_type } :
232 if ( $data_type =~ /timestamp/i ) {
233 if ( defined $size[0] && $size[0] > 6 ) {
238 if ( $data_type eq 'integer' ) {
239 if ( defined $size[0] ) {
240 if ( $size[0] > 10 ) {
241 $data_type = 'bigint';
243 elsif ( $size[0] < 5 ) {
244 $data_type = 'smallint';
247 $data_type = 'integer';
251 $data_type = 'integer';
256 # PG doesn't need a size for integers or text
258 undef @size if $data_type =~ m/(integer|smallint|bigint|text)/;
260 $field_def .= " $data_type";
262 if ( defined $size[0] && $size[0] > 0 ) {
263 $field_def .= '(' . join( ',', @size ) . ')';
267 # Default value -- disallow for timestamps
269 my $default = $data_type =~ /(timestamp|date)/i
270 ? undef : $field->default_value;
271 if ( defined $default ) {
272 $field_def .= sprintf( ' DEFAULT %s',
273 ( $field->is_auto_increment && $seq_name )
274 ? qq[nextval('"$seq_name"'::text)] :
275 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
280 # Not null constraint
282 $field_def .= ' NOT NULL' unless $field->is_nullable;
284 push @field_defs, $field_def;
291 my $idx_name_default;
292 for my $index ( $table->get_indices ) {
293 my $name = $index->name || '';
295 $name = next_unused_name($name, \%used_index_names);
296 $used_index_names{$name} = $name;
299 my $type = $index->type || NORMAL;
301 map { $_ =~ s/\(.+\)//; $_ }
302 map { unreserve( $_, $table_name ) }
306 my $def_start = qq[Constraint "$name" ];
307 if ( $type eq PRIMARY_KEY ) {
308 push @constraint_defs, "${def_start}PRIMARY KEY ".
309 '("' . join( '", "', @fields ) . '")';
311 elsif ( $type eq UNIQUE ) {
312 push @constraint_defs, "${def_start}UNIQUE " .
313 '("' . join( '", "', @fields ) . '")';
315 elsif ( $type eq NORMAL ) {
317 'CREATE INDEX "' . $name . "\" on $table_name_ur (".
318 join( ', ', map { qq["$_"] } @fields ).
323 warn "Unknown index type ($type) on table $table_name.\n"
332 for my $c ( $table->get_constraints ) {
333 my $name = $c->name || '';
335 $name = next_unused_name($name, \%used_index_names);
336 $used_index_names{$name} = $name;
340 map { $_ =~ s/\(.+\)//; $_ }
341 map { unreserve( $_, $table_name ) }
345 map { $_ =~ s/\(.+\)//; $_ }
346 map { unreserve( $_, $table_name ) }
347 $c->reference_fields;
349 next if !@fields && $c->type ne CHECK_C;
351 my $def_start = $name ? qq[Constraint "$name" ] : '';
352 if ( $c->type eq PRIMARY_KEY ) {
353 push @constraint_defs, "${def_start}PRIMARY KEY ".
354 '("' . join( '", "', @fields ) . '")';
356 elsif ( $c->type eq UNIQUE ) {
357 $name = next_unused_name($name, \%used_index_names);
358 $used_index_names{$name} = $name;
359 push @constraint_defs, "${def_start}UNIQUE " .
360 '("' . join( '", "', @fields ) . '")';
362 elsif ( $c->type eq CHECK_C ) {
363 my $expression = $c->expression;
364 push @constraint_defs, "${def_start}CHECK ($expression)";
366 elsif ( $c->type eq FOREIGN_KEY ) {
367 my $def .= "ALTER TABLE $table_name ADD FOREIGN KEY (" .
368 join( ', ', map { qq["$_"] } @fields ) . ')' .
369 "\n REFERENCES " . $c->reference_table;
372 $def .= ' ("' . join( '", "', @rfields ) . '")';
375 if ( $c->match_type ) {
377 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
380 if ( $c->on_delete ) {
381 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
384 if ( $c->on_update ) {
385 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
392 my $create_statement;
393 $create_statement = qq[DROP TABLE "$table_name_ur";\n]
395 $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
396 join( ",\n", map { " $_" } @field_defs, @constraint_defs ).
400 $output .= join( "\n\n",
410 $output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
411 $output .= join( "\n\n", @fks );
416 warn "Truncated " . keys( %truncated ) . " names:\n";
417 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
421 warn "Encounted " . keys( %unreserve ) .
422 " unsafe names in schema (reserved or invalid):\n";
423 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
430 # -------------------------------------------------------------------
432 my $basename = shift || '';
433 my $type = shift || '';
434 my $scope = shift || '';
435 my $critical = shift || '';
436 my $basename_orig = $basename;
438 ? $max_id_length - (length($type) + 1)
440 $basename = substr( $basename, 0, $max_name )
441 if length( $basename ) > $max_name;
442 my $name = $type ? "${type}_$basename" : $basename;
444 if ( $basename ne $basename_orig and $critical ) {
445 my $show_type = $type ? "+'$type'" : "";
446 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
447 "character limit to make '$name'\n" if $WARN;
448 $truncated{ $basename_orig } = $name;
451 $scope ||= \%global_names;
452 if ( my $prev = $scope->{ $name } ) {
453 my $name_orig = $name;
454 $name .= sprintf( "%02d", ++$prev );
455 substr($name, $max_id_length - 3) = "00"
456 if length( $name ) > $max_id_length;
458 warn "The name '$name_orig' has been changed to ",
459 "'$name' to make it unique.\n" if $WARN;
461 $scope->{ $name_orig }++;
468 # -------------------------------------------------------------------
470 my $name = shift || '';
471 my $schema_obj_name = shift || '';
473 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
475 # also trap fields that don't begin with a letter
476 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
478 if ( $schema_obj_name ) {
479 ++$unreserve{"$schema_obj_name.$name"};
482 ++$unreserve{"$name (table name)"};
485 my $unreserve = sprintf '%s_', $name;
486 return $unreserve.$suffix;
489 # -------------------------------------------------------------------
490 sub next_unused_name {
491 my $name = shift || '';
492 my $used_names = shift || '';
494 my %used_names = %$used_names;
496 if ( !defined($used_names{$name}) ) {
497 $used_names{$name} = $name;
502 while ( defined($used_names{$name . $i}) ) {
506 $used_names{$name} = $name;
512 # -------------------------------------------------------------------
513 # Life is full of misery, loneliness, and suffering --
514 # and it's all over much too soon.
516 # -------------------------------------------------------------------
522 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>