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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.19 2003-09-26 22:54:48 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.19 $ =~ /(\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;

    my @fks;
    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' ) {
                $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;
            }
            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 .= "ALTER TABLE $table_name ADD FOREIGN KEY (" . 
                    join( ', ', map { qq["$_"] } @fields ) . ')' .
                    "\n  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 @fks, "$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 ( @fks ) {
        $output .= "--\n-- Foreign Key Definitions\n--\n\n" unless $no_comments;
        $output .= join( "\n\n", @fks );
    }

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