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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.20 2003-10-15 19:07:13 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

=head1 SYNOPSIS

  my $t = SQL::Translator->new( parser => '...', producer => 'PostgreSQL' );
  $t->translate;

=head1 DESCRIPTION

Creates a DDL suitable for PostgreSQL.  Very heavily based on the Oracle
producer.

=cut

use strict;
use vars qw[ $DEBUG $WARN $VERSION ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.20 $ =~ /(\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 SEE ALSO

SQL::Translator, SQL::Translator::Producer::Oracle.

=head1 AUTHOR

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

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