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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.8 2003-04-25 11:47:25 dlc 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.8 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

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, $data ) = @_;
    $DEBUG                    = $translator->debug;
    $WARN                     = $translator->show_warnings;
    my $no_comments           = $translator->no_comments;
    my $add_drop_table        = $translator->add_drop_table;

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

    for my $table ( 
        map  { $_->[1] }
        sort { $a->[0] <=> $b->[0] }
        map  { [ $_->{'order'}, $_ ] }
        values %$data
   ) {
        my $table_name    = $table->{'table_name'};
        $table_name       = mk_name( $table_name, '', undef, 1 );
        my $table_name_ur = unreserve($table_name);

        my ( @comments, @field_decs, @sequence_decs, @constraints );

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

        #
        # Fields
        #
        my %field_name_scope;
        for my $field ( 
            map  { $_->[1] }
            sort { $a->[0] <=> $b->[0] }
            map  { [ $_->{'order'}, $_ ] }
            values %{ $table->{'fields'} }
        ) {
            my $field_name    = mk_name(
                $field->{'name'}, '', \%field_name_scope, 1 
            );
            my $field_name_ur = unreserve( $field_name, $table_name );
            my $field_str     = qq["$field_name_ur"];

            #
            # Datatype
            #
            my $data_type = lc $field->{'data_type'};
            my $list      = $field->{'list'} || [];
            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 @constraints, 
                "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
                $field_str .= " character varying($len)";
            }
            elsif ( $data_type eq 'set' ) {
                # XXX add a CHECK constraint maybe 
                # (trickier and slower, than enum :)
                my $len     = length $commalist;
                $field_str .= " character varying($len) /* set $commalist */";
            }
            elsif ( $field->{'is_auto_inc'} ) {
                $field_str .= ' serial';
                $seq_name   = mk_name( $table_name.'_'.$field_name, 'sq' );
                push @sequence_decs, qq[DROP SEQUENCE "$seq_name";];
                push @sequence_decs, qq[CREATE SEQUENCE "$seq_name";];
            }
            else {
                $data_type  = defined $translate{ $data_type } ?
                              $translate{ $data_type } :
                              die "Unknown datatype: $data_type\n";
                $field_str .= ' '.$data_type;
                if ( $data_type =~ /(char|varbit|numeric|decimal)/i ) {
                    $field_str .= '('.join(',', @{ $field->{'size'} }).')' 
                        if @{ $field->{'size'} || [] };
                }
            }

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

            #
            # Not null constraint
            #
            unless ( $field->{'null'} ) {
                my $constraint_name = mk_name($field_name_ur, 'nn');
#                $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
                $field_str .= ' NOT NULL';
            }

            #
            # Primary key
            #
#            if ( $field->{'is_primary_key'} ) {
#                my $constraint_name = mk_name($field_name_ur, 'pk');
#                $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
#            }

            push @field_decs, $field_str;
        }

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

            if ( $index_type eq 'primary_key' ) {
                $index_name = mk_name( $table_name, 'pk' );
                push @constraints, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $index_type eq 'unique' ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $index_type eq 'normal' ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @index_decs, 
                    qq[CREATE INDEX "$index_name" on $table_name_ur (].
                        join( ', ', @fields ).  
                    ');'; 
            }
            else {
                warn "Unknown index type ($index_type) on table $table_name.\n"
                    if $WARN;
            }
        }

        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_decs, @constraints ).
            "\n);"
        ;

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

    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, $type, $scope, $critical) = @_;
    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, $schema_obj_name ) = @_;
    my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';

    # also trap fields that don't begin with a letter
    return $_[0] 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;
}

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	# -------------------------------------------------------------------
5ee19df8	4	# $Id: PostgreSQL.pm,v 1.8 2003-04-25 11:47:25 dlc 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 ];
5ee19df8	33	$VERSION = sprintf "%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/;
f8f0253c	34	$DEBUG = 1 unless defined $DEBUG;
f8f0253c	35
5ee19df8	36	use SQL::Translator::Utils qw(header_comment);
f8f0253c	37	use Data::Dumper;
f8f0253c	38
d529894e	39	my %translate = (
	40	#
	41	# MySQL types
	42	#
	43	bigint => 'bigint',
	44	double => 'double precision',
	45	decimal => 'decimal',
	46	float => 'double precision',
	47	int => 'integer',
	48	mediumint => 'integer',
	49	smallint => 'smallint',
	50	tinyint => 'smallint',
	51	char => 'char',
da8e499e	52	varchar => 'character varying',
d529894e	53	longtext => 'text',
	54	mediumtext => 'text',
	55	text => 'text',
	56	tinytext => 'text',
	57	tinyblob => 'bytea',
	58	blob => 'bytea',
	59	mediumblob => 'bytea',
	60	longblob => 'bytea',
da8e499e	61	enum => 'character varying',
da8e499e	62	set => 'character varying',
d529894e	63	date => 'date',
	64	datetime => 'timestamp',
	65	time => 'date',
	66	timestamp => 'timestamp',
	67	year => 'date',
	68
	69	#
	70	# Oracle types
	71	#
96844cae	72	number => 'integer',
96844cae	73	char => 'char',
da8e499e	74	varchar2 => 'character varying',
96844cae	75	long => 'text',
	76	CLOB => 'bytea',
	77	date => 'date',
	78
	79	#
	80	# Sybase types
	81	#
	82	int => 'integer',
	83	money => 'money',
da8e499e	84	varchar => 'character varying',
96844cae	85	datetime => 'timestamp',
	86	text => 'text',
	87	real => 'double precision',
	88	comment => 'text',
	89	bit => 'bit',
	90	tinyint => 'smallint',
	91	float => 'double precision',
d529894e	92	);
d529894e	93
96844cae	94	my %reserved = map { $_, 1 } qw[
	95	ALL ANALYSE ANALYZE AND ANY AS ASC
	96	BETWEEN BINARY BOTH
	97	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	98	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	99	DEFAULT DEFERRABLE DESC DISTINCT DO
	100	ELSE END EXCEPT
	101	FALSE FOR FOREIGN FREEZE FROM FULL
	102	GROUP HAVING
	103	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	104	JOIN LEADING LEFT LIKE LIMIT
	105	NATURAL NEW NOT NOTNULL NULL
	106	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	107	PRIMARY PUBLIC REFERENCES RIGHT
	108	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	109	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	110	];
