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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.13 2003-08-17 00:46:23 rossta 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.13 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils qw(header_comment);
use Data::Dumper;

my %translate  = (
    #
    # MySQL types
    #
    bigint     => 'bigint',
    double     => 'double precision',
    decimal    => 'decimal',
    float      => 'double precision',
    int        => 'integer',
    mediumint  => 'integer',
    smallint   => 'smallint',
    tinyint    => 'smallint',
    char       => 'char',
    varchar    => 'character varying',
    longtext   => 'text',
    mediumtext => 'text',
    text       => 'text',
    tinytext   => 'text',
    tinyblob   => 'bytea',
    blob       => 'bytea',
    mediumblob => 'bytea',
    longblob   => 'bytea',
    enum       => 'character varying',
    set        => 'character varying',
    date       => 'date',
    datetime   => 'timestamp',
    time       => 'date',
    timestamp  => 'timestamp',
    year       => 'date',

    #
    # Oracle types
    #
    number     => 'integer',
    char       => 'char',
    varchar2   => 'character varying',
    long       => 'text',
    CLOB       => 'bytea',
    date       => 'date',

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

my %reserved = map { $_, 1 } qw[
    ALL ANALYSE ANALYZE AND ANY AS ASC 
    BETWEEN BINARY BOTH
    CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
    CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER 
    DEFAULT DEFERRABLE DESC DISTINCT DO
    ELSE END EXCEPT
    FALSE FOR FOREIGN FREEZE FROM FULL 
    GROUP HAVING 
    ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL 
    JOIN LEADING LEFT LIKE LIMIT 
    NATURAL NEW NOT NOTNULL NULL
    OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
    PRIMARY PUBLIC REFERENCES RIGHT 
    SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE 
    UNION UNIQUE USER USING VERBOSE WHEN WHERE
];

my $max_id_length    = 30;
my %used_identifiers = ();
my %global_names;
my %unreserve;
my %truncated;

=pod

=head1 PostgreSQL Create Table Syntax

  CREATE [ [ LOCAL ] { TEMPORARY | TEMP } ] TABLE table_name (
      { column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
      | table_constraint }  [, ... ]
  )
  [ INHERITS ( parent_table [, ... ] ) ]
  [ WITH OIDS | WITHOUT OIDS ]

where column_constraint is:

  [ CONSTRAINT constraint_name ]
  { NOT NULL | NULL | UNIQUE | PRIMARY KEY |
    CHECK (expression) |
    REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL | MATCH PARTIAL ]
      [ ON DELETE action ] [ ON UPDATE action ] }
  [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]

