[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Producer / PostgreSQL.pm

package SQL::Translator::Producer::PostgreSQL;

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.6 2003-01-27 17:04:48 dlc Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>,
#                    Chris Mungall <cjm@fruitfly.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator

=cut

use strict;
use vars qw[ $DEBUG $WARN $VERSION ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

use Data::Dumper;

my %translate  = (
    #
    # MySQL types
    #
    bigint     => 'bigint',
    double     => 'double precision',
    decimal    => 'decimal',
    float      => 'double precision',
    int        => 'integer',
    mediumint  => 'integer',
    smallint   => 'smallint',
    tinyint    => 'smallint',
    char       => 'char',
    varchar    => 'character varying',
    longtext   => 'text',
    mediumtext => 'text',
    text       => 'text',
    tinytext   => 'text',
    tinyblob   => 'bytea',
    blob       => 'bytea',
    mediumblob => 'bytea',
    longblob   => 'bytea',
    enum       => 'character varying',
    set        => 'character varying',
    date       => 'date',
    datetime   => 'timestamp',
    time       => 'date',
    timestamp  => 'timestamp',
    year       => 'date',

    #
    # Oracle types
    #
    number     => 'integer',
    char       => 'char',
    varchar2   => 'character varying',
    long       => 'text',
    CLOB       => 'bytea',
    date       => 'date',

    #
    # Sybase types
    #
    int        => 'integer',
    money      => 'money',
    varchar    => 'character varying',
    datetime   => 'timestamp',
    text       => 'text',
    real       => 'double precision',
    comment    => 'text',
    bit        => 'bit',
    tinyint    => 'smallint',
    float      => 'double precision',
);

my %reserved = map { $_, 1 } qw[
    ALL ANALYSE ANALYZE AND ANY AS ASC 
    BETWEEN BINARY BOTH
    CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
    CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER 
    DEFAULT DEFERRABLE DESC DISTINCT DO
    ELSE END EXCEPT
    FALSE FOR FOREIGN FREEZE FROM FULL 
    GROUP HAVING 
    ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL 
    JOIN LEADING LEFT LIKE LIMIT 
    NATURAL NEW NOT NOTNULL NULL
    OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
    PRIMARY PUBLIC REFERENCES RIGHT 
    SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE 
    UNION UNIQUE USER USING VERBOSE WHEN WHERE
];

my $max_id_length    = 30;
my %used_identifiers = ();
my %global_names;
my %unreserve;
my %truncated;

=pod

=head1 PostgreSQL Create Table Syntax

  CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
      { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
      | table_constraint }  [, ... ]
  )
  [ INHERITS ( parent_table [, ... ] ) ]
  [ WITH OIDS | WITHOUT OIDS ]

where column_constraint is:

  [ CONSTRAINT constraint_name ]
  { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
    CHECK (expression) |
    REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
      [ ON DELETE action ] [ ON UPDATE action ] }
  [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]

and table_constraint is:

  [ CONSTRAINT constraint_name ]
  { UNIQUE ( column_name [, ... ] ) |
    PRIMARY KEY ( column_name [, ... ] ) |
    CHECK ( expression ) |
    FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
      [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
  [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]

=head1 Create Index Syntax

  CREATE [ UNIQUE ] INDEX index_name ON table
      [ USING acc_method ] ( column [ ops_name ] [, ...] )
      [ WHERE predicate ]
  CREATE [ UNIQUE ] INDEX index_name ON table
      [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
      [ WHERE predicate ]

=cut

# -------------------------------------------------------------------
sub produce {
    my ( $translator, $data ) = @_;
    $DEBUG                    = $translator->debug;
    $WARN                     = $translator->show_warnings;
    my $no_comments           = $translator->no_comments;
    my $add_drop_table        = $translator->add_drop_table;

    my $output;
    unless ( $no_comments ) {
        $output .=  sprintf 
            "--\n-- Created by %s\n-- Created on %s\n--\n\n",
            __PACKAGE__, scalar localtime;
    }

    for my $table ( 
        map  { $_->[1] }
        sort { $a->[0] <=> $b->[0] }
        map  { [ $_->{'order'}, $_ ] }
        values %$data
   ) {
        my $table_name    = $table->{'table_name'};
        $table_name       = mk_name( $table_name, '', undef, 1 );
        my $table_name_ur = unreserve($table_name);

        my ( @comments, @field_decs, @sequence_decs, @constraints );

        push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;

        #
        # Fields
        #
        my %field_name_scope;
        for my $field ( 
            map  { $_->[1] }
            sort { $a->[0] <=> $b->[0] }
            map  { [ $_->{'order'}, $_ ] }
            values %{ $table->{'fields'} }
        ) {
            my $field_name    = mk_name(
                $field->{'name'}, '', \%field_name_scope, 1 
            );
            my $field_name_ur = unreserve( $field_name, $table_name );
            my $field_str     = qq["$field_name_ur"];

            #
            # Datatype
            #
            my $data_type = lc $field->{'data_type'};
            my $list      = $field->{'list'} || [];
            my $commalist = join ",", @$list;
            my $seq_name;

            if ( $data_type eq 'enum' ) {
                my $len = 0;
                $len = ($len < length($_)) ? length($_) : $len for (@$list);
                my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
                push @constraints, 
                "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
                $field_str .= " character varying($len)";
            }
            elsif ( $data_type eq 'set' ) {
                # XXX add a CHECK constraint maybe 
                # (trickier and slower, than enum :)
                my $len     = length $commalist;
                $field_str .= " character varying($len) /* set $commalist */";
            }
            elsif ( $field->{'is_auto_inc'} ) {
                $field_str .= ' serial';
                $seq_name   = mk_name( $table_name.'_'.$field_name, 'sq' );
                push @sequence_decs, qq[DROP SEQUENCE "$seq_name";];
                push @sequence_decs, qq[CREATE SEQUENCE "$seq_name";];
            }
            else {
                $data_type  = defined $translate{ $data_type } ?
                              $translate{ $data_type } :
                              die "Unknown datatype: $data_type\n";
                $field_str .= ' '.$data_type;
                if ( $data_type =~ /(char|varbit|numeric|decimal)/i ) {
                    $field_str .= '('.join(',', @{ $field->{'size'} }).')' 
                        if @{ $field->{'size'} || [] };
                }
            }

            #
            # Default value
            #
            if ( defined $field->{'default'} ) {
                $field_str .= sprintf( ' DEFAULT %s',
                    ( $field->{'is_auto_inc'} && $seq_name )
                    ? qq[nextval('"$seq_name"'::text)] :
                    ( $field->{'default'} =~ m/null/i )
                    ? 'NULL' : 
                    "'".$field->{'default'}."'"
                );
            }

            #
            # Not null constraint
            #
            unless ( $field->{'null'} ) {
                my $constraint_name = mk_name($field_name_ur, 'nn');
#                $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
                $field_str .= ' NOT NULL';
            }

            #
            # Primary key
            #
#            if ( $field->{'is_primary_key'} ) {
#                my $constraint_name = mk_name($field_name_ur, 'pk');
#                $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
#            }

            push @field_decs, $field_str;
        }

        #
        # Index Declarations
        #
        my @index_decs = ();
        my $idx_name_default;
        for my $index ( @{ $table->{'indices'} } ) {
            my $index_name = $index->{'name'} || '';
            my $index_type = $index->{'type'} || 'normal';
            my @fields     = map { unreserve( $_, $table_name ) }
                             @{ $index->{'fields'} };
            next unless @fields;

            if ( $index_type eq 'primary_key' ) {
                $index_name = mk_name( $table_name, 'pk' );
                push @constraints, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $index_type eq 'unique' ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $index_type eq 'normal' ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @index_decs, 
                    qq[CREATE INDEX "$index_name" on $table_name_ur (].
                        join( ', ', @fields ).  
                    ');'; 
            }
            else {
                warn "Unknown index type ($index_type) on table $table_name.\n"
                    if $WARN;
            }
        }

        my $create_statement;
        $create_statement  = qq[DROP TABLE "$table_name_ur";\n] 
            if $add_drop_table;
        $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
            join( ",\n", map { "  $_" } @field_decs, @constraints ).
            "\n);"
        ;

        $output .= join( "\n\n", 
            @comments,
            @sequence_decs, 
            $create_statement, 
            @index_decs, 
            '' 
        );
    }

    if ( $WARN ) {
        if ( %truncated ) {
            warn "Truncated " . keys( %truncated ) . " names:\n";
            warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
        }

        if ( %unreserve ) {
            warn "Encounted " . keys( %unreserve ) .
                " unsafe names in schema (reserved or invalid):\n";
            warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
        }
    }

    return $output;
}

# -------------------------------------------------------------------
sub mk_name {
    my ($basename, $type, $scope, $critical) = @_;
    my $basename_orig = $basename;
    my $max_name      = $type 
                        ? $max_id_length - (length($type) + 1) 
                        : $max_id_length;
    $basename         = substr( $basename, 0, $max_name ) 
                        if length( $basename ) > $max_name;
    my $name          = $type ? "${type}_$basename" : $basename;

    if ( $basename ne $basename_orig and $critical ) {
        my $show_type = $type ? "+'$type'" : "";
        warn "Truncating '$basename_orig'$show_type to $max_id_length ",
            "character limit to make '$name'\n" if $WARN;
        $truncated{ $basename_orig } = $name;
    }

    $scope ||= \%global_names;
    if ( my $prev = $scope->{ $name } ) {
        my $name_orig = $name;
        $name        .= sprintf( "%02d", ++$prev );
        substr($name, $max_id_length - 3) = "00" 
            if length( $name ) > $max_id_length;

        warn "The name '$name_orig' has been changed to ",
             "'$name' to make it unique.\n" if $WARN;

        $scope->{ $name_orig }++;
    }

    $scope->{ $name }++;
    return $name;
}

# -------------------------------------------------------------------
sub unreserve {
    my ( $name, $schema_obj_name ) = @_;
    my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';

    # also trap fields that don't begin with a letter
    return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i; 

    if ( $schema_obj_name ) {
        ++$unreserve{"$schema_obj_name.$name"};
    }
    else {
        ++$unreserve{"$name (table name)"};
    }

    my $unreserve = sprintf '%s_', $name;
    return $unreserve.$suffix;
}

1;

# -------------------------------------------------------------------
# Life is full of misery, loneliness, and suffering --
# and it's all over much too soon.
# Woody Allen
# -------------------------------------------------------------------

=pod

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>

=cut
Commit	Line	Data
f8f0253c	1	package SQL::Translator::Producer::PostgreSQL;
	2
	3	# -------------------------------------------------------------------
abfa405a	4	# $Id: PostgreSQL.pm,v 1.6 2003-01-27 17:04:48 dlc Exp $
f8f0253c	5	# -------------------------------------------------------------------
abfa405a	6	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
	7	# darren chamberlain <darren@cpan.org>,
	8	# Chris Mungall <cjm@fruitfly.org>
f8f0253c	9	#
	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.
	13	#
	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.
	18	#
	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
	22	# 02111-1307 USA
	23	# -------------------------------------------------------------------
	24
96844cae	25	=head1 NAME
	26
	27	SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
	28
	29	=cut
	30
f8f0253c	31	use strict;
96844cae	32	use vars qw[ $DEBUG $WARN $VERSION ];
abfa405a	33	$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
f8f0253c	34	$DEBUG = 1 unless defined $DEBUG;
	35
	36	use Data::Dumper;
	37
d529894e	38	my %translate = (
	39	#
	40	# MySQL types
	41	#
	42	bigint => 'bigint',
	43	double => 'double precision',
	44	decimal => 'decimal',
	45	float => 'double precision',
	46	int => 'integer',
	47	mediumint => 'integer',
	48	smallint => 'smallint',
	49	tinyint => 'smallint',
	50	char => 'char',
da8e499e	51	varchar => 'character varying',
d529894e	52	longtext => 'text',
	53	mediumtext => 'text',
	54	text => 'text',
	55	tinytext => 'text',
	56	tinyblob => 'bytea',
	57	blob => 'bytea',
	58	mediumblob => 'bytea',
	59	longblob => 'bytea',
da8e499e	60	enum => 'character varying',
da8e499e	61	set => 'character varying',
d529894e	62	date => 'date',
	63	datetime => 'timestamp',
	64	time => 'date',
	65	timestamp => 'timestamp',
	66	year => 'date',
	67
	68	#
	69	# Oracle types
	70	#
96844cae	71	number => 'integer',
96844cae	72	char => 'char',
da8e499e	73	varchar2 => 'character varying',
96844cae	74	long => 'text',
	75	CLOB => 'bytea',
	76	date => 'date',
	77
	78	#
	79	# Sybase types
	80	#
	81	int => 'integer',
	82	money => 'money',
da8e499e	83	varchar => 'character varying',
96844cae	84	datetime => 'timestamp',
	85	text => 'text',
	86	real => 'double precision',
	87	comment => 'text',
	88	bit => 'bit',
	89	tinyint => 'smallint',
	90	float => 'double precision',
d529894e	91	);
d529894e	92
96844cae	93	my %reserved = map { $_, 1 } qw[
	94	ALL ANALYSE ANALYZE AND ANY AS ASC
	95	BETWEEN BINARY BOTH
	96	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	97	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	98	DEFAULT DEFERRABLE DESC DISTINCT DO
	99	ELSE END EXCEPT
	100	FALSE FOR FOREIGN FREEZE FROM FULL
	101	GROUP HAVING
	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
	109	];
d529894e	110
96844cae	111	my $max_id_length = 30;
	112	my %used_identifiers = ();
	113	my %global_names;
	114	my %unreserve;
	115	my %truncated;
	116
	117	=pod
	118
	119	=head1 PostgreSQL Create Table Syntax
	120
	121	CREATE [ [ LOCAL ] { TEMPORARY \| TEMP } ] TABLE table_name (
	122	{ column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
	123	\| table_constraint } [, ... ]
	124	)
	125	[ INHERITS ( parent_table [, ... ] ) ]
	126	[ WITH OIDS \| WITHOUT OIDS ]
	127
	128	where column_constraint is:
	129
	130	[ CONSTRAINT constraint_name ]
	131	{ NOT NULL \| NULL \| UNIQUE \| PRIMARY KEY \|
	132	CHECK (expression) \|
	133	REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL \| MATCH PARTIAL ]
	134	[ ON DELETE action ] [ ON UPDATE action ] }
	135	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	136
	137	and table_constraint is:
	138
	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 ]
	146
da8e499e	147	=head1 Create Index Syntax
	148
	149	CREATE [ UNIQUE ] INDEX index_name ON table
	150	[ USING acc_method ] ( column [ ops_name ] [, ...] )
	151	[ WHERE predicate ]
	152	CREATE [ UNIQUE ] INDEX index_name ON table
	153	[ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
	154	[ WHERE predicate ]
	155
96844cae	156	=cut
f8f0253c	157
96844cae	158	# -------------------------------------------------------------------
f8f0253c	159	sub produce {
f8f0253c	160	my ( $translator, $data ) = @_;
96844cae	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;
	165
da8e499e	166	my $output;
96844cae	167	unless ( $no_comments ) {
da8e499e	168	$output .= sprintf
96844cae	169	"--\n-- Created by %s\n-- Created on %s\n--\n\n",
	170	__PACKAGE__, scalar localtime;
	171	}
	172
	173	for my $table (
	174	map { $_->[1] }
	175	sort { $a->[0] <=> $b->[0] }
	176	map { [ $_->{'order'}, $_ ] }
	177	values %$data
	178	) {
da8e499e	179	my $table_name = $table->{'table_name'};
	180	$table_name = mk_name( $table_name, '', undef, 1 );
	181	my $table_name_ur = unreserve($table_name);
	182
	183	my ( @comments, @field_decs, @sequence_decs, @constraints );
96844cae	184
da8e499e	185	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
f8f0253c	186
	187	#
	188	# Fields
	189	#
96844cae	190	my %field_name_scope;
da8e499e	191	for my $field (
	192	map { $_->[1] }
	193	sort { $a->[0] <=> $b->[0] }
	194	map { [ $_->{'order'}, $_ ] }
	195	values %{ $table->{'fields'} }
	196	) {
96844cae	197	my $field_name = mk_name(
	198	$field->{'name'}, '', \%field_name_scope, 1
	199	);
	200	my $field_name_ur = unreserve( $field_name, $table_name );
da8e499e	201	my $field_str = qq["$field_name_ur"];
	202
	203	#
	204	# Datatype
	205	#
	206	my $data_type = lc $field->{'data_type'};
	207	my $list = $field->{'list'} \|\| [];
	208	my $commalist = join ",", @$list;
	209	my $seq_name;
	210
	211	if ( $data_type eq 'enum' ) {
	212	my $len = 0;
	213	$len = ($len < length($_)) ? length($_) : $len for (@$list);
	214	my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
	215	push @constraints,
	216	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
	217	$field_str .= " character varying($len)";
	218	}
	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 */";
	224	}
	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";];
	230	}
	231	else {
	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'} \|\| [] };
	239	}
f8f0253c	240	}
f8f0253c	241
da8e499e	242	#
	243	# Default value
	244	#
	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 )
	250	? 'NULL' :
	251	"'".$field->{'default'}."'"
	252	);
	253	}
f8f0253c	254
da8e499e	255	#
	256	# Not null constraint
	257	#
	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';
	262	}
