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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.9 2003-06-09 01:59:21 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.9 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils qw(header_comment);
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 $schema                = $translator->schema;

    my $output;
    $output .= header_comment unless ($no_comments);

    for my $table ( $schema->get_tables ) {
        my $table_name    = $table->name or next;
        $table_name       = mk_name( $table_name, '', undef, 1 );
        my $table_name_ur = unreserve($table_name);

        my ( @comments, @field_defs, @sequence_defs, @constraint_defs );

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

        #
        # Fields
        #
        my %field_name_scope;
        for my $field ( $table->get_fields ) {
            my $field_name    = mk_name(
                $field->name, '', \%field_name_scope, 1 
            );
            my $field_name_ur = unreserve( $field_name, $table_name );
            my $field_def     = qq["$field_name_ur"];

            #
            # Datatype
            #
            my @size      = $field->size;
            my $data_type = lc $field->data_type;
            my %extra     = $field->extra;
            my $list      = $extra{'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 @constraint_defs, 
                "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
                $data_type = 'character varying';
            }
            elsif ( $data_type eq 'set' ) {
                # XXX add a CHECK constraint maybe 
                # (trickier and slower, than enum :)
#                my $len     = length $commalist;
#                $field_def .= " character varying($len) /* set $commalist */";
                $data_type = 'character varying';
            }
            elsif ( $field->is_auto_increment ) {
                $field_def .= ' serial';
#                $seq_name   = mk_name( $table_name.'_'.$field_name, 'sq' );
#                push @sequence_defs, qq[DROP SEQUENCE "$seq_name";];
#                push @sequence_defs, qq[CREATE SEQUENCE "$seq_name";];
            }
            else {
                $data_type  = defined $translate{ $data_type } ?
                              $translate{ $data_type } :
                              die "Unknown datatype: $data_type\n";
            }

            $field_def .= " $data_type";

            if ( defined $size[0] && $size[0] > 0 ) {
                $field_def .= '(' . join( ', ', @size ) . ')';
            }

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

            #
            # Not null constraint
            #
            $field_def .= ' NOT NULL' unless $field->is_nullable;

            push @field_defs, $field_def;
        }

        #
        # Index Declarations
        #
        my @index_defs = ();
        my $idx_name_default;
        for my $index ( $table->get_indices ) {
            my $name = $index->name || '';
            my $type = $index->type || NORMAL;
            my @fields     = 
                map { $_ =~ s/\(.+\)//; $_ }
                map { unreserve( $_, $table_name ) }
                $index->fields;
            next unless @fields;

            if ( $type eq PRIMARY_KEY ) {
                $name ||= mk_name( $table_name, 'pk' );
                push @constraint_defs, 'CONSTRAINT '.$name.' PRIMARY KEY '.
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $type eq UNIQUE ) {
                $name ||= mk_name( 
                    $table_name, $name || ++$idx_name_default
                );
                push @constraint_defs, 'CONSTRAINT ' . $name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $type eq NORMAL ) {
                $name ||= mk_name( 
                    $table_name, $name || ++$idx_name_default
                );
                push @index_defs, 
                    qq[CREATE INDEX "$name" on $table_name_ur (].
                        join( ', ', @fields ).  
                    ');'; 
            }
            else {
                warn "Unknown index type ($type) on table $table_name.\n"
                    if $WARN;
            }
        }

        #
        # Table constraints
        #
        my $c_name_default;
        for my $c ( $table->get_constraints ) {
            my $name = $c->name || '';
            my @fields     = 
                map { $_ =~ s/\(.+\)//; $_ }
                map { unreserve( $_, $table_name ) }
                $c->fields;
            my @rfields     = 
                map { $_ =~ s/\(.+\)//; $_ }
                map { unreserve( $_, $table_name ) }
                $c->reference_fields;
            next unless @fields;

            if ( $c->type eq PRIMARY_KEY ) {
                $name ||= mk_name( $table_name, 'pk' );
                push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $c->type eq UNIQUE ) {
                $name ||= mk_name( 
                    $table_name, $name || ++$c_name_default
                );
                push @constraint_defs, "CONSTRAINT $name UNIQUE " .
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $c->type eq FOREIGN_KEY ) {
                my $def = join(' ', 
                    map { $_ || () } 'FOREIGN KEY', $c->name 
                );

                $def .= ' (' . join( ', ', @fields ) . ')';

                $def .= ' REFERENCES ' . $c->reference_table;

                if ( @rfields ) {
                    $def .= ' (' . join( ', ', @rfields ) . ')';
                }

                if ( $c->match_type ) {
                    $def .= ' MATCH ' . 
                        ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
                }

                if ( $c->on_delete ) {
                    $def .= ' ON DELETE '.join( ' ', $c->on_delete );
                }

                if ( $c->on_update ) {
                    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
                }

                push @constraint_defs, $def;
            }
        }

        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_defs, @constraint_defs ).
            "\n);"
        ;

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

    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      = shift || ''; 
    my $type          = shift || ''; 
    my $scope         = shift || ''; 
    my $critical      = shift || '';
    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            = shift || '';
    my $schema_obj_name = shift || '';

    my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';

    # also trap fields that don't begin with a letter
    return $name 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	# -------------------------------------------------------------------
0c43e0a1	4	# $Id: PostgreSQL.pm,v 1.9 2003-06-09 01:59:21 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 ];
0c43e0a1	33	$VERSION = sprintf "%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/;
f8f0253c	34	$DEBUG = 1 unless defined $DEBUG;
f8f0253c	35
0c43e0a1	36	use SQL::Translator::Schema::Constants;
5ee19df8	37	use SQL::Translator::Utils qw(header_comment);
f8f0253c	38	use Data::Dumper;
f8f0253c	39
d529894e	40	my %translate = (
	41	#
	42	# MySQL types
	43	#
	44	bigint => 'bigint',
	45	double => 'double precision',
	46	decimal => 'decimal',
	47	float => 'double precision',
	48	int => 'integer',
	49	mediumint => 'integer',
	50	smallint => 'smallint',
	51	tinyint => 'smallint',
	52	char => 'char',
da8e499e	53	varchar => 'character varying',
d529894e	54	longtext => 'text',
	55	mediumtext => 'text',
	56	text => 'text',
	57	tinytext => 'text',
	58	tinyblob => 'bytea',
	59	blob => 'bytea',
	60	mediumblob => 'bytea',
	61	longblob => 'bytea',
da8e499e	62	enum => 'character varying',
da8e499e	63	set => 'character varying',
d529894e	64	date => 'date',
	65	datetime => 'timestamp',
	66	time => 'date',
	67	timestamp => 'timestamp',
	68	year => 'date',
	69
	70	#
	71	# Oracle types
	72	#
96844cae	73	number => 'integer',
96844cae	74	char => 'char',
da8e499e	75	varchar2 => 'character varying',
96844cae	76	long => 'text',
	77	CLOB => 'bytea',
	78	date => 'date',
	79
	80	#
	81	# Sybase types
	82	#
	83	int => 'integer',
	84	money => 'money',
da8e499e	85	varchar => 'character varying',
96844cae	86	datetime => 'timestamp',
	87	text => 'text',
	88	real => 'double precision',
	89	comment => 'text',
	90	bit => 'bit',
	91	tinyint => 'smallint',
	92	float => 'double precision',
d529894e	93	);
d529894e	94
96844cae	95	my %reserved = map { $_, 1 } qw[
	96	ALL ANALYSE ANALYZE AND ANY AS ASC
	97	BETWEEN BINARY BOTH
	98	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	99	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	100	DEFAULT DEFERRABLE DESC DISTINCT DO
	101	ELSE END EXCEPT
	102	FALSE FOR FOREIGN FREEZE FROM FULL
	103	GROUP HAVING
	104	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	105	JOIN LEADING LEFT LIKE LIMIT
	106	NATURAL NEW NOT NOTNULL NULL
	107	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	108	PRIMARY PUBLIC REFERENCES RIGHT
	109	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	110	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	111	];
d529894e	112
96844cae	113	my $max_id_length = 30;
	114	my %used_identifiers = ();
	115	my %global_names;
	116	my %unreserve;
	117	my %truncated;
	118
	119	=pod
	120
	121	=head1 PostgreSQL Create Table Syntax
	122
	123	CREATE [ [ LOCAL ] { TEMPORARY \| TEMP } ] TABLE table_name (
	124	{ column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
	125	\| table_constraint } [, ... ]
	126	)
	127	[ INHERITS ( parent_table [, ... ] ) ]
	128	[ WITH OIDS \| WITHOUT OIDS ]
	129
	130	where column_constraint is:
	131
	132	[ CONSTRAINT constraint_name ]
	133	{ NOT NULL \| NULL \| UNIQUE \| PRIMARY KEY \|
	134	CHECK (expression) \|
	135	REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL \| MATCH PARTIAL ]
	136	[ ON DELETE action ] [ ON UPDATE action ] }
	137	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	138
	139	and table_constraint is:
	140
	141	[ CONSTRAINT constraint_name ]
	142	{ UNIQUE ( column_name [, ... ] ) \|
	143	PRIMARY KEY ( column_name [, ... ] ) \|
	144	CHECK ( expression ) \|
	145	FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
	146	[ MATCH FULL \| MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
	147	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	148
da8e499e	149	=head1 Create Index Syntax
	150
	151	CREATE [ UNIQUE ] INDEX index_name ON table
	152	[ USING acc_method ] ( column [ ops_name ] [, ...] )
	153	[ WHERE predicate ]
	154	CREATE [ UNIQUE ] INDEX index_name ON table
	155	[ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
	156	[ WHERE predicate ]
	157
96844cae	158	=cut
f8f0253c	159
96844cae	160	# -------------------------------------------------------------------
f8f0253c	161	sub produce {
f8f0253c	162	my ( $translator, $data ) = @_;
96844cae	163	$DEBUG = $translator->debug;
	164	$WARN = $translator->show_warnings;
	165	my $no_comments = $translator->no_comments;
	166	my $add_drop_table = $translator->add_drop_table;
0c43e0a1	167	my $schema = $translator->schema;
96844cae	168
da8e499e	169	my $output;
5ee19df8	170	$output .= header_comment unless ($no_comments);
96844cae	171
0c43e0a1	172	for my $table ( $schema->get_tables ) {
0c43e0a1	173	my $table_name = $table->name or next;
da8e499e	174	$table_name = mk_name( $table_name, '', undef, 1 );
	175	my $table_name_ur = unreserve($table_name);
	176
0c43e0a1	177	my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
96844cae	178
da8e499e	179	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
f8f0253c	180
	181	#
	182	# Fields
	183	#
96844cae	184	my %field_name_scope;
0c43e0a1	185	for my $field ( $table->get_fields ) {
96844cae	186	my $field_name = mk_name(
0c43e0a1	187	$field->name, '', \%field_name_scope, 1
96844cae	188	);
96844cae	189	my $field_name_ur = unreserve( $field_name, $table_name );
0c43e0a1	190	my $field_def = qq["$field_name_ur"];
da8e499e	191
	192	#
	193	# Datatype
	194	#
0c43e0a1	195	my @size = $field->size;
	196	my $data_type = lc $field->data_type;
	197	my %extra = $field->extra;
	198	my $list = $extra{'list'} \|\| [];
da8e499e	199	my $commalist = join ",", @$list;
	200	my $seq_name;
	201
	202	if ( $data_type eq 'enum' ) {
	203	my $len = 0;
	204	$len = ($len < length($_)) ? length($_) : $len for (@$list);
	205	my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
0c43e0a1	206	push @constraint_defs,
da8e499e	207	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
0c43e0a1	208	$data_type = 'character varying';
da8e499e	209	}
	210	elsif ( $data_type eq 'set' ) {
	211	# XXX add a CHECK constraint maybe
	212	# (trickier and slower, than enum :)
0c43e0a1	213	# my $len = length $commalist;
	214	# $field_def .= " character varying($len) /* set $commalist */";
	215	$data_type = 'character varying';
da8e499e	216	}
0c43e0a1	217	elsif ( $field->is_auto_increment ) {
	218	$field_def .= ' serial';
	219	# $seq_name = mk_name( $table_name.'_'.$field_name, 'sq' );
	220	# push @sequence_defs, qq[DROP SEQUENCE "$seq_name";];
	221	# push @sequence_defs, qq[CREATE SEQUENCE "$seq_name";];
da8e499e	222	}
	223	else {
	224	$data_type = defined $translate{ $data_type } ?
	225	$translate{ $data_type } :
	226	die "Unknown datatype: $data_type\n";
0c43e0a1	227	}
	228
	229	$field_def .= " $data_type";
	230
	231	if ( defined $size[0] && $size[0] > 0 ) {
	232	$field_def .= '(' . join( ', ', @size ) . ')';
f8f0253c	233	}
f8f0253c	234
da8e499e	235	#
	236	# Default value
	237	#
0c43e0a1	238	my $default = $field->default_value;
	239	if ( defined $default ) {
	240	$field_def .= sprintf( ' DEFAULT %s',
	241	( $field->is_auto_increment && $seq_name )
da8e499e	242	? qq[nextval('"$seq_name"'::text)] :
0c43e0a1	243	( $default =~ m/null/i ) ? 'NULL' : "'$default'"
da8e499e	244	);
da8e499e	245	}
f8f0253c	246
da8e499e	247	#
	248	# Not null constraint
	249	#
0c43e0a1	250	$field_def .= ' NOT NULL' unless $field->is_nullable;
f8f0253c	251
0c43e0a1	252	push @field_defs, $field_def;
f8f0253c	253	}
f8f0253c	254
f8f0253c	255	#
da8e499e	256	# Index Declarations
f8f0253c	257	#
0c43e0a1	258	my @index_defs = ();
da8e499e	259	my $idx_name_default;
0c43e0a1	260	for my $index ( $table->get_indices ) {
	261	my $name = $index->name \|\| '';
	262	my $type = $index->type \|\| NORMAL;
d8dcdb7a	263	my @fields =
	264	map { $_ =~ s/\(.+\)//; $_ }
	265	map { unreserve( $_, $table_name ) }
0c43e0a1	266	$index->fields;
da8e499e	267	next unless @fields;
da8e499e	268
0c43e0a1	269	if ( $type eq PRIMARY_KEY ) {
	270	$name \|\|= mk_name( $table_name, 'pk' );
	271	push @constraint_defs, 'CONSTRAINT '.$name.' PRIMARY KEY '.
da8e499e	272	'(' . join( ', ', @fields ) . ')';
da8e499e	273	}
0c43e0a1	274	elsif ( $type eq UNIQUE ) {
	275	$name \|\|= mk_name(
	276	$table_name, $name \|\| ++$idx_name_default
da8e499e	277	);
0c43e0a1	278	push @constraint_defs, 'CONSTRAINT ' . $name . ' UNIQUE ' .
da8e499e	279	'(' . join( ', ', @fields ) . ')';
da8e499e	280	}
0c43e0a1	281	elsif ( $type eq NORMAL ) {
	282	$name \|\|= mk_name(
	283	$table_name, $name \|\| ++$idx_name_default
da8e499e	284	);
0c43e0a1	285	push @index_defs,
0c43e0a1	286	qq[CREATE INDEX "$name" on $table_name_ur (].
da8e499e	287	join( ', ', @fields ).
	288	');';
	289	}
f8f0253c	290	else {
0c43e0a1	291	warn "Unknown index type ($type) on table $table_name.\n"
da8e499e	292	if $WARN;
f8f0253c	293	}
	294	}
	295
0c43e0a1	296	#
	297	# Table constraints
	298	#
	299	my $c_name_default;
	300	for my $c ( $table->get_constraints ) {
	301	my $name = $c->name \|\| '';
	302	my @fields =
	303	map { $_ =~ s/\(.+\)//; $_ }
	304	map { unreserve( $_, $table_name ) }
	305	$c->fields;
	306	my @rfields =
	307	map { $_ =~ s/\(.+\)//; $_ }
	308	map { unreserve( $_, $table_name ) }
	309	$c->reference_fields;
	310	next unless @fields;
	311
	312	if ( $c->type eq PRIMARY_KEY ) {
	313	$name \|\|= mk_name( $table_name, 'pk' );
	314	push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
	315	'(' . join( ', ', @fields ) . ')';
	316	}
	317	elsif ( $c->type eq UNIQUE ) {
	318	$name \|\|= mk_name(
	319	$table_name, $name \|\| ++$c_name_default
	320	);
	321	push @constraint_defs, "CONSTRAINT $name UNIQUE " .
	322	'(' . join( ', ', @fields ) . ')';
	323	}
	324	elsif ( $c->type eq FOREIGN_KEY ) {
	325	my $def = join(' ',
	326	map { $_ \|\| () } 'FOREIGN KEY', $c->name
	327	);
	328
	329	$def .= ' (' . join( ', ', @fields ) . ')';
	330
	331	$def .= ' REFERENCES ' . $c->reference_table;
	332
	333	if ( @rfields ) {
	334	$def .= ' (' . join( ', ', @rfields ) . ')';
	335	}
	336
	337	if ( $c->match_type ) {
	338	$def .= ' MATCH ' .
	339	( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
	340	}
	341
	342	if ( $c->on_delete ) {
	343	$def .= ' ON DELETE '.join( ' ', $c->on_delete );
	344	}
	345
	346	if ( $c->on_update ) {
	347	$def .= ' ON UPDATE '.join( ' ', $c->on_update );
	348	}
	349
	350	push @constraint_defs, $def;
	351	}
	352	}
	353
da8e499e	354	my $create_statement;
	355	$create_statement = qq[DROP TABLE "$table_name_ur";\n]
	356	if $add_drop_table;
	357	$create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
0c43e0a1	358	join( ",\n", map { " $_" } @field_defs, @constraint_defs ).
da8e499e	359	"\n);"
	360	;
	361
	362	$output .= join( "\n\n",
	363	@comments,
0c43e0a1	364	@sequence_defs,
da8e499e	365	$create_statement,
0c43e0a1	366	@index_defs,
da8e499e	367	''
	368	);
	369	}
	370
	371	if ( $WARN ) {
	372	if ( %truncated ) {
	373	warn "Truncated " . keys( %truncated ) . " names:\n";
	374	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	375	}
	376
	377	if ( %unreserve ) {
	378	warn "Encounted " . keys( %unreserve ) .
	379	" unsafe names in schema (reserved or invalid):\n";
	380	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	381	}
f8f0253c	382	}
f8f0253c	383
da8e499e	384	return $output;
f8f0253c	385	}
f8f0253c	386
96844cae	387	# -------------------------------------------------------------------
96844cae	388	sub mk_name {
0c43e0a1	389	my $basename = shift \|\| '';
	390	my $type = shift \|\| '';
	391	my $scope = shift \|\| '';
	392	my $critical = shift \|\| '';
96844cae	393	my $basename_orig = $basename;
2ad4c2c8	394	my $max_name = $type
	395	? $max_id_length - (length($type) + 1)
	396	: $max_id_length;
96844cae	397	$basename = substr( $basename, 0, $max_name )
	398	if length( $basename ) > $max_name;
	399	my $name = $type ? "${type}_$basename" : $basename;
	400
	401	if ( $basename ne $basename_orig and $critical ) {
	402	my $show_type = $type ? "+'$type'" : "";
	403	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	404	"character limit to make '$name'\n" if $WARN;
	405	$truncated{ $basename_orig } = $name;
	406	}
	407
	408	$scope \|\|= \%global_names;
	409	if ( my $prev = $scope->{ $name } ) {
	410	my $name_orig = $name;
	411	$name .= sprintf( "%02d", ++$prev );
	412	substr($name, $max_id_length - 3) = "00"
	413	if length( $name ) > $max_id_length;
	414
	415	warn "The name '$name_orig' has been changed to ",
	416	"'$name' to make it unique.\n" if $WARN;
	417
	418	$scope->{ $name_orig }++;
f8f0253c	419	}
96844cae	420
	421	$scope->{ $name }++;
	422	return $name;
	423	}
	424
	425	# -------------------------------------------------------------------
	426	sub unreserve {
0c43e0a1	427	my $name = shift \|\| '';
	428	my $schema_obj_name = shift \|\| '';
	429
96844cae	430	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	431
	432	# also trap fields that don't begin with a letter
0c43e0a1	433	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
96844cae	434
	435	if ( $schema_obj_name ) {
	436	++$unreserve{"$schema_obj_name.$name"};
	437	}
	438	else {
	439	++$unreserve{"$name (table name)"};
	440	}
	441
	442	my $unreserve = sprintf '%s_', $name;
	443	return $unreserve.$suffix;
f8f0253c	444	}
	445
	446	1;
f8f0253c	447
96844cae	448	# -------------------------------------------------------------------
	449	# Life is full of misery, loneliness, and suffering --
	450	# and it's all over much too soon.
	451	# Woody Allen
	452	# -------------------------------------------------------------------
f8f0253c	453
96844cae	454	=pod
f8f0253c	455
	456	=head1 AUTHOR
	457
	458	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	459
	460	=cut