1 package SQL::Translator::Producer::PostgreSQL;
3 # -------------------------------------------------------------------
4 # $Id: PostgreSQL.pm,v 1.20 2003-10-15 19:07:13 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
31 my $t = SQL::Translator->new( parser => '...', producer => 'PostgreSQL' );
36 Creates a DDL suitable for PostgreSQL. Very heavily based on the Oracle
42 use vars qw[ $DEBUG $WARN $VERSION ];
43 $VERSION = sprintf "%d.%02d", q$Revision: 1.20 $ =~ /(\d+)\.(\d+)/;
44 $DEBUG = 1 unless defined $DEBUG;
46 use SQL::Translator::Schema::Constants;
47 use SQL::Translator::Utils qw(header_comment);
59 mediumint => 'integer',
60 smallint => 'smallint',
61 tinyint => 'smallint',
63 varchar => 'character varying',
70 mediumblob => 'bytea',
72 enum => 'character varying',
73 set => 'character varying',
75 datetime => 'timestamp',
77 timestamp => 'timestamp',
85 varchar2 => 'character varying',
95 varchar => 'character varying',
96 datetime => 'timestamp',
101 tinyint => 'smallint',
105 my %reserved = map { $_, 1 } qw[
106 ALL ANALYSE ANALYZE AND ANY AS ASC
108 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
109 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
110 DEFAULT DEFERRABLE DESC DISTINCT DO
112 FALSE FOR FOREIGN FREEZE FROM FULL
114 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
115 JOIN LEADING LEFT LIKE LIMIT
116 NATURAL NEW NOT NOTNULL NULL
117 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
118 PRIMARY PUBLIC REFERENCES RIGHT
119 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
120 UNION UNIQUE USER USING VERBOSE WHEN WHERE
123 my $max_id_length = 30;
124 my %used_identifiers = ();
131 =head1 PostgreSQL Create Table Syntax
133 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
134 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
135 | table_constraint } [, ... ]
137 [ INHERITS ( parent_table [, ... ] ) ]
138 [ WITH OIDS | WITHOUT OIDS ]
140 where column_constraint is:
142 [ CONSTRAINT constraint_name ]
143 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
145 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
146 [ ON DELETE action ] [ ON UPDATE action ] }
147 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
149 and table_constraint is:
151 [ CONSTRAINT constraint_name ]
152 { UNIQUE ( column_name [, ... ] ) |
153 PRIMARY KEY ( column_name [, ... ] ) |
154 CHECK ( expression ) |
155 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
156 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
157 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
159 =head1 Create Index Syntax
161 CREATE [ UNIQUE ] INDEX index_name ON table
162 [ USING acc_method ] ( column [ ops_name ] [, ...] )
164 CREATE [ UNIQUE ] INDEX index_name ON table
165 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
170 # -------------------------------------------------------------------
172 my $translator = shift;
173 $DEBUG = $translator->debug;
174 $WARN = $translator->show_warnings;
175 my $no_comments = $translator->no_comments;
176 my $add_drop_table = $translator->add_drop_table;
177 my $schema = $translator->schema;
180 $output .= header_comment unless ($no_comments);
181 my %used_index_names;
184 for my $table ( $schema->get_tables ) {
185 my $table_name = $table->name or next;
186 $table_name = mk_name( $table_name, '', undef, 1 );
187 my $table_name_ur = unreserve($table_name);
189 my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
191 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
196 my %field_name_scope;
197 for my $field ( $table->get_fields ) {
198 my $field_name = mk_name(
199 $field->name, '', \%field_name_scope, 1
201 my $field_name_ur = unreserve( $field_name, $table_name );
202 my $field_def = qq["$field_name_ur"];
207 my @size = $field->size;
208 my $data_type = lc $field->data_type;
209 my %extra = $field->extra;
210 my $list = $extra{'list'} || [];
211 # todo deal with embedded quotes
212 my $commalist = join( ', ', map { qq['$_'] } @$list );
215 if ( $data_type eq 'enum' ) {
217 $len = ($len < length($_)) ? length($_) : $len for (@$list);
218 my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
219 push @constraint_defs,
220 qq[Constraint "$chk_name" CHECK ("$field_name" ].
221 qq[IN ($commalist))];
222 $data_type = 'character varying';
224 elsif ( $data_type eq 'set' ) {
225 $data_type = 'character varying';
227 elsif ( $field->is_auto_increment ) {
228 if ( defined $size[0] && $size[0] > 11 ) {
229 $data_type = 'bigserial';
232 $data_type = 'serial';
237 $data_type = defined $translate{ $data_type } ?
238 $translate{ $data_type } :
242 if ( $data_type =~ /timestamp/i ) {
243 if ( defined $size[0] && $size[0] > 6 ) {
248 if ( $data_type eq 'integer' ) {
249 if ( defined $size[0] ) {
250 if ( $size[0] > 10 ) {
251 $data_type = 'bigint';
253 elsif ( $size[0] < 5 ) {
254 $data_type = 'smallint';
257 $data_type = 'integer';
261 $data_type = 'integer';
266 # PG doesn't need a size for integers or text
268 undef @size if $data_type =~ m/(integer|smallint|bigint|text)/;
270 $field_def .= " $data_type";
272 if ( defined $size[0] && $size[0] > 0 ) {
273 $field_def .= '(' . join( ',', @size ) . ')';
277 # Default value -- disallow for timestamps
279 my $default = $data_type =~ /(timestamp|date)/i
280 ? undef : $field->default_value;
281 if ( defined $default ) {
282 $field_def .= sprintf( ' DEFAULT %s',
283 ( $field->is_auto_increment && $seq_name )
284 ? qq[nextval('"$seq_name"'::text)] :
285 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
290 # Not null constraint
292 $field_def .= ' NOT NULL' unless $field->is_nullable;
294 push @field_defs, $field_def;
301 my $idx_name_default;
302 for my $index ( $table->get_indices ) {
303 my $name = $index->name || '';
305 $name = next_unused_name($name, \%used_index_names);
306 $used_index_names{$name} = $name;
309 my $type = $index->type || NORMAL;
311 map { $_ =~ s/\(.+\)//; $_ }
312 map { unreserve( $_, $table_name ) }
316 my $def_start = qq[Constraint "$name" ];
317 if ( $type eq PRIMARY_KEY ) {
318 push @constraint_defs, "${def_start}PRIMARY KEY ".
319 '("' . join( '", "', @fields ) . '")';
321 elsif ( $type eq UNIQUE ) {
322 push @constraint_defs, "${def_start}UNIQUE " .
323 '("' . join( '", "', @fields ) . '")';
325 elsif ( $type eq NORMAL ) {
327 'CREATE INDEX "' . $name . "\" on $table_name_ur (".
328 join( ', ', map { qq["$_"] } @fields ).
333 warn "Unknown index type ($type) on table $table_name.\n"
342 for my $c ( $table->get_constraints ) {
343 my $name = $c->name || '';
345 $name = next_unused_name($name, \%used_index_names);
346 $used_index_names{$name} = $name;
350 map { $_ =~ s/\(.+\)//; $_ }
351 map { unreserve( $_, $table_name ) }
355 map { $_ =~ s/\(.+\)//; $_ }
356 map { unreserve( $_, $table_name ) }
357 $c->reference_fields;
359 next if !@fields && $c->type ne CHECK_C;
361 my $def_start = $name ? qq[Constraint "$name" ] : '';
362 if ( $c->type eq PRIMARY_KEY ) {
363 push @constraint_defs, "${def_start}PRIMARY KEY ".
364 '("' . join( '", "', @fields ) . '")';
366 elsif ( $c->type eq UNIQUE ) {
367 $name = next_unused_name($name, \%used_index_names);
368 $used_index_names{$name} = $name;
369 push @constraint_defs, "${def_start}UNIQUE " .
370 '("' . join( '", "', @fields ) . '")';
372 elsif ( $c->type eq CHECK_C ) {
373 my $expression = $c->expression;
374 push @constraint_defs, "${def_start}CHECK ($expression)";
376 elsif ( $c->type eq FOREIGN_KEY ) {
377 my $def .= "ALTER TABLE $table_name ADD FOREIGN KEY (" .
378 join( ', ', map { qq["$_"] } @fields ) . ')' .
379 "\n REFERENCES " . $c->reference_table;
382 $def .= ' ("' . join( '", "', @rfields ) . '")';
385 if ( $c->match_type ) {
387 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
390 if ( $c->on_delete ) {
391 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
394 if ( $c->on_update ) {
395 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
402 my $create_statement;
403 $create_statement = qq[DROP TABLE "$table_name_ur";\n]
405 $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
406 join( ",\n", map { " $_" } @field_defs, @constraint_defs ).
410 $output .= join( "\n\n",
420 $output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
421 $output .= join( "\n\n", @fks );
426 warn "Truncated " . keys( %truncated ) . " names:\n";
427 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
431 warn "Encounted " . keys( %unreserve ) .
432 " unsafe names in schema (reserved or invalid):\n";
433 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
440 # -------------------------------------------------------------------
442 my $basename = shift || '';
443 my $type = shift || '';
444 my $scope = shift || '';
445 my $critical = shift || '';
446 my $basename_orig = $basename;
448 ? $max_id_length - (length($type) + 1)
450 $basename = substr( $basename, 0, $max_name )
451 if length( $basename ) > $max_name;
452 my $name = $type ? "${type}_$basename" : $basename;
454 if ( $basename ne $basename_orig and $critical ) {
455 my $show_type = $type ? "+'$type'" : "";
456 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
457 "character limit to make '$name'\n" if $WARN;
458 $truncated{ $basename_orig } = $name;
461 $scope ||= \%global_names;
462 if ( my $prev = $scope->{ $name } ) {
463 my $name_orig = $name;
464 $name .= sprintf( "%02d", ++$prev );
465 substr($name, $max_id_length - 3) = "00"
466 if length( $name ) > $max_id_length;
468 warn "The name '$name_orig' has been changed to ",
469 "'$name' to make it unique.\n" if $WARN;
471 $scope->{ $name_orig }++;
478 # -------------------------------------------------------------------
480 my $name = shift || '';
481 my $schema_obj_name = shift || '';
483 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
485 # also trap fields that don't begin with a letter
486 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
488 if ( $schema_obj_name ) {
489 ++$unreserve{"$schema_obj_name.$name"};
492 ++$unreserve{"$name (table name)"};
495 my $unreserve = sprintf '%s_', $name;
496 return $unreserve.$suffix;
499 # -------------------------------------------------------------------
500 sub next_unused_name {
501 my $name = shift || '';
502 my $used_names = shift || '';
504 my %used_names = %$used_names;
506 if ( !defined($used_names{$name}) ) {
507 $used_names{$name} = $name;
512 while ( defined($used_names{$name . $i}) ) {
516 $used_names{$name} = $name;
522 # -------------------------------------------------------------------
523 # Life is full of misery, loneliness, and suffering --
524 # and it's all over much too soon.
526 # -------------------------------------------------------------------
532 SQL::Translator, SQL::Translator::Producer::Oracle.
536 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.