f8f0253c	263
da8e499e	264	#
	265	# Primary key
	266	#
	267	# if ( $field->{'is_primary_key'} ) {
	268	# my $constraint_name = mk_name($field_name_ur, 'pk');
	269	# $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
	270	# }
f8f0253c	271
da8e499e	272	push @field_decs, $field_str;
f8f0253c	273	}
f8f0253c	274
f8f0253c	275	#
da8e499e	276	# Index Declarations
f8f0253c	277	#
da8e499e	278	my @index_decs = ();
	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'} };
	285	next unless @fields;
	286
	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 ) . ')';
	291	}
	292	elsif ( $index_type eq 'unique' ) {
	293	$index_name = mk_name(
	294	$table_name, $index_name \|\| ++$idx_name_default
	295	);
	296	push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
	297	'(' . join( ', ', @fields ) . ')';
	298	}
	299	elsif ( $index_type eq 'normal' ) {
	300	$index_name = mk_name(
	301	$table_name, $index_name \|\| ++$idx_name_default
	302	);
	303	push @index_decs,
	304	qq[CREATE INDEX "$index_name" on $table_name_ur (].
	305	join( ', ', @fields ).
	306	');';
	307	}
f8f0253c	308	else {
da8e499e	309	warn "Unknown index type ($index_type) on table $table_name.\n"
da8e499e	310	if $WARN;
f8f0253c	311	}
	312	}
	313
