1 package SQL::Translator::Producer::PostgreSQL;
3 # -------------------------------------------------------------------
4 # $Id: PostgreSQL.pm,v 1.6 2003-01-27 17:04:48 dlc 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.6 $ =~ /(\d+)\.(\d+)/;
34 $DEBUG = 1 unless defined $DEBUG;
43 double => 'double precision',
45 float => 'double precision',
47 mediumint => 'integer',
48 smallint => 'smallint',
49 tinyint => 'smallint',
51 varchar => 'character varying',
58 mediumblob => 'bytea',
60 enum => 'character varying',
61 set => 'character varying',
63 datetime => 'timestamp',
65 timestamp => 'timestamp',
73 varchar2 => 'character varying',
83 varchar => 'character varying',
84 datetime => 'timestamp',
86 real => 'double precision',
89 tinyint => 'smallint',
90 float => 'double precision',
93 my %reserved = map { $_, 1 } qw[
94 ALL ANALYSE ANALYZE AND ANY AS ASC
96 CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
97 CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
98 DEFAULT DEFERRABLE DESC DISTINCT DO
100 FALSE FOR FOREIGN FREEZE FROM FULL
102 ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
103 JOIN LEADING LEFT LIKE LIMIT
104 NATURAL NEW NOT NOTNULL NULL
105 OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
106 PRIMARY PUBLIC REFERENCES RIGHT
107 SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
108 UNION UNIQUE USER USING VERBOSE WHEN WHERE
111 my $max_id_length = 30;
112 my %used_identifiers = ();
119 =head1 PostgreSQL Create Table Syntax
121 CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
122 { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
123 | table_constraint } [, ... ]
125 [ INHERITS ( parent_table [, ... ] ) ]
126 [ WITH OIDS | WITHOUT OIDS ]
128 where column_constraint is:
130 [ CONSTRAINT constraint_name ]
131 { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
133 REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
134 [ ON DELETE action ] [ ON UPDATE action ] }
135 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
137 and table_constraint is:
139 [ CONSTRAINT constraint_name ]
140 { UNIQUE ( column_name [, ... ] ) |
141 PRIMARY KEY ( column_name [, ... ] ) |
142 CHECK ( expression ) |
143 FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
144 [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
145 [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]
147 =head1 Create Index Syntax
149 CREATE [ UNIQUE ] INDEX index_name ON table
150 [ USING acc_method ] ( column [ ops_name ] [, ...] )
152 CREATE [ UNIQUE ] INDEX index_name ON table
153 [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
158 # -------------------------------------------------------------------
160 my ( $translator, $data ) = @_;
161 $DEBUG = $translator->debug;
162 $WARN = $translator->show_warnings;
163 my $no_comments = $translator->no_comments;
164 my $add_drop_table = $translator->add_drop_table;
167 unless ( $no_comments ) {
169 "--\n-- Created by %s\n-- Created on %s\n--\n\n",
170 __PACKAGE__, scalar localtime;
175 sort { $a->[0] <=> $b->[0] }
176 map { [ $_->{'order'}, $_ ] }
179 my $table_name = $table->{'table_name'};
180 $table_name = mk_name( $table_name, '', undef, 1 );
181 my $table_name_ur = unreserve($table_name);
183 my ( @comments, @field_decs, @sequence_decs, @constraints );
185 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
190 my %field_name_scope;
193 sort { $a->[0] <=> $b->[0] }
194 map { [ $_->{'order'}, $_ ] }
195 values %{ $table->{'fields'} }
197 my $field_name = mk_name(
198 $field->{'name'}, '', \%field_name_scope, 1
200 my $field_name_ur = unreserve( $field_name, $table_name );
201 my $field_str = qq["$field_name_ur"];
206 my $data_type = lc $field->{'data_type'};
207 my $list = $field->{'list'} || [];
208 my $commalist = join ",", @$list;
211 if ( $data_type eq 'enum' ) {
213 $len = ($len < length($_)) ? length($_) : $len for (@$list);
214 my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
216 "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
217 $field_str .= " character varying($len)";
219 elsif ( $data_type eq 'set' ) {
220 # XXX add a CHECK constraint maybe
221 # (trickier and slower, than enum :)
222 my $len = length $commalist;
223 $field_str .= " character varying($len) /* set $commalist */";
225 elsif ( $field->{'is_auto_inc'} ) {
226 $field_str .= ' serial';
227 $seq_name = mk_name( $table_name.'_'.$field_name, 'sq' );
228 push @sequence_decs, qq[DROP SEQUENCE "$seq_name";];
229 push @sequence_decs, qq[CREATE SEQUENCE "$seq_name";];
232 $data_type = defined $translate{ $data_type } ?
233 $translate{ $data_type } :
234 die "Unknown datatype: $data_type\n";
235 $field_str .= ' '.$data_type;
236 if ( $data_type =~ /(char|varbit|numeric|decimal)/i ) {
237 $field_str .= '('.join(',', @{ $field->{'size'} }).')'
238 if @{ $field->{'size'} || [] };
245 if ( defined $field->{'default'} ) {
246 $field_str .= sprintf( ' DEFAULT %s',
247 ( $field->{'is_auto_inc'} && $seq_name )
248 ? qq[nextval('"$seq_name"'::text)] :
249 ( $field->{'default'} =~ m/null/i )
251 "'".$field->{'default'}."'"
256 # Not null constraint
258 unless ( $field->{'null'} ) {
259 my $constraint_name = mk_name($field_name_ur, 'nn');
260 # $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
261 $field_str .= ' NOT NULL';
267 # if ( $field->{'is_primary_key'} ) {
268 # my $constraint_name = mk_name($field_name_ur, 'pk');
269 # $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
272 push @field_decs, $field_str;
279 my $idx_name_default;
280 for my $index ( @{ $table->{'indices'} } ) {
281 my $index_name = $index->{'name'} || '';
282 my $index_type = $index->{'type'} || 'normal';
283 my @fields = map { unreserve( $_, $table_name ) }
284 @{ $index->{'fields'} };
287 if ( $index_type eq 'primary_key' ) {
288 $index_name = mk_name( $table_name, 'pk' );
289 push @constraints, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
290 '(' . join( ', ', @fields ) . ')';
292 elsif ( $index_type eq 'unique' ) {
293 $index_name = mk_name(
294 $table_name, $index_name || ++$idx_name_default
296 push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
297 '(' . join( ', ', @fields ) . ')';
299 elsif ( $index_type eq 'normal' ) {
300 $index_name = mk_name(
301 $table_name, $index_name || ++$idx_name_default
304 qq[CREATE INDEX "$index_name" on $table_name_ur (].
305 join( ', ', @fields ).
309 warn "Unknown index type ($index_type) on table $table_name.\n"
314 my $create_statement;
315 $create_statement = qq[DROP TABLE "$table_name_ur";\n]
317 $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
318 join( ",\n", map { " $_" } @field_decs, @constraints ).
322 $output .= join( "\n\n",
333 warn "Truncated " . keys( %truncated ) . " names:\n";
334 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
338 warn "Encounted " . keys( %unreserve ) .
339 " unsafe names in schema (reserved or invalid):\n";
340 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
347 # -------------------------------------------------------------------
349 my ($basename, $type, $scope, $critical) = @_;
350 my $basename_orig = $basename;
352 ? $max_id_length - (length($type) + 1)
354 $basename = substr( $basename, 0, $max_name )
355 if length( $basename ) > $max_name;
356 my $name = $type ? "${type}_$basename" : $basename;
358 if ( $basename ne $basename_orig and $critical ) {
359 my $show_type = $type ? "+'$type'" : "";
360 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
361 "character limit to make '$name'\n" if $WARN;
362 $truncated{ $basename_orig } = $name;
365 $scope ||= \%global_names;
366 if ( my $prev = $scope->{ $name } ) {
367 my $name_orig = $name;
368 $name .= sprintf( "%02d", ++$prev );
369 substr($name, $max_id_length - 3) = "00"
370 if length( $name ) > $max_id_length;
372 warn "The name '$name_orig' has been changed to ",
373 "'$name' to make it unique.\n" if $WARN;
375 $scope->{ $name_orig }++;
382 # -------------------------------------------------------------------
384 my ( $name, $schema_obj_name ) = @_;
385 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
387 # also trap fields that don't begin with a letter
388 return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
390 if ( $schema_obj_name ) {
391 ++$unreserve{"$schema_obj_name.$name"};
394 ++$unreserve{"$name (table name)"};
397 my $unreserve = sprintf '%s_', $name;
398 return $unreserve.$suffix;
403 # -------------------------------------------------------------------
404 # Life is full of misery, loneliness, and suffering --
405 # and it's all over much too soon.
407 # -------------------------------------------------------------------
413 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>