and table_constraint is:

  [ CONSTRAINT constraint_name ]
  { UNIQUE ( column_name [, ... ] ) |
    PRIMARY KEY ( column_name [, ... ] ) |
    CHECK ( expression ) |
    FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
      [ MATCH FULL | MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
  [ DEFERRABLE | NOT DEFERRABLE ] [ INITIALLY DEFERRED | INITIALLY IMMEDIATE ]

=head1 Create Index Syntax

  CREATE [ UNIQUE ] INDEX index_name ON table
      [ USING acc_method ] ( column [ ops_name ] [, ...] )
      [ WHERE predicate ]
  CREATE [ UNIQUE ] INDEX index_name ON table
      [ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
      [ WHERE predicate ]

=cut

# -------------------------------------------------------------------
sub produce {
    my $translator     = shift;
    $DEBUG             = $translator->debug;
    $WARN              = $translator->show_warnings;
    my $no_comments    = $translator->no_comments;
    my $add_drop_table = $translator->add_drop_table;
    my $schema         = $translator->schema;

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

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

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

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

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

            #
            # Datatype
            #
            my @size      = $field->size;
            my $data_type = lc $field->data_type;
            my %extra     = $field->extra;
            my $list      = $extra{'list'} || [];
            # \todo deal with embedded quotes
            my $commalist = "'" . join("','", @$list) . "'";
            my $seq_name;

            if ( $data_type eq 'enum' ) {
                my $len = 0;
                $len = ($len < length($_)) ? length($_) : $len for (@$list);
                my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
                push @constraint_defs, 
                "CONSTRAINT $check_name CHECK (\"$field_name\" IN ($commalist))";
                $data_type = 'character varying';
            }
            elsif ( $data_type eq 'set' ) {
                # XXX add a CHECK constraint maybe 
                # (trickier and slower, than enum :)
#                my $len     = length $commalist;
#                $field_def .= " character varying($len) /* set $commalist */";
                $data_type = 'character varying';
            }
            elsif ( $field->is_auto_increment ) {
                if ( defined $size[0] && $size[0] > 11 ) {
                    $data_type = ' bigserial';
                }
                else {
                    $data_type = ' serial';
                }
                undef @size;

#                $seq_name   = mk_name( $table_name.'_'.$field_name, 'sq' );
#                push @sequence_defs, qq[DROP SEQUENCE "$seq_name";];
#                push @sequence_defs, qq[CREATE SEQUENCE "$seq_name";];
            }
            else {
                $data_type  = defined $translate{ $data_type } ?
                              $translate{ $data_type } :
                              $data_type;
            }

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

            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';
                }
                undef @size;
            }
            
            $field_def .= " $data_type";

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

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

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

            push @field_defs, $field_def;
        }

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

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

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

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

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

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

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

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

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

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

                push @constraint_defs, $def;
            }
        }

        my $create_statement;
        $create_statement  = qq[DROP TABLE "$table_name_ur";\n] 
            if $add_drop_table;
        $create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
            join( ",\n", map { "  $_" } @field_defs, @constraint_defs ).
            "\n);"
        ;

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

    if ( $WARN ) {
        if ( %truncated ) {
            warn "Truncated " . keys( %truncated ) . " names:\n";
            warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
        }

        if ( %unreserve ) {
            warn "Encounted " . keys( %unreserve ) .
                " unsafe names in schema (reserved or invalid):\n";
            warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
        }
    }

    return $output;
}

# -------------------------------------------------------------------
sub mk_name {
    my $basename      = shift || ''; 
    my $type          = shift || ''; 
    my $scope         = shift || ''; 
    my $critical      = shift || '';
    my $basename_orig = $basename;
    my $max_name      = $type 
                        ? $max_id_length - (length($type) + 1) 
                        : $max_id_length;
    $basename         = substr( $basename, 0, $max_name ) 
                        if length( $basename ) > $max_name;
    my $name          = $type ? "${type}_$basename" : $basename;

    if ( $basename ne $basename_orig and $critical ) {
        my $show_type = $type ? "+'$type'" : "";
        warn "Truncating '$basename_orig'$show_type to $max_id_length ",
            "character limit to make '$name'\n" if $WARN;
        $truncated{ $basename_orig } = $name;
    }

    $scope ||= \%global_names;
    if ( my $prev = $scope->{ $name } ) {
        my $name_orig = $name;
        $name        .= sprintf( "%02d", ++$prev );
        substr($name, $max_id_length - 3) = "00" 
            if length( $name ) > $max_id_length;

        warn "The name '$name_orig' has been changed to ",
             "'$name' to make it unique.\n" if $WARN;

        $scope->{ $name_orig }++;
    }

    $scope->{ $name }++;
    return $name;
}

# -------------------------------------------------------------------
sub unreserve {
    my $name            = shift || '';
    my $schema_obj_name = shift || '';

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

    # also trap fields that don't begin with a letter
    return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i; 

    if ( $schema_obj_name ) {
        ++$unreserve{"$schema_obj_name.$name"};
    }
    else {
        ++$unreserve{"$name (table name)"};
    }

    my $unreserve = sprintf '%s_', $name;
    return $unreserve.$suffix;
}

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