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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.7 2003-03-07 16:08:22 kycl4rk 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.7 $ =~ /(\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 { $_ =~ s/\(.+\)//; $_ }
                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	# -------------------------------------------------------------------
d8dcdb7a	4	# $Id: PostgreSQL.pm,v 1.7 2003-03-07 16:08:22 kycl4rk 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 ];
d8dcdb7a	33	$VERSION = sprintf "%d.%02d", q$Revision: 1.7 $ =~ /(\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';
d8dcdb7a	283	my @fields =
	284	map { $_ =~ s/\(.+\)//; $_ }
	285	map { unreserve( $_, $table_name ) }
	286	@{ $index->{'fields'} };
da8e499e	287	next unless @fields;
	288
	289	if ( $index_type eq 'primary_key' ) {
	290	$index_name = mk_name( $table_name, 'pk' );
	291	push @constraints, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
	292	'(' . join( ', ', @fields ) . ')';
	293	}
	294	elsif ( $index_type eq 'unique' ) {
	295	$index_name = mk_name(
	296	$table_name, $index_name \|\| ++$idx_name_default
	297	);
	298	push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
	299	'(' . join( ', ', @fields ) . ')';
	300	}
	301	elsif ( $index_type eq 'normal' ) {
	302	$index_name = mk_name(
	303	$table_name, $index_name \|\| ++$idx_name_default
	304	);
	305	push @index_decs,
	306	qq[CREATE INDEX "$index_name" on $table_name_ur (].
	307	join( ', ', @fields ).
	308	');';
	309	}
f8f0253c	310	else {
da8e499e	311	warn "Unknown index type ($index_type) on table $table_name.\n"
da8e499e	312	if $WARN;
f8f0253c	313	}
	314	}
	315
da8e499e	316	my $create_statement;
	317	$create_statement = qq[DROP TABLE "$table_name_ur";\n]
	318	if $add_drop_table;
	319	$create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
	320	join( ",\n", map { " $_" } @field_decs, @constraints ).
	321	"\n);"
	322	;
	323
	324	$output .= join( "\n\n",
	325	@comments,
	326	@sequence_decs,
	327	$create_statement,
	328	@index_decs,
	329	''
	330	);
	331	}
	332
	333	if ( $WARN ) {
	334	if ( %truncated ) {
	335	warn "Truncated " . keys( %truncated ) . " names:\n";
	336	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	337	}
	338
	339	if ( %unreserve ) {
	340	warn "Encounted " . keys( %unreserve ) .
	341	" unsafe names in schema (reserved or invalid):\n";
	342	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	343	}
f8f0253c	344	}
f8f0253c	345
da8e499e	346	return $output;
f8f0253c	347	}
f8f0253c	348
96844cae	349	# -------------------------------------------------------------------
	350	sub mk_name {
	351	my ($basename, $type, $scope, $critical) = @_;
	352	my $basename_orig = $basename;
2ad4c2c8	353	my $max_name = $type
	354	? $max_id_length - (length($type) + 1)
	355	: $max_id_length;
96844cae	356	$basename = substr( $basename, 0, $max_name )
	357	if length( $basename ) > $max_name;
	358	my $name = $type ? "${type}_$basename" : $basename;
	359
	360	if ( $basename ne $basename_orig and $critical ) {
	361	my $show_type = $type ? "+'$type'" : "";
	362	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	363	"character limit to make '$name'\n" if $WARN;
	364	$truncated{ $basename_orig } = $name;
	365	}
	366
	367	$scope \|\|= \%global_names;
	368	if ( my $prev = $scope->{ $name } ) {
	369	my $name_orig = $name;
	370	$name .= sprintf( "%02d", ++$prev );
	371	substr($name, $max_id_length - 3) = "00"
	372	if length( $name ) > $max_id_length;
	373
	374	warn "The name '$name_orig' has been changed to ",
	375	"'$name' to make it unique.\n" if $WARN;
	376
	377	$scope->{ $name_orig }++;
f8f0253c	378	}
96844cae	379
	380	$scope->{ $name }++;
	381	return $name;
	382	}
	383
	384	# -------------------------------------------------------------------
	385	sub unreserve {
	386	my ( $name, $schema_obj_name ) = @_;
	387	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	388
	389	# also trap fields that don't begin with a letter
	390	return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
	391
	392	if ( $schema_obj_name ) {
	393	++$unreserve{"$schema_obj_name.$name"};
	394	}
	395	else {
	396	++$unreserve{"$name (table name)"};
	397	}
	398
	399	my $unreserve = sprintf '%s_', $name;
	400	return $unreserve.$suffix;
f8f0253c	401	}
	402
	403	1;
f8f0253c	404
96844cae	405	# -------------------------------------------------------------------
	406	# Life is full of misery, loneliness, and suffering --
	407	# and it's all over much too soon.
	408	# Woody Allen
	409	# -------------------------------------------------------------------
f8f0253c	410
96844cae	411	=pod
f8f0253c	412
	413	=head1 AUTHOR
	414
	415	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	416
	417	=cut