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

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

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