1 package SQL::Translator::Producer::PostgreSQL;
3 # -------------------------------------------------------------------
4 # $Id: PostgreSQL.pm,v 1.23 2005-07-05 16:20:43 mwz444 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.23 $ =~ /(\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 print STDERR "$table_name table_name\n";
188 my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
190 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
192 if ( $table->comments and !$no_comments ){
193 my $c = "-- Comments: \n-- ";
194 $c .= join "\n-- ", $table->comments;
202 my %field_name_scope;
203 for my $field ( $table->get_fields ) {
204 my $field_name = mk_name(
205 $field->name, '', \%field_name_scope, 1
207 my $field_name_ur = unreserve( $field_name, $table_name );
208 my $field_comments = $field->comments
209 ? "-- " . $field->comments . "\n "
212 my $field_def = $field_comments.qq["$field_name_ur"];
217 my @size = $field->size;
218 my $data_type = lc $field->data_type;
219 my %extra = $field->extra;
220 my $list = $extra{'list'} || [];
221 # todo deal with embedded quotes
222 my $commalist = join( ', ', map { qq['$_'] } @$list );
225 if ( $data_type eq 'enum' ) {
227 $len = ($len < length($_)) ? length($_) : $len for (@$list);
228 my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
229 push @constraint_defs,
230 qq[Constraint "$chk_name" CHECK ("$field_name" ].
231 qq[IN ($commalist))];
232 $data_type = 'character varying';
234 elsif ( $data_type eq 'set' ) {
235 $data_type = 'character varying';
237 elsif ( $field->is_auto_increment ) {
238 if ( defined $size[0] && $size[0] > 11 ) {
239 $data_type = 'bigserial';
242 $data_type = 'serial';
247 $data_type = defined $translate{ $data_type } ?
248 $translate{ $data_type } :
252 if ( $data_type =~ /timestamp/i ) {
253 if ( defined $size[0] && $size[0] > 6 ) {
258 if ( $data_type eq 'integer' ) {
259 if ( defined $size[0] ) {
260 if ( $size[0] > 10 ) {
261 $data_type = 'bigint';
263 elsif ( $size[0] < 5 ) {
264 $data_type = 'smallint';
267 $data_type = 'integer';
271 $data_type = 'integer';
276 # PG doesn't need a size for integers or text
278 undef @size if $data_type =~ m/(integer|smallint|bigint|text)/;
280 $field_def .= " $data_type";
282 if ( defined $size[0] && $size[0] > 0 ) {
283 $field_def .= '(' . join( ',', @size ) . ')';
287 # Default value -- disallow for timestamps
289 my $default = $data_type =~ /(timestamp|date)/i
290 ? undef : $field->default_value;
291 if ( defined $default ) {
292 $field_def .= sprintf( ' DEFAULT %s',
293 ( $field->is_auto_increment && $seq_name )
294 ? qq[nextval('"$seq_name"'::text)] :
295 ( $default =~ m/null/i ) ? 'NULL' : "'$default'"
300 # Not null constraint
302 $field_def .= ' NOT NULL' unless $field->is_nullable;
304 push @field_defs, $field_def;
311 my $idx_name_default;
312 for my $index ( $table->get_indices ) {
313 my $name = $index->name || '';
315 $name = next_unused_name($name, \%used_index_names);
316 $used_index_names{$name} = $name;
319 my $type = $index->type || NORMAL;
321 map { $_ =~ s/\(.+\)//; $_ }
322 map { unreserve( $_, $table_name ) }
326 my $def_start = qq[Constraint "$name" ];
327 if ( $type eq PRIMARY_KEY ) {
328 push @constraint_defs, "${def_start}PRIMARY KEY ".
329 '("' . join( '", "', @fields ) . '")';
331 elsif ( $type eq UNIQUE ) {
332 push @constraint_defs, "${def_start}UNIQUE " .
333 '("' . join( '", "', @fields ) . '")';
335 elsif ( $type eq NORMAL ) {
337 'CREATE INDEX "' . $name . "\" on $table_name_ur (".
338 join( ', ', map { qq["$_"] } @fields ).
343 warn "Unknown index type ($type) on table $table_name.\n"
352 for my $c ( $table->get_constraints ) {
353 my $name = $c->name || '';
355 $name = next_unused_name($name, \%used_index_names);
356 $used_index_names{$name} = $name;
360 map { $_ =~ s/\(.+\)//; $_ }
361 map { unreserve( $_, $table_name ) }
365 map { $_ =~ s/\(.+\)//; $_ }
366 map { unreserve( $_, $table_name ) }
367 $c->reference_fields;
369 next if !@fields && $c->type ne CHECK_C;
371 my $def_start = $name ? qq[Constraint "$name" ] : '';
372 if ( $c->type eq PRIMARY_KEY ) {
373 push @constraint_defs, "${def_start}PRIMARY KEY ".
374 '("' . join( '", "', @fields ) . '")';
376 elsif ( $c->type eq UNIQUE ) {
377 $name = next_unused_name($name, \%used_index_names);
378 $used_index_names{$name} = $name;
379 push @constraint_defs, "${def_start}UNIQUE " .
380 '("' . join( '", "', @fields ) . '")';
382 elsif ( $c->type eq CHECK_C ) {
383 my $expression = $c->expression;
384 push @constraint_defs, "${def_start}CHECK ($expression)";
386 elsif ( $c->type eq FOREIGN_KEY ) {
387 my $def .= "ALTER TABLE $table_name ADD FOREIGN KEY (" .
388 join( ', ', map { qq["$_"] } @fields ) . ')' .
389 "\n REFERENCES " . $c->reference_table;
392 $def .= ' ("' . join( '", "', @rfields ) . '")';
395 if ( $c->match_type ) {
397 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
400 if ( $c->on_delete ) {
401 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
404 if ( $c->on_update ) {
405 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
412 my $create_statement;
413 $create_statement = qq[DROP TABLE "$table_name_ur";\n]
415 $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
416 join( ",\n", map { " $_" } @field_defs, @constraint_defs ).
420 $output .= join( "\n\n",
430 $output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
431 $output .= join( "\n\n", @fks );
436 warn "Truncated " . keys( %truncated ) . " names:\n";
437 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
441 warn "Encounted " . keys( %unreserve ) .
442 " unsafe names in schema (reserved or invalid):\n";
443 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
450 # -------------------------------------------------------------------
452 my $basename = shift || '';
453 my $type = shift || '';
454 my $scope = shift || '';
455 my $critical = shift || '';
456 my $basename_orig = $basename;
458 ? $max_id_length - (length($type) + 1)
460 $basename = substr( $basename, 0, $max_name )
461 if length( $basename ) > $max_name;
462 my $name = $type ? "${type}_$basename" : $basename;
464 if ( $basename ne $basename_orig and $critical ) {
465 my $show_type = $type ? "+'$type'" : "";
466 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
467 "character limit to make '$name'\n" if $WARN;
468 $truncated{ $basename_orig } = $name;
471 $scope ||= \%global_names;
472 if ( my $prev = $scope->{ $name } ) {
473 my $name_orig = $name;
474 $name .= sprintf( "%02d", ++$prev );
475 substr($name, $max_id_length - 3) = "00"
476 if length( $name ) > $max_id_length;
478 warn "The name '$name_orig' has been changed to ",
479 "'$name' to make it unique.\n" if $WARN;
481 $scope->{ $name_orig }++;
488 # -------------------------------------------------------------------
490 my $name = shift || '';
491 my $schema_obj_name = shift || '';
493 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
495 # also trap fields that don't begin with a letter
496 return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
498 if ( $schema_obj_name ) {
499 ++$unreserve{"$schema_obj_name.$name"};
502 ++$unreserve{"$name (table name)"};
505 my $unreserve = sprintf '%s_', $name;
506 return $unreserve.$suffix;
509 # -------------------------------------------------------------------
510 sub next_unused_name {
511 my $name = shift || '';
512 my $used_names = shift || '';
514 my %used_names = %$used_names;
516 if ( !defined($used_names{$name}) ) {
517 $used_names{$name} = $name;
522 while ( defined($used_names{$name . $i}) ) {
526 $used_names{$name} = $name;
532 # -------------------------------------------------------------------
533 # Life is full of misery, loneliness, and suffering --
534 # and it's all over much too soon.
536 # -------------------------------------------------------------------
542 SQL::Translator, SQL::Translator::Producer::Oracle.
546 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.