1 package SQL::Translator::Producer::PostgreSQL;
3 # -------------------------------------------------------------------
4 # $Id: PostgreSQL.pm,v 1.22 2004-02-09 23:02:15 kycl4rk Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002-4 SQLFairy Authors
8 # This program is free software; you can redistribute it and/or
9 # modify it under the terms of the GNU General Public License as
10 # published by the Free Software Foundation; version 2.
12 # This program is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 # General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program; if not, write to the Free Software
19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
21 # -------------------------------------------------------------------
25 SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
29 my $t = SQL::Translator->new( parser => '...', producer => 'PostgreSQL' );
34 Creates a DDL suitable for PostgreSQL. Very heavily based on the Oracle
40 use vars qw[ $DEBUG $WARN $VERSION ];
41 $VERSION = sprintf "%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/;
42 $DEBUG = 1 unless defined $DEBUG;
44 use SQL::Translator::Schema::Constants;
45 use SQL::Translator::Utils qw(header_comment);
57 mediumint => 'integer',
58 smallint => 'smallint',
59 tinyint => 'smallint',
61 varchar => 'character varying',
68 mediumblob => 'bytea',
70 enum => 'character varying',
71 set => 'character varying',
73 datetime => 'timestamp',
75 timestamp => 'timestamp',
83 varchar2 => 'character varying',
93 varchar => 'character varying',
94 datetime => 'timestamp',
99 tinyint => 'smallint',
103 my %reserved = map { $_, 1 } qw[
104 ALL ANALYSE ANALYZE AND ANY AS ASC
106 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
107 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
108 DEFAULT DEFERRABLE DESC DISTINCT DO
110 FALSE FOR FOREIGN FREEZE FROM FULL
112 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
113 JOIN LEADING LEFT LIKE LIMIT
114 NATURAL NEW NOT NOTNULL NULL
115 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
116 PRIMARY PUBLIC REFERENCES RIGHT
117 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
118 UNION UNIQUE USER USING VERBOSE WHEN WHERE
121 my $max_id_length = 62;
122 my %used_identifiers = ();
129 =head1 PostgreSQL Create Table Syntax
131 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
132 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
133 | table_constraint } [, ... ]
135 [ INHERITS ( parent_table [, ... ] ) ]
136 [ WITH OIDS | WITHOUT OIDS ]
138 where column_constraint is:
140 [ CONSTRAINT constraint_name ]
141 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
143 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
144 [ ON DELETE action ] [ ON UPDATE action ] }
145 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
147 and table_constraint is:
149 [ CONSTRAINT constraint_name ]
150 { UNIQUE ( column_name [, ... ] ) |
151 PRIMARY KEY ( column_name [, ... ] ) |
152 CHECK ( expression ) |
153 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
154 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
155 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
157 =head1 Create Index Syntax
159 CREATE [ UNIQUE ] INDEX index_name ON table
160 [ USING acc_method ] ( column [ ops_name ] [, ...] )
162 CREATE [ UNIQUE ] INDEX index_name ON table
163 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
168 # -------------------------------------------------------------------
170 my $translator = shift;
171 $DEBUG = $translator->debug;
172 $WARN = $translator->show_warnings;
173 my $no_comments = $translator->no_comments;
174 my $add_drop_table = $translator->add_drop_table;
175 my $schema = $translator->schema;
178 $output .= header_comment unless ($no_comments);
179 my %used_index_names;
182 for my $table ( $schema->get_tables ) {
183 my $table_name = $table->name or next;
184 $table_name = mk_name( $table_name, '', undef, 1 );
185 my $table_name_ur = unreserve($table_name);
187 my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
189 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
194 my %field_name_scope;
195 for my $field ( $table->get_fields ) {
196 my $field_name = mk_name(
197 $field->name, '', \%field_name_scope, 1
199 my $field_name_ur = unreserve( $field_name, $table_name );
200 my $field_def = qq["$field_name_ur"];
205 my @size = $field->size;
206 my $data_type = lc $field->data_type;
207 my %extra = $field->extra;
208 my $list = $extra{'list'} || [];
209 # todo deal with embedded quotes
210 my $commalist = join( ', ', map { qq['$_'] } @$list );
213 if ( $data_type eq 'enum' ) {
215 $len = ($len < length($_)) ? length($_) : $len for (@$list);
216 my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
217 push @constraint_defs,
218 qq[Constraint "$chk_name" CHECK ("$field_name" ].
219 qq[IN ($commalist))];
220 $data_type = 'character varying';
222 elsif ( $data_type eq 'set' ) {
223 $data_type = 'character varying';
225 elsif ( $field->is_auto_increment ) {
226 if ( defined $size[0] && $size[0] > 11 ) {
227 $data_type = 'bigserial';
230 $data_type = 'serial';
235 $data_type = defined $translate{ $data_type } ?
236 $translate{ $data_type } :
240 if ( $data_type =~ /timestamp/i ) {
241 if ( defined $size[0] && $size[0] > 6 ) {
246 if ( $data_type eq 'integer' ) {
247 if ( defined $size[0] ) {
248 if ( $size[0] > 10 ) {
249 $data_type = 'bigint';
251 elsif ( $size[0] < 5 ) {
252 $data_type = 'smallint';
255 $data_type = 'integer';
259 $data_type = 'integer';
264 # PG doesn't need a size for integers or text
266 undef @size if $data_type =~ m/(integer|smallint|bigint|text)/;
268 $field_def .= " $data_type";
270 if ( defined $size[0] && $size[0] > 0 ) {
271 $field_def .= '(' . join( ',', @size ) . ')';
275 # Default value -- disallow for timestamps
277 my $default = $data_type =~ /(timestamp|date)/i
278 ? undef : $field->default_value;
279 if ( defined $default ) {
280 $field_def .= sprintf( ' DEFAULT %s',
281 ( $field->is_auto_increment && $seq_name )
282 ? qq[nextval('"$seq_name"'::text)] :
283 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
288 # Not null constraint
290 $field_def .= ' NOT NULL' unless $field->is_nullable;
292 push @field_defs, $field_def;
299 my $idx_name_default;
300 for my $index ( $table->get_indices ) {
301 my $name = $index->name || '';
303 $name = next_unused_name($name, \%used_index_names);
304 $used_index_names{$name} = $name;
307 my $type = $index->type || NORMAL;
309 map { $_ =~ s/\(.+\)//; $_ }
310 map { unreserve( $_, $table_name ) }
314 my $def_start = qq[Constraint "$name" ];
315 if ( $type eq PRIMARY_KEY ) {
316 push @constraint_defs, "${def_start}PRIMARY KEY ".
317 '("' . join( '", "', @fields ) . '")';
319 elsif ( $type eq UNIQUE ) {
320 push @constraint_defs, "${def_start}UNIQUE " .
321 '("' . join( '", "', @fields ) . '")';
323 elsif ( $type eq NORMAL ) {
325 'CREATE INDEX "' . $name . "\" on $table_name_ur (".
326 join( ', ', map { qq["$_"] } @fields ).
331 warn "Unknown index type ($type) on table $table_name.\n"
340 for my $c ( $table->get_constraints ) {
341 my $name = $c->name || '';
343 $name = next_unused_name($name, \%used_index_names);
344 $used_index_names{$name} = $name;
348 map { $_ =~ s/\(.+\)//; $_ }
349 map { unreserve( $_, $table_name ) }
353 map { $_ =~ s/\(.+\)//; $_ }
354 map { unreserve( $_, $table_name ) }
355 $c->reference_fields;
357 next if !@fields && $c->type ne CHECK_C;
359 my $def_start = $name ? qq[Constraint "$name" ] : '';
360 if ( $c->type eq PRIMARY_KEY ) {
361 push @constraint_defs, "${def_start}PRIMARY KEY ".
362 '("' . join( '", "', @fields ) . '")';
364 elsif ( $c->type eq UNIQUE ) {
365 $name = next_unused_name($name, \%used_index_names);
366 $used_index_names{$name} = $name;
367 push @constraint_defs, "${def_start}UNIQUE " .
368 '("' . join( '", "', @fields ) . '")';
370 elsif ( $c->type eq CHECK_C ) {
371 my $expression = $c->expression;
372 push @constraint_defs, "${def_start}CHECK ($expression)";
374 elsif ( $c->type eq FOREIGN_KEY ) {
375 my $def .= "ALTER TABLE $table_name ADD FOREIGN KEY (" .
376 join( ', ', map { qq["$_"] } @fields ) . ')' .
377 "\n REFERENCES " . $c->reference_table;
380 $def .= ' ("' . join( '", "', @rfields ) . '")';
383 if ( $c->match_type ) {
385 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
388 if ( $c->on_delete ) {
389 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
392 if ( $c->on_update ) {
393 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
400 my $create_statement;
401 $create_statement = qq[DROP TABLE "$table_name_ur";\n]
403 $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
404 join( ",\n", map { " $_" } @field_defs, @constraint_defs ).
408 $output .= join( "\n\n",
418 $output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
419 $output .= join( "\n\n", @fks );
424 warn "Truncated " . keys( %truncated ) . " names:\n";
425 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
429 warn "Encounted " . keys( %unreserve ) .
430 " unsafe names in schema (reserved or invalid):\n";
431 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
438 # -------------------------------------------------------------------
440 my $basename = shift || '';
441 my $type = shift || '';
442 my $scope = shift || '';
443 my $critical = shift || '';
444 my $basename_orig = $basename;
446 ? $max_id_length - (length($type) + 1)
448 $basename = substr( $basename, 0, $max_name )
449 if length( $basename ) > $max_name;
450 my $name = $type ? "${type}_$basename" : $basename;
452 if ( $basename ne $basename_orig and $critical ) {
453 my $show_type = $type ? "+'$type'" : "";
454 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
455 "character limit to make '$name'\n" if $WARN;
456 $truncated{ $basename_orig } = $name;
459 $scope ||= \%global_names;
460 if ( my $prev = $scope->{ $name } ) {
461 my $name_orig = $name;
462 $name .= sprintf( "%02d", ++$prev );
463 substr($name, $max_id_length - 3) = "00"
464 if length( $name ) > $max_id_length;
466 warn "The name '$name_orig' has been changed to ",
467 "'$name' to make it unique.\n" if $WARN;
469 $scope->{ $name_orig }++;
476 # -------------------------------------------------------------------
478 my $name = shift || '';
479 my $schema_obj_name = shift || '';
481 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
483 # also trap fields that don't begin with a letter
484 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
486 if ( $schema_obj_name ) {
487 ++$unreserve{"$schema_obj_name.$name"};
490 ++$unreserve{"$name (table name)"};
493 my $unreserve = sprintf '%s_', $name;
494 return $unreserve.$suffix;
497 # -------------------------------------------------------------------
498 sub next_unused_name {
499 my $name = shift || '';
500 my $used_names = shift || '';
502 my %used_names = %$used_names;
504 if ( !defined($used_names{$name}) ) {
505 $used_names{$name} = $name;
510 while ( defined($used_names{$name . $i}) ) {
514 $used_names{$name} = $name;
520 # -------------------------------------------------------------------
521 # Life is full of misery, loneliness, and suffering --
522 # and it's all over much too soon.
524 # -------------------------------------------------------------------
530 SQL::Translator, SQL::Translator::Producer::Oracle.
534 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.