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

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

# -------------------------------------------------------------------
# $Id: PostgreSQL.pm,v 1.5 2003-01-02 17:47:59 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.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.5 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

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;
    unless ( $no_comments ) {
        $output .=  sprintf 
            "--\n-- Created by %s\n-- Created on %s\n--\n\n",
            __PACKAGE__, scalar localtime;
    }

    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 { 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	# -------------------------------------------------------------------
2ad4c2c8	4	# $Id: PostgreSQL.pm,v 1.5 2003-01-02 17:47:59 kycl4rk Exp $
f8f0253c	5	# -------------------------------------------------------------------
d529894e	6	# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
f8f0253c	7	# darren chamberlain <darren@cpan.org>
	8	#
	9	# This program is free software; you can redistribute it and/or
	10	# modify it under the terms of the GNU General Public License as
	11	# published by the Free Software Foundation; version 2.
	12	#
	13	# This program is distributed in the hope that it will be useful, but
	14	# WITHOUT ANY WARRANTY; without even the implied warranty of
	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	16	# General Public License for more details.
	17	#
	18	# You should have received a copy of the GNU General Public License
	19	# along with this program; if not, write to the Free Software
	20	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	21	# 02111-1307 USA
	22	# -------------------------------------------------------------------
	23
96844cae	24	=head1 NAME
	25
	26	SQL::Translator::Producer::PostgreSQL - PostgreSQL producer for SQL::Translator
	27
	28	=cut
	29
f8f0253c	30	use strict;
96844cae	31	use vars qw[ $DEBUG $WARN $VERSION ];
2ad4c2c8	32	$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
f8f0253c	33	$DEBUG = 1 unless defined $DEBUG;
	34
	35	use Data::Dumper;
	36
d529894e	37	my %translate = (
	38	#
	39	# MySQL types
	40	#
	41	bigint => 'bigint',
	42	double => 'double precision',
	43	decimal => 'decimal',
	44	float => 'double precision',
	45	int => 'integer',
	46	mediumint => 'integer',
	47	smallint => 'smallint',
	48	tinyint => 'smallint',
	49	char => 'char',
da8e499e	50	varchar => 'character varying',
d529894e	51	longtext => 'text',
	52	mediumtext => 'text',
	53	text => 'text',
	54	tinytext => 'text',
	55	tinyblob => 'bytea',
	56	blob => 'bytea',
	57	mediumblob => 'bytea',
	58	longblob => 'bytea',
da8e499e	59	enum => 'character varying',
da8e499e	60	set => 'character varying',
d529894e	61	date => 'date',
	62	datetime => 'timestamp',
	63	time => 'date',
	64	timestamp => 'timestamp',
	65	year => 'date',
	66
	67	#
	68	# Oracle types
	69	#
96844cae	70	number => 'integer',
96844cae	71	char => 'char',
da8e499e	72	varchar2 => 'character varying',
96844cae	73	long => 'text',
	74	CLOB => 'bytea',
	75	date => 'date',
	76
	77	#
	78	# Sybase types
	79	#
	80	int => 'integer',
	81	money => 'money',
da8e499e	82	varchar => 'character varying',
96844cae	83	datetime => 'timestamp',
	84	text => 'text',
	85	real => 'double precision',
	86	comment => 'text',
	87	bit => 'bit',
	88	tinyint => 'smallint',
	89	float => 'double precision',
d529894e	90	);
d529894e	91
96844cae	92	my %reserved = map { $_, 1 } qw[
	93	ALL ANALYSE ANALYZE AND ANY AS ASC
	94	BETWEEN BINARY BOTH
	95	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	96	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	97	DEFAULT DEFERRABLE DESC DISTINCT DO
	98	ELSE END EXCEPT
	99	FALSE FOR FOREIGN FREEZE FROM FULL
	100	GROUP HAVING
	101	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	102	JOIN LEADING LEFT LIKE LIMIT
	103	NATURAL NEW NOT NOTNULL NULL
	104	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	105	PRIMARY PUBLIC REFERENCES RIGHT
	106	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	107	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	108	];
d529894e	109
96844cae	110	my $max_id_length = 30;
	111	my %used_identifiers = ();
	112	my %global_names;
	113	my %unreserve;
	114	my %truncated;
	115
	116	=pod
	117
	118	=head1 PostgreSQL Create Table Syntax
	119
	120	CREATE [ [ LOCAL ] { TEMPORARY \| TEMP } ] TABLE table_name (
	121	{ column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
	122	\| table_constraint } [, ... ]
	123	)
	124	[ INHERITS ( parent_table [, ... ] ) ]
	125	[ WITH OIDS \| WITHOUT OIDS ]
	126
	127	where column_constraint is:
	128
	129	[ CONSTRAINT constraint_name ]
	130	{ NOT NULL \| NULL \| UNIQUE \| PRIMARY KEY \|
	131	CHECK (expression) \|
	132	REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL \| MATCH PARTIAL ]
	133	[ ON DELETE action ] [ ON UPDATE action ] }
	134	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	135
	136	and table_constraint is:
	137
	138	[ CONSTRAINT constraint_name ]
	139	{ UNIQUE ( column_name [, ... ] ) \|
	140	PRIMARY KEY ( column_name [, ... ] ) \|
	141	CHECK ( expression ) \|
	142	FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
	143	[ MATCH FULL \| MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
	144	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	145
da8e499e	146	=head1 Create Index Syntax
	147
	148	CREATE [ UNIQUE ] INDEX index_name ON table
	149	[ USING acc_method ] ( column [ ops_name ] [, ...] )
	150	[ WHERE predicate ]
	151	CREATE [ UNIQUE ] INDEX index_name ON table
	152	[ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
	153	[ WHERE predicate ]
	154
96844cae	155	=cut
f8f0253c	156
96844cae	157	# -------------------------------------------------------------------
f8f0253c	158	sub produce {
f8f0253c	159	my ( $translator, $data ) = @_;
96844cae	160	$DEBUG = $translator->debug;
	161	$WARN = $translator->show_warnings;
	162	my $no_comments = $translator->no_comments;
	163	my $add_drop_table = $translator->add_drop_table;
	164
da8e499e	165	my $output;
96844cae	166	unless ( $no_comments ) {
da8e499e	167	$output .= sprintf
96844cae	168	"--\n-- Created by %s\n-- Created on %s\n--\n\n",
	169	__PACKAGE__, scalar localtime;
	170	}
	171
	172	for my $table (
	173	map { $_->[1] }
	174	sort { $a->[0] <=> $b->[0] }
	175	map { [ $_->{'order'}, $_ ] }
	176	values %$data
	177	) {
da8e499e	178	my $table_name = $table->{'table_name'};
	179	$table_name = mk_name( $table_name, '', undef, 1 );
	180	my $table_name_ur = unreserve($table_name);
	181
	182	my ( @comments, @field_decs, @sequence_decs, @constraints );
96844cae	183
da8e499e	184	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
f8f0253c	185
	186	#
	187	# Fields
	188	#
96844cae	189	my %field_name_scope;
da8e499e	190	for my $field (
	191	map { $_->[1] }
	192	sort { $a->[0] <=> $b->[0] }
	193	map { [ $_->{'order'}, $_ ] }
	194	values %{ $table->{'fields'} }
	195	) {
96844cae	196	my $field_name = mk_name(
	197	$field->{'name'}, '', \%field_name_scope, 1
	198	);
	199	my $field_name_ur = unreserve( $field_name, $table_name );
da8e499e	200	my $field_str = qq["$field_name_ur"];
	201
	202	#
	203	# Datatype
	204	#
	205	my $data_type = lc $field->{'data_type'};
	206	my $list = $field->{'list'} \|\| [];
	207	my $commalist = join ",", @$list;
	208	my $seq_name;
	209
	210	if ( $data_type eq 'enum' ) {
	211	my $len = 0;
	212	$len = ($len < length($_)) ? length($_) : $len for (@$list);
	213	my $check_name = mk_name( $table_name.'_'.$field_name, 'chk' );
	214	push @constraints,
	215	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
	216	$field_str .= " character varying($len)";
	217	}
	218	elsif ( $data_type eq 'set' ) {
	219	# XXX add a CHECK constraint maybe
	220	# (trickier and slower, than enum :)
	221	my $len = length $commalist;
	222	$field_str .= " character varying($len) /* set $commalist */";
	223	}
	224	elsif ( $field->{'is_auto_inc'} ) {
	225	$field_str .= ' serial';
	226	$seq_name = mk_name( $table_name.'_'.$field_name, 'sq' );
	227	push @sequence_decs, qq[DROP SEQUENCE "$seq_name";];
	228	push @sequence_decs, qq[CREATE SEQUENCE "$seq_name";];
	229	}
	230	else {
	231	$data_type = defined $translate{ $data_type } ?
	232	$translate{ $data_type } :
	233	die "Unknown datatype: $data_type\n";
	234	$field_str .= ' '.$data_type;
	235	if ( $data_type =~ /(char\|varbit\|numeric\|decimal)/i ) {
	236	$field_str .= '('.join(',', @{ $field->{'size'} }).')'
	237	if @{ $field->{'size'} \|\| [] };
	238	}
f8f0253c	239	}
f8f0253c	240
da8e499e	241	#
	242	# Default value
	243	#
	244	if ( defined $field->{'default'} ) {
	245	$field_str .= sprintf( ' DEFAULT %s',
	246	( $field->{'is_auto_inc'} && $seq_name )
	247	? qq[nextval('"$seq_name"'::text)] :
	248	( $field->{'default'} =~ m/null/i )
	249	? 'NULL' :
	250	"'".$field->{'default'}."'"
	251	);
	252	}
f8f0253c	253
da8e499e	254	#
	255	# Not null constraint
	256	#
	257	unless ( $field->{'null'} ) {
	258	my $constraint_name = mk_name($field_name_ur, 'nn');
	259	# $field_str .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
	260	$field_str .= ' NOT NULL';
	261	}
f8f0253c	262
da8e499e	263	#
	264	# Primary key
	265	#
	266	# if ( $field->{'is_primary_key'} ) {
	267	# my $constraint_name = mk_name($field_name_ur, 'pk');
	268	# $field_str .= ' CONSTRAINT '.$constraint_name.' PRIMARY KEY';
	269	# }
f8f0253c	270
da8e499e	271	push @field_decs, $field_str;
f8f0253c	272	}
f8f0253c	273
f8f0253c	274	#
da8e499e	275	# Index Declarations
f8f0253c	276	#
da8e499e	277	my @index_decs = ();
	278	my $idx_name_default;
	279	for my $index ( @{ $table->{'indices'} } ) {
	280	my $index_name = $index->{'name'} \|\| '';
	281	my $index_type = $index->{'type'} \|\| 'normal';
	282	my @fields = map { unreserve( $_, $table_name ) }
	283	@{ $index->{'fields'} };
	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