d529894e	111
96844cae	112	my $max_id_length = 30;
	113	my %used_identifiers = ();
	114	my %global_names;
	115	my %unreserve;
	116	my %truncated;
	117
	118	=pod
	119
	120	=head1 PostgreSQL Create Table Syntax
	121
	122	CREATE [ [ LOCAL ] { TEMPORARY \| TEMP } ] TABLE table_name (
	123	{ column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
	124	\| table_constraint } [, ... ]
	125	)
	126	[ INHERITS ( parent_table [, ... ] ) ]
	127	[ WITH OIDS \| WITHOUT OIDS ]
	128
	129	where column_constraint is:
	130
	131	[ CONSTRAINT constraint_name ]
	132	{ NOT NULL \| NULL \| UNIQUE \| PRIMARY KEY \|
	133	CHECK (expression) \|
	134	REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL \| MATCH PARTIAL ]
	135	[ ON DELETE action ] [ ON UPDATE action ] }
	136	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	137
	138	and table_constraint is:
	139
	140	[ CONSTRAINT constraint_name ]
	141	{ UNIQUE ( column_name [, ... ] ) \|
	142	PRIMARY KEY ( column_name [, ... ] ) \|
	143	CHECK ( expression ) \|
	144	FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
	145	[ MATCH FULL \| MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
	146	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	147
da8e499e	148	=head1 Create Index Syntax
	149
	150	CREATE [ UNIQUE ] INDEX index_name ON table
	151	[ USING acc_method ] ( column [ ops_name ] [, ...] )
	152	[ WHERE predicate ]
	153	CREATE [ UNIQUE ] INDEX index_name ON table
	154	[ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
	155	[ WHERE predicate ]
	156
96844cae	157	=cut
f8f0253c	158
96844cae	159	# -------------------------------------------------------------------
f8f0253c	160	sub produce {
f8f0253c	161	my ( $translator, $data ) = @_;
96844cae	162	$DEBUG = $translator->debug;
	163	$WARN = $translator->show_warnings;
	164	my $no_comments = $translator->no_comments;
	165	my $add_drop_table = $translator->add_drop_table;
	166
da8e499e	167	my $output;
5ee19df8	168	$output .= header_comment unless ($no_comments);
96844cae	169
	170	for my $table (
	171	map { $_->[1] }
	172	sort { $a->[0] <=> $b->[0] }
	173	map { [ $_->{'order'}, $_ ] }
	174	values %$data
	175	) {
da8e499e	176	my $table_name = $table->{'table_name'};
	177	$table_name = mk_name( $table_name, '', undef, 1 );
	178	my $table_name_ur = unreserve($table_name);
	179
	180	my ( @comments, @field_decs, @sequence_decs, @constraints );
96844cae	181
da8e499e	182	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
f8f0253c	183
	184	#
	185	# Fields
	186	#
96844cae	187	my %field_name_scope;
da8e499e	188	for my $field (
	189	map { $_->[1] }
	190	sort { $a->[0] <=> $b->[0] }
	191	map { [ $_->{'order'}, $_ ] }
	192	values %{ $table->{'fields'} }
	193	) {
96844cae	194	my $field_name = mk_name(
	195	$field->{'name'}, '', \%field_name_scope, 1
	196	);
	197	my $field_name_ur = unreserve( $field_name, $table_name );
da8e499e	198	my $field_str = qq["$field_name_ur"];
	199
	200	#
	201	# Datatype
	202	#
	203	my $data_type = lc $field->{'data_type'};
	204	my $list = $field->{'list'} \|\| [];
	205	my $commalist = join ",", @$list;
	206	my $seq_name;
	207
	208	if ( $data_type eq 'enum' ) {
	209	my $len = 0;
	210	$len = ($len < length($_)) ? length($_) : $len for (@$list);
	211	my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
	212	push @constraints,
	213	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
	214	$field_str .= " character varying($len)";
	215	}
	216	elsif ( $data_type eq 'set' ) {
	217	# XXX add a CHECK constraint maybe
	218	# (trickier and slower, than enum :)
	219	my $len = length $commalist;
	220	$field_str .= " character varying($len) /* set $commalist */";
	221	}
	222	elsif ( $field->{'is_auto_inc'} ) {
	223	$field_str .= ' serial';
	224	$seq_name = mk_name( $table_name.'_'.$field_name, 'sq' );
	225	push @sequence_decs, qq[DROP SEQUENCE "$seq_name";];
	226	push @sequence_decs, qq[CREATE SEQUENCE "$seq_name";];
	227	}
	228	else {
	229	$data_type = defined $translate{ $data_type } ?
	230	$translate{ $data_type } :
	231	die "Unknown datatype: $data_type\n";
	232	$field_str .= ' '.$data_type;
	233	if ( $data_type =~ /(char\|varbit\|numeric\|decimal)/i ) {
	234	$field_str .= '('.join(',', @{ $field->{'size'} }).')'
	235	if @{ $field->{'size'} \|\| [] };
	236	}
f8f0253c	237	}
f8f0253c	238
da8e499e	239	#
	240	# Default value
	241	#
	242	if ( defined $field->{'default'} ) {
	243	$field_str .= sprintf( ' DEFAULT %s',
	244	( $field->{'is_auto_inc'} && $seq_name )
	245	? qq[nextval('"$seq_name"'::text)] :
	246	( $field->{'default'} =~ m/null/i )
	247	? 'NULL' :
	248	"'".$field->{'default'}."'"
	249	);
	250	}
f8f0253c	251
da8e499e	252	#
	253	# Not null constraint
	254	#
	255	unless ( $field->{'null'} ) {
	256	my $constraint_name = mk_name($field_name_ur, 'nn');
	257	# $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
	258	$field_str .= ' NOT NULL';
	259	}
f8f0253c	260
da8e499e	261	#
	262	# Primary key
	263	#
	264	# if ( $field->{'is_primary_key'} ) {
	265	# my $constraint_name = mk_name($field_name_ur, 'pk');
	266	# $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
	267	# }
f8f0253c	268
da8e499e	269	push @field_decs, $field_str;
f8f0253c	270	}
f8f0253c	271
f8f0253c	272	#
da8e499e	273	# Index Declarations
f8f0253c	274	#
da8e499e	275	my @index_decs = ();
	276	my $idx_name_default;
	277	for my $index ( @{ $table->{'indices'} } ) {
	278	my $index_name = $index->{'name'} \|\| '';
	279	my $index_type = $index->{'type'} \|\| 'normal';
d8dcdb7a	280	my @fields =
	281	map { $_ =~ s/\(.+\)//; $_ }
	282	map { unreserve( $_, $table_name ) }
	283	@{ $index->{'fields'} };
da8e499e	284	next unless @fields;
	285
	286	if ( $index_type eq 'primary_key' ) {
	287	$index_name = mk_name( $table_name, 'pk' );
	288	push @constraints, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
	289	'(' . join( ', ', @fields ) . ')';
	290	}
	291	elsif ( $index_type eq 'unique' ) {
	292	$index_name = mk_name(
	293	$table_name, $index_name \|\| ++$idx_name_default
	294	);
	295	push @constraints, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
	296	'(' . join( ', ', @fields ) . ')';
	297	}
	298	elsif ( $index_type eq 'normal' ) {
	299	$index_name = mk_name(
	300	$table_name, $index_name \|\| ++$idx_name_default
	301	);
	302	push @index_decs,
	303	qq[CREATE INDEX "$index_name" on $table_name_ur (].
	304	join( ', ', @fields ).
	305	');';
	306	}
f8f0253c	307	else {
da8e499e	308	warn "Unknown index type ($index_type) on table $table_name.\n"
da8e499e	309	if $WARN;
f8f0253c	310	}
	311	}
	312
da8e499e	313	my $create_statement;
	314	$create_statement = qq[DROP TABLE "$table_name_ur";\n]
	315	if $add_drop_table;
	316	$create_statement .= qq[CREATE TABLE "$table_name_ur" (\n].
	317	join( ",\n", map { " $_" } @field_decs, @constraints ).
	318	"\n);"
	319	;
	320
	321	$output .= join( "\n\n",
	322	@comments,
	323	@sequence_decs,
	324	$create_statement,
	325	@index_decs,
	326	''
	327	);
	328	}
	329
	330	if ( $WARN ) {
	331	if ( %truncated ) {
	332	warn "Truncated " . keys( %truncated ) . " names:\n";
	333	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	334	}
	335
	336	if ( %unreserve ) {
	337	warn "Encounted " . keys( %unreserve ) .
	338	" unsafe names in schema (reserved or invalid):\n";
	339	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	340	}
f8f0253c	341	}
f8f0253c	342
da8e499e	343	return $output;
f8f0253c	344	}
f8f0253c	345
96844cae	346	# -------------------------------------------------------------------
	347	sub mk_name {
	348	my ($basename, $type, $scope, $critical) = @_;
	349	my $basename_orig = $basename;
2ad4c2c8	350	my $max_name = $type
	351	? $max_id_length - (length($type) + 1)
	352	: $max_id_length;
96844cae	353	$basename = substr( $basename, 0, $max_name )
	354	if length( $basename ) > $max_name;
	355	my $name = $type ? "${type}_$basename" : $basename;
	356
	357	if ( $basename ne $basename_orig and $critical ) {
	358	my $show_type = $type ? "+'$type'" : "";
	359	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	360	"character limit to make '$name'\n" if $WARN;
	361	$truncated{ $basename_orig } = $name;
	362	}
	363
	364	$scope \|\|= \%global_names;
	365	if ( my $prev = $scope->{ $name } ) {
	366	my $name_orig = $name;
	367	$name .= sprintf( "%02d", ++$prev );
	368	substr($name, $max_id_length - 3) = "00"
	369	if length( $name ) > $max_id_length;
	370
	371	warn "The name '$name_orig' has been changed to ",
	372	"'$name' to make it unique.\n" if $WARN;
	373
	374	$scope->{ $name_orig }++;
f8f0253c	375	}
96844cae	376
	377	$scope->{ $name }++;
	378	return $name;
	379	}
	380
	381	# -------------------------------------------------------------------
	382	sub unreserve {
	383	my ( $name, $schema_obj_name ) = @_;
	384	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	385
	386	# also trap fields that don't begin with a letter
	387	return $_[0] if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
	388
	389	if ( $schema_obj_name ) {
	390	++$unreserve{"$schema_obj_name.$name"};
	391	}
	392	else {
	393	++$unreserve{"$name (table name)"};
	394	}
	395
	396	my $unreserve = sprintf '%s_', $name;
	397	return $unreserve.$suffix;
f8f0253c	398	}
	399
	400	1;
f8f0253c	401
96844cae	402	# -------------------------------------------------------------------
	403	# Life is full of misery, loneliness, and suffering --
	404	# and it's all over much too soon.
	405	# Woody Allen
	406	# -------------------------------------------------------------------
f8f0253c	407
96844cae	408	=pod
f8f0253c	409
	410	=head1 AUTHOR
	411
	412	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	413
	414	=cut