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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.17 2003-09-26 22:35:23 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.17 $ =~ /(\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     => 'numeric',
    decimal    => 'numeric',
    float      => 'numeric',
    int        => 'integer',
    mediumint  => 'integer',
    smallint   => 'smallint',
    tinyint    => 'smallint',
    char       => 'character',
    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       => 'character',
    varchar2   => 'character varying',
    long       => 'text',
    CLOB       => 'bytea',
    date       => 'date',

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

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     = shift;
    $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);
    my %used_index_names;

    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'} || [];
            # todo deal with embedded quotes
            my $commalist = join( ', ', map { qq['$_'] } @$list );
            my $seq_name;

            if ( $data_type eq 'enum' ) {
                my $len = 0;
                $len = ($len < length($_)) ? length($_) : $len for (@$list);
                my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
                push @constraint_defs, 
                    qq[Constraint "$chk_name" CHECK ("$field_name" ].
                    qq[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 ) {
                if ( defined $size[0] && $size[0] > 11 ) {
                    $data_type = 'bigserial';
                }
                else {
                    $data_type = 'serial';
                }
                undef @size;

#                $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 } :
                              $data_type;
            }

            if ( $data_type =~ /timestamp/i ) {
                if ( defined $size[0] && $size[0] > 6 ) {
                    $size[0] = 6;
                }
            }

            if ( $data_type eq 'integer' ) {
                if ( defined $size[0] ) {
                    if ( $size[0] > 10 ) {
                        $data_type = 'bigint';
                    }
                    elsif ( $size[0] < 5 ) {
                        $data_type = 'smallint';
                    }
                    else {
                        $data_type = 'integer';
                    }
                }
                else {
                    $data_type = 'integer';
                }
            }

            #
            # PG doesn't need a size for integers or text
            #
            undef @size if $data_type =~ m/(integer|smallint|bigint|text)/;
            
            $field_def .= " $data_type";

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

            #
            # Default value -- disallow for timestamps
            #
            my $default = $data_type =~ /(timestamp|date)/i
                ? undef : $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 || '';
            if ( $name ) {
                $name = next_unused_name($name, \%used_index_names);
                $used_index_names{$name} = $name;
            }

            my $type = $index->type || NORMAL;
            my @fields     = 
                map { $_ =~ s/\(.+\)//; $_ }
                map { unreserve( $_, $table_name ) }
                $index->fields;
            next unless @fields;

            my $def_start = qq[Constraint "$name" ];
            if ( $type eq PRIMARY_KEY ) {
                push @constraint_defs, "${def_start}PRIMARY KEY ".
                    '("' . join( '", "', @fields ) . '")';
            }
            elsif ( $type eq UNIQUE ) {
                push @constraint_defs, "${def_start}UNIQUE " .
                    '("' . join( '", "', @fields ) . '")';
            }
            elsif ( $type eq NORMAL ) {
                push @index_defs, 
                    'CREATE INDEX "' . $name . "\" on $table_name_ur (".
                        join( ', ', map { qq["$_"] } @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 || '';
            if ( $name ) {
                $name = next_unused_name($name, \%used_index_names);
                $used_index_names{$name} = $name;
            }

            my @fields     = 
                map { $_ =~ s/\(.+\)//; $_ }
                map { unreserve( $_, $table_name ) }
                $c->fields;

            my @rfields     = 
                map { $_ =~ s/\(.+\)//; $_ }
                map { unreserve( $_, $table_name ) }
                $c->reference_fields;

            next if !@fields && $c->type ne CHECK_C;

            my $def_start = $name ? qq[Constraint "$name" ] : '';
            if ( $c->type eq PRIMARY_KEY ) {
                push @constraint_defs, "${def_start}PRIMARY KEY ".
                    '("' . join( '", "', @fields ) . '")';
            }
            elsif ( $c->type eq UNIQUE ) {
                $name = next_unused_name($name, \%used_index_names);
                $used_index_names{$name} = $name;
                push @constraint_defs, "${def_start}UNIQUE " .
                    '("' . join( '", "', @fields ) . '")';
            }
            elsif ( $c->type eq CHECK_C ) {
                my $expression = $c->expression;
                push @constraint_defs, "${def_start}CHECK ($expression)";
            }
            elsif ( $c->type eq FOREIGN_KEY ) {
#                my $def = join(' ', 
#                    map { $_ || () } 'FOREIGN KEY', $c->name 
#                );
#
                my $def .= 'FOREIGN KEY ("' . 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;
}

# -------------------------------------------------------------------
sub next_unused_name {
    my $name       = shift || '';
    my $used_names = shift || '';

    my %used_names = %$used_names;

    if ( !defined($used_names{$name}) ) {
        $used_names{$name} = $name;
        return $name;
    }
    
    my $i = 2;
    while ( defined($used_names{$name . $i}) ) {
        ++$i;
    }
    $name .= $i;
    $used_names{$name} = $name;
    return $name;
}

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	# -------------------------------------------------------------------
c8c17a58	4	# $Id: PostgreSQL.pm,v 1.17 2003-09-26 22:35:23 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 ];
c8c17a58	33	$VERSION = sprintf "%d.%02d", q$Revision: 1.17 $ =~ /(\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',
4328d7bd	45	double => 'numeric',
	46	decimal => 'numeric',
	47	float => 'numeric',
d529894e	48	int => 'integer',
	49	mediumint => 'integer',
	50	smallint => 'smallint',
	51	tinyint => 'smallint',
c8c17a58	52	char => 'character',
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',
c8c17a58	74	char => 'character',
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',
96844cae	87	text => 'text',
4328d7bd	88	real => 'numeric',
96844cae	89	comment => 'text',
	90	bit => 'bit',
	91	tinyint => 'smallint',
4328d7bd	92	float => 'numeric',
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 {
a1d94525	162	my $translator = shift;
	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;
	167	my $schema = $translator->schema;
96844cae	168
da8e499e	169	my $output;
5ee19df8	170	$output .= header_comment unless ($no_comments);
50840472	171	my %used_index_names;
96844cae	172
0c43e0a1	173	for my $table ( $schema->get_tables ) {
0c43e0a1	174	my $table_name = $table->name or next;
da8e499e	175	$table_name = mk_name( $table_name, '', undef, 1 );
	176	my $table_name_ur = unreserve($table_name);
	177
0c43e0a1	178	my ( @comments, @field_defs, @sequence_defs, @constraint_defs );
96844cae	179
da8e499e	180	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
f8f0253c	181
	182	#
	183	# Fields
	184	#
96844cae	185	my %field_name_scope;
0c43e0a1	186	for my $field ( $table->get_fields ) {
96844cae	187	my $field_name = mk_name(
0c43e0a1	188	$field->name, '', \%field_name_scope, 1
96844cae	189	);
96844cae	190	my $field_name_ur = unreserve( $field_name, $table_name );
0c43e0a1	191	my $field_def = qq["$field_name_ur"];
da8e499e	192
	193	#
	194	# Datatype
	195	#
0c43e0a1	196	my @size = $field->size;
	197	my $data_type = lc $field->data_type;
	198	my %extra = $field->extra;
	199	my $list = $extra{'list'} \|\| [];
4524cf01	200	# todo deal with embedded quotes
4524cf01	201	my $commalist = join( ', ', map { qq['$_'] } @$list );
da8e499e	202	my $seq_name;
	203
	204	if ( $data_type eq 'enum' ) {
	205	my $len = 0;
	206	$len = ($len < length($_)) ? length($_) : $len for (@$list);
4524cf01	207	my $chk_name = mk_name( $table_name.'_'.$field_name, 'chk' );
0c43e0a1	208	push @constraint_defs,
4328d7bd	209	qq[Constraint "$chk_name" CHECK ("$field_name" ].
4328d7bd	210	qq[IN ($commalist))];
0c43e0a1	211	$data_type = 'character varying';
da8e499e	212	}
	213	elsif ( $data_type eq 'set' ) {
	214	# XXX add a CHECK constraint maybe
	215	# (trickier and slower, than enum :)
0c43e0a1	216	# my $len = length $commalist;
	217	# $field_def .= " character varying($len) /* set $commalist */";
	218	$data_type = 'character varying';
da8e499e	219	}
0c43e0a1	220	elsif ( $field->is_auto_increment ) {
50840472	221	if ( defined $size[0] && $size[0] > 11 ) {
4328d7bd	222	$data_type = 'bigserial';
50840472	223	}
50840472	224	else {
4328d7bd	225	$data_type = 'serial';
50840472	226	}
	227	undef @size;
	228
0c43e0a1	229	# $seq_name = mk_name( $table_name.'_'.$field_name, 'sq' );
	230	# push @sequence_defs, qq[DROP SEQUENCE "$seq_name";];
	231	# push @sequence_defs, qq[CREATE SEQUENCE "$seq_name";];
da8e499e	232	}
	233	else {
	234	$data_type = defined $translate{ $data_type } ?
	235	$translate{ $data_type } :
61aa0c9d	236	$data_type;
0c43e0a1	237	}
0c43e0a1	238
50840472	239	if ( $data_type =~ /timestamp/i ) {
c8c17a58	240	if ( defined $size[0] && $size[0] > 6 ) {
c8c17a58	241	$size[0] = 6;
50840472	242	}
	243	}
	244
	245	if ( $data_type eq 'integer' ) {
	246	if ( defined $size[0] ) {
4328d7bd	247	if ( $size[0] > 10 ) {
4328d7bd	248	$data_type = 'bigint';
50840472	249	}
50840472	250	elsif ( $size[0] < 5 ) {
4328d7bd	251	$data_type = 'smallint';
50840472	252	}
50840472	253	else {
4328d7bd	254	$data_type = 'integer';
50840472	255	}
	256	}
	257	else {
4328d7bd	258	$data_type = 'integer';
50840472	259	}
50840472	260	}
4328d7bd	261
	262	#
	263	# PG doesn't need a size for integers or text
	264	#
	265	undef @size if $data_type =~ m/(integer\|smallint\|bigint\|text)/;
50840472	266
0c43e0a1	267	$field_def .= " $data_type";
	268
	269	if ( defined $size[0] && $size[0] > 0 ) {
4328d7bd	270	$field_def .= '(' . join( ',', @size ) . ')';
f8f0253c	271	}
f8f0253c	272
da8e499e	273	#
c8c17a58	274	# Default value -- disallow for timestamps
da8e499e	275	#
c8c17a58	276	my $default = $data_type =~ /(timestamp\|date)/i
c8c17a58	277	? undef : $field->default_value;
0c43e0a1	278	if ( defined $default ) {
	279	$field_def .= sprintf( ' DEFAULT %s',
	280	( $field->is_auto_increment && $seq_name )
da8e499e	281	? qq[nextval('"$seq_name"'::text)] :
0c43e0a1	282	( $default =~ m/null/i ) ? 'NULL' : "'$default'"
da8e499e	283	);
da8e499e	284	}
f8f0253c	285
da8e499e	286	#
	287	# Not null constraint
	288	#
0c43e0a1	289	$field_def .= ' NOT NULL' unless $field->is_nullable;
f8f0253c	290
0c43e0a1	291	push @field_defs, $field_def;
f8f0253c	292	}
f8f0253c	293
f8f0253c	294	#
da8e499e	295	# Index Declarations
f8f0253c	296	#
0c43e0a1	297	my @index_defs = ();
da8e499e	298	my $idx_name_default;
0c43e0a1	299	for my $index ( $table->get_indices ) {
0c43e0a1	300	my $name = $index->name \|\| '';
c8c17a58	301	if ( $name ) {
	302	$name = next_unused_name($name, \%used_index_names);
	303	$used_index_names{$name} = $name;
	304	}
	305
0c43e0a1	306	my $type = $index->type \|\| NORMAL;
d8dcdb7a	307	my @fields =
	308	map { $_ =~ s/\(.+\)//; $_ }
	309	map { unreserve( $_, $table_name ) }
0c43e0a1	310	$index->fields;
da8e499e	311	next unless @fields;
da8e499e	312
c8c17a58	313	my $def_start = qq[Constraint "$name" ];
0c43e0a1	314	if ( $type eq PRIMARY_KEY ) {
c8c17a58	315	push @constraint_defs, "${def_start}PRIMARY KEY ".
50840472	316	'("' . join( '", "', @fields ) . '")';
da8e499e	317	}
0c43e0a1	318	elsif ( $type eq UNIQUE ) {
c8c17a58	319	push @constraint_defs, "${def_start}UNIQUE " .
50840472	320	'("' . join( '", "', @fields ) . '")';
da8e499e	321	}
0c43e0a1	322	elsif ( $type eq NORMAL ) {
0c43e0a1	323	push @index_defs,
c8c17a58	324	'CREATE INDEX "' . $name . "\" on $table_name_ur (".
	325	join( ', ', map { qq["$_"] } @fields ).
	326	');'
	327	;
da8e499e	328	}
f8f0253c	329	else {
0c43e0a1	330	warn "Unknown index type ($type) on table $table_name.\n"
da8e499e	331	if $WARN;
f8f0253c	332	}
	333	}
	334
0c43e0a1	335	#
	336	# Table constraints
	337	#
	338	my $c_name_default;
	339	for my $c ( $table->get_constraints ) {
	340	my $name = $c->name \|\| '';
c8c17a58	341	if ( $name ) {
	342	$name = next_unused_name($name, \%used_index_names);
	343	$used_index_names{$name} = $name;
	344	}
	345
0c43e0a1	346	my @fields =
	347	map { $_ =~ s/\(.+\)//; $_ }
	348	map { unreserve( $_, $table_name ) }
	349	$c->fields;
c8c17a58	350
0c43e0a1	351	my @rfields =
	352	map { $_ =~ s/\(.+\)//; $_ }
	353	map { unreserve( $_, $table_name ) }
	354	$c->reference_fields;
c8c17a58	355
8065e024	356	next if !@fields && $c->type ne CHECK_C;
0c43e0a1	357
c8c17a58	358	my $def_start = $name ? qq[Constraint "$name" ] : '';
0c43e0a1	359	if ( $c->type eq PRIMARY_KEY ) {
c8c17a58	360	push @constraint_defs, "${def_start}PRIMARY KEY ".
50840472	361	'("' . join( '", "', @fields ) . '")';
0c43e0a1	362	}
0c43e0a1	363	elsif ( $c->type eq UNIQUE ) {
50840472	364	$name = next_unused_name($name, \%used_index_names);
50840472	365	$used_index_names{$name} = $name;
c8c17a58	366	push @constraint_defs, "${def_start}UNIQUE " .
50840472	367	'("' . join( '", "', @fields ) . '")';
0c43e0a1	368	}
8065e024	369	elsif ( $c->type eq CHECK_C ) {
8065e024	370	my $expression = $c->expression;
c8c17a58	371	push @constraint_defs, "${def_start}CHECK ($expression)";
8065e024	372	}
0c43e0a1	373	elsif ( $c->type eq FOREIGN_KEY ) {
c8c17a58	374	# my $def = join(' ',
	375	# map { $_ \|\| () } 'FOREIGN KEY', $c->name
	376	# );
	377	#
	378	my $def .= 'FOREIGN KEY ("' . join( '", "', @fields ) . '")';
0c43e0a1	379
	380	$def .= ' REFERENCES ' . $c->reference_table;
	381
	382	if ( @rfields ) {
50840472	383	$def .= ' ("' . join( '", "', @rfields ) . '")';
0c43e0a1	384	}
	385
	386	if ( $c->match_type ) {
	387	$def .= ' MATCH ' .
	388	( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
	389	}
	390
	391	if ( $c->on_delete ) {
	392	$def .= ' ON DELETE '.join( ' ', $c->on_delete );
	393	}
	394
	395	if ( $c->on_update ) {
	396	$def .= ' ON UPDATE '.join( ' ', $c->on_update );
	397	}
	398
	399	push @constraint_defs, $def;
	400	}
	401	}
	402
da8e499e	403	my $create_statement;
	404	$create_statement = qq[DROP TABLE "$table_name_ur";\n]
	405	if $add_drop_table;
	406	$create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
0c43e0a1	407	join( ",\n", map { " $_" } @field_defs, @constraint_defs ).
da8e499e	408	"\n);"
	409	;
	410
	411	$output .= join( "\n\n",
	412	@comments,
0c43e0a1	413	@sequence_defs,
da8e499e	414	$create_statement,
0c43e0a1	415	@index_defs,
da8e499e	416	''
	417	);
	418	}
	419
	420	if ( $WARN ) {
	421	if ( %truncated ) {
	422	warn "Truncated " . keys( %truncated ) . " names:\n";
	423	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	424	}
	425
	426	if ( %unreserve ) {
	427	warn "Encounted " . keys( %unreserve ) .
	428	" unsafe names in schema (reserved or invalid):\n";
	429	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	430	}
f8f0253c	431	}
f8f0253c	432
da8e499e	433	return $output;
f8f0253c	434	}
f8f0253c	435
96844cae	436	# -------------------------------------------------------------------
96844cae	437	sub mk_name {
0c43e0a1	438	my $basename = shift \|\| '';
	439	my $type = shift \|\| '';
	440	my $scope = shift \|\| '';
	441	my $critical = shift \|\| '';
96844cae	442	my $basename_orig = $basename;
2ad4c2c8	443	my $max_name = $type
	444	? $max_id_length - (length($type) + 1)
	445	: $max_id_length;
96844cae	446	$basename = substr( $basename, 0, $max_name )
	447	if length( $basename ) > $max_name;
	448	my $name = $type ? "${type}_$basename" : $basename;
	449
	450	if ( $basename ne $basename_orig and $critical ) {
	451	my $show_type = $type ? "+'$type'" : "";
	452	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	453	"character limit to make '$name'\n" if $WARN;
	454	$truncated{ $basename_orig } = $name;
	455	}
	456
	457	$scope \|\|= \%global_names;
	458	if ( my $prev = $scope->{ $name } ) {
	459	my $name_orig = $name;
	460	$name .= sprintf( "%02d", ++$prev );
	461	substr($name, $max_id_length - 3) = "00"
	462	if length( $name ) > $max_id_length;
	463
	464	warn "The name '$name_orig' has been changed to ",
	465	"'$name' to make it unique.\n" if $WARN;
	466
	467	$scope->{ $name_orig }++;
f8f0253c	468	}
96844cae	469
	470	$scope->{ $name }++;
	471	return $name;
	472	}
	473
	474	# -------------------------------------------------------------------
	475	sub unreserve {
0c43e0a1	476	my $name = shift \|\| '';
	477	my $schema_obj_name = shift \|\| '';
	478
96844cae	479	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	480
	481	# also trap fields that don't begin with a letter
0c43e0a1	482	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
96844cae	483
	484	if ( $schema_obj_name ) {
	485	++$unreserve{"$schema_obj_name.$name"};
	486	}
	487	else {
	488	++$unreserve{"$name (table name)"};
	489	}
	490
	491	my $unreserve = sprintf '%s_', $name;
	492	return $unreserve.$suffix;
f8f0253c	493	}
f8f0253c	494
50840472	495	# -------------------------------------------------------------------
	496	sub next_unused_name {
	497	my $name = shift \|\| '';
	498	my $used_names = shift \|\| '';
	499
	500	my %used_names = %$used_names;
	501
	502	if ( !defined($used_names{$name}) ) {
	503	$used_names{$name} = $name;
	504	return $name;
	505	}
	506
	507	my $i = 2;
	508	while ( defined($used_names{$name . $i}) ) {
	509	++$i;
	510	}
	511	$name .= $i;
	512	$used_names{$name} = $name;
	513	return $name;
	514	}
	515
f8f0253c	516	1;
f8f0253c	517
96844cae	518	# -------------------------------------------------------------------
	519	# Life is full of misery, loneliness, and suffering --
	520	# and it's all over much too soon.
	521	# Woody Allen
	522	# -------------------------------------------------------------------
f8f0253c	523
96844cae	524	=pod
f8f0253c	525
	526	=head1 AUTHOR
	527
	528	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	529
	530	=cut