da8e499e	314	my $create_statement;
	315	$create_statement = qq[DROP TABLE "$table_name_ur";\n]
	316	if $add_drop_table;
	317	$create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
	318	join( ",\n", map { " $_" } @field_decs, @constraints ).
	319	"\n);"
	320	;
	321
	322	$output .= join( "\n\n",
	323	@comments,
	324	@sequence_decs,
	325	$create_statement,
	326	@index_decs,
	327	''
	328	);
	329	}
	330
	331	if ( $WARN ) {
	332	if ( %truncated ) {
	333	warn "Truncated " . keys( %truncated ) . " names:\n";
	334	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	335	}
	336
	337	if ( %unreserve ) {
	338	warn "Encounted " . keys( %unreserve ) .
	339	" unsafe names in schema (reserved or invalid):\n";
	340	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	341	}
f8f0253c	342	}
f8f0253c	343
da8e499e	344	return $output;
f8f0253c	345	}
f8f0253c	346
96844cae	347	# -------------------------------------------------------------------
	348	sub mk_name {
	349	my ($basename, $type, $scope, $critical) = @_;
	350	my $basename_orig = $basename;
2ad4c2c8	351	my $max_name = $type
	352	? $max_id_length - (length($type) + 1)
	353	: $max_id_length;
96844cae	354	$basename = substr( $basename, 0, $max_name )
	355	if length( $basename ) > $max_name;
	356	my $name = $type ? "${type}_$basename" : $basename;
	357
	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;
	363	}
	364
	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;
	371
	372	warn "The name '$name_orig' has been changed to ",
	373	"'$name' to make it unique.\n" if $WARN;
	374
	375	$scope->{ $name_orig }++;
f8f0253c	376	}
96844cae	377
	378	$scope->{ $name }++;
	379	return $name;
	380	}
	381
	382	# -------------------------------------------------------------------
	383	sub unreserve {
	384	my ( $name, $schema_obj_name ) = @_;
	385	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	386
	387	# also trap fields that don't begin with a letter
	388	return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
	389
	390	if ( $schema_obj_name ) {
	391	++$unreserve{"$schema_obj_name.$name"};
	392	}
	393	else {
	394	++$unreserve{"$name (table name)"};
	395	}
	396
	397	my $unreserve = sprintf '%s_', $name;
	398	return $unreserve.$suffix;
f8f0253c	399	}
	400
	401	1;
f8f0253c	402
96844cae	403	# -------------------------------------------------------------------
	404	# Life is full of misery, loneliness, and suffering --
	405	# and it's all over much too soon.
	406	# Woody Allen
	407	# -------------------------------------------------------------------
f8f0253c	408
96844cae	409	=pod
f8f0253c	410
	411	=head1 AUTHOR
	412
	413	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	414
	415	=cut