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

package SQL::Translator::Producer::Sybase;

# -------------------------------------------------------------------
# $Id: Sybase.pm,v 1.6 2003-08-18 15:43:15 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>,
#                    Chris Mungall <cjm@fruitfly.org>,
#                    Sam Angiuoli <angiuoli@users.sourceforge.net>
#
# 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::Sybase - Sybase producer for SQL::Translator

=cut

use strict;
use vars qw[ $DEBUG $WARN $VERSION ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

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

my %translate  = (
    #
    # Sybase types
    #
    integer   => 'numeric',
    int       => 'numeric',
    number    => 'numeric',
    money     => 'money',
    varchar   => 'varchar',
    varchar2  => 'varchar',
    timestamp => 'datetime',
    text      => 'varchar',
    real      => 'double precision',
    comment   => 'text',
    bit       => 'bit',
    tinyint   => 'smallint',
    float     => 'double precision',
    serial    => 'numeric', 
    boolean   => 'varchar',
    char      => 'char',
    long      => 'varchar',
);

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 Sybase 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);

    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, @index_defs, @constraint_defs );

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

        push @comments, map { "-- $_" } $table->comments;

        #
        # Fields
        #
        my %field_name_scope;
        for my $field ( $table->get_fields ) {
            my $field_name    = mk_name(
                $field->name, '', \%field_name_scope, undef,1 
            );
            my $field_name_ur = unreserve( $field_name, $table_name );
            my $field_def     = qq["$field_name_ur"];
            $field_def        =~ s/\"//g;
            if ( $field_def =~ /identity/ ){
                $field_def =~ s/identity/pidentity/;
            }

            #
            # Datatype
            #
            my $data_type      = lc $field->data_type;
            my $orig_data_type = $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 $check_name = mk_name( 
                    $table_name.'_'.$field_name, 'chk' ,undef, 1
                );
                push @constraint_defs, 
                "CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
                $data_type .= 'character varying';
            }
            elsif ( $data_type eq 'set' ) {
                $data_type .= 'character varying';
            }
            elsif ( $field->is_auto_increment ) {
                $field_def .= ' IDENTITY';
            }
            else {
                if ( defined $translate{ $data_type } ) {
                    $data_type = $translate{ $data_type };
                }
                else {
                    warn "Unknown datatype: $data_type ",
                        "($table_name.$field_name)\n" if $WARN;
                }
            }

            my $size = $field->size;
            unless ( $size ) {
                if ( $data_type =~ /numeric/ ) {
                    $size = '9,0';
                }
                elsif ( $orig_data_type eq 'text' ) {
                    #interpret text fields as long varchars
                    $size = '255';
                }
                elsif (
                    $data_type eq 'varchar' && 
                    $orig_data_type eq 'boolean'
                ) {
                    $size = '6';
                }
                elsif ( $data_type eq 'varchar' ) {
                    $size = '255';
                }
            }

            $field_def .= " $data_type";
            $field_def .= "($size)" if $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
            #
            unless ( $field->is_nullable ) {
                $field_def .= ' NOT NULL';
            }
            else {
                $field_def .= ' NULL' if $data_type ne 'bit';
            }

            push @field_defs, $field_def;
        }

        #
        # Constraint Declarations
        #
        my @constraint_decs = ();
        my $c_name_default;
        for my $constraint ( $table->get_constraints ) {
            my $name    = $constraint->name || '';
            my $type    = $constraint->type || NORMAL;
            my @fields  = map { unreserve( $_, $table_name ) }
                $constraint->fields;
            my @rfields = map { unreserve( $_, $table_name ) }
                $constraint->reference_fields;
            next unless @fields;

            if ( $type eq PRIMARY_KEY ) {
                $name ||= mk_name( $table_name, 'pk', undef,1 );
                push @constraint_defs, 
                    "CONSTRAINT $name PRIMARY KEY ".
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $type eq FOREIGN_KEY ) {
                $name ||= mk_name( $table_name, 'fk', undef,1 );
                push @constraint_defs, 
                    "CONSTRAINT $name FOREIGN KEY".
                    ' (' . join( ', ', @fields ) . ') REFERENCES '.
                    $constraint->reference_table.
                    ' (' . join( ', ', @rfields ) . ')';
            }
            elsif ( $type eq UNIQUE ) {
                $name ||= mk_name( 
                    $table_name, 
                    $name || ++$c_name_default,undef, 1
                );
                push @constraint_defs, 
                    "CONSTRAINT $name UNIQUE " .
                    '(' . join( ', ', @fields ) . ')';
            }
        }

        #
        # Indices
        #
        for my $index ( $table->get_indices ) {
            push @index_defs, 
                'CREATE INDEX ' . $index->name .
                " ON $table_name (".
                join( ', ', $index->fields ) . ");";
        }

        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,
            $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 }++;
    }
    $name = substr( $name, 0, $max_id_length ) 
                        if ((length( $name ) > $max_id_length) && $critical);
    $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;
}

1;

# -------------------------------------------------------------------

=pod

=head1 AUTHORS

Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
Ken Y. Clark E<lt>kclark@cpan.orgE<gt>

=cut
Commit	Line	Data
d9b22bfe	1	package SQL::Translator::Producer::Sybase;
	2
	3	# -------------------------------------------------------------------
4524cf01	4	# $Id: Sybase.pm,v 1.6 2003-08-18 15:43:15 kycl4rk Exp $
d9b22bfe	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
	7	# darren chamberlain <darren@cpan.org>,
590f4d4a	8	# Chris Mungall <cjm@fruitfly.org>,
590f4d4a	9	# Sam Angiuoli <angiuoli@users.sourceforge.net>
d9b22bfe	10	#
	11	# This program is free software; you can redistribute it and/or
	12	# modify it under the terms of the GNU General Public License as
	13	# published by the Free Software Foundation; version 2.
	14	#
	15	# This program is distributed in the hope that it will be useful, but
	16	# WITHOUT ANY WARRANTY; without even the implied warranty of
	17	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	18	# General Public License for more details.
	19	#
	20	# You should have received a copy of the GNU General Public License
	21	# along with this program; if not, write to the Free Software
	22	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	23	# 02111-1307 USA
	24	# -------------------------------------------------------------------
	25
	26	=head1 NAME
	27
	28	SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator
	29
	30	=cut
	31
	32	use strict;
	33	use vars qw[ $DEBUG $WARN $VERSION ];
4524cf01	34	$VERSION = sprintf "%d.%02d", q$Revision: 1.6 $ =~ /(\d+)\.(\d+)/;
d9b22bfe	35	$DEBUG = 1 unless defined $DEBUG;
	36
	37	use Data::Dumper;
54c9812d	38	use SQL::Translator::Schema::Constants;
590f4d4a	39	use SQL::Translator::Utils qw(debug header_comment);
d9b22bfe	40
	41	my %translate = (
	42	#
	43	# Sybase types
	44	#
54c9812d	45	integer => 'numeric',
	46	int => 'numeric',
	47	number => 'numeric',
	48	money => 'money',
	49	varchar => 'varchar',
	50	varchar2 => 'varchar',
	51	timestamp => 'datetime',
	52	text => 'varchar',
	53	real => 'double precision',
	54	comment => 'text',
	55	bit => 'bit',
	56	tinyint => 'smallint',
	57	float => 'double precision',
	58	serial => 'numeric',
	59	boolean => 'varchar',
	60	char => 'char',
	61	long => 'varchar',
d9b22bfe	62	);
	63
	64	my %reserved = map { $_, 1 } qw[
	65	ALL ANALYSE ANALYZE AND ANY AS ASC
	66	BETWEEN BINARY BOTH
	67	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	68	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	69	DEFAULT DEFERRABLE DESC DISTINCT DO
	70	ELSE END EXCEPT
	71	FALSE FOR FOREIGN FREEZE FROM FULL
	72	GROUP HAVING
	73	ILIKE IN INITIALLY INNER INTERSECT INTO IS ISNULL
	74	JOIN LEADING LEFT LIKE LIMIT
	75	NATURAL NEW NOT NOTNULL NULL
	76	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	77	PRIMARY PUBLIC REFERENCES RIGHT
	78	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	79	UNION UNIQUE USER USING VERBOSE WHEN WHERE
	80	];
	81
	82	my $max_id_length = 30;
	83	my %used_identifiers = ();
	84	my %global_names;
	85	my %unreserve;
	86	my %truncated;
	87
	88	=pod
	89
	90	=head1 Sybase Create Table Syntax
	91
	92	CREATE [ [ LOCAL ] { TEMPORARY \| TEMP } ] TABLE table_name (
	93	{ column_name data_type [ DEFAULT default_expr ] [ column_constraint [, ... ] ]
	94	\| table_constraint } [, ... ]
	95	)
	96	[ INHERITS ( parent_table [, ... ] ) ]
	97	[ WITH OIDS \| WITHOUT OIDS ]
	98
	99	where column_constraint is:
	100
	101	[ CONSTRAINT constraint_name ]
	102	{ NOT NULL \| NULL \| UNIQUE \| PRIMARY KEY \|
	103	CHECK (expression) \|
	104	REFERENCES reftable [ ( refcolumn ) ] [ MATCH FULL \| MATCH PARTIAL ]
	105	[ ON DELETE action ] [ ON UPDATE action ] }
	106	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	107
	108	and table_constraint is:
	109
	110	[ CONSTRAINT constraint_name ]
	111	{ UNIQUE ( column_name [, ... ] ) \|
	112	PRIMARY KEY ( column_name [, ... ] ) \|
	113	CHECK ( expression ) \|
	114	FOREIGN KEY ( column_name [, ... ] ) REFERENCES reftable [ ( refcolumn [, ... ] ) ]
	115	[ MATCH FULL \| MATCH PARTIAL ] [ ON DELETE action ] [ ON UPDATE action ] }
	116	[ DEFERRABLE \| NOT DEFERRABLE ] [ INITIALLY DEFERRED \| INITIALLY IMMEDIATE ]
	117
	118	=head1 Create Index Syntax
	119
	120	CREATE [ UNIQUE ] INDEX index_name ON table
	121	[ USING acc_method ] ( column [ ops_name ] [, ...] )
	122	[ WHERE predicate ]
	123	CREATE [ UNIQUE ] INDEX index_name ON table
	124	[ USING acc_method ] ( func_name( column [, ... ]) [ ops_name ] )
	125	[ WHERE predicate ]
126
127	=cut
128
129	# -------------------------------------------------------------------
130	sub produce {
a1d94525	131	my $translator = shift;
	132	$DEBUG = $translator->debug;
	133	$WARN = $translator->show_warnings;
	134	my $no_comments = $translator->no_comments;
	135	my $add_drop_table = $translator->add_drop_table;
	136	my $schema = $translator->schema;
d9b22bfe	137
d9b22bfe	138	my $output;
590f4d4a	139	$output .= header_comment unless ($no_comments);
d9b22bfe	140
54c9812d	141	for my $table ( $schema->get_tables ) {
54c9812d	142	my $table_name = $table->name or next;
d9b22bfe	143	$table_name = mk_name( $table_name, '', undef, 1 );
54c9812d	144	my $table_name_ur = unreserve($table_name) \|\| '';
d9b22bfe	145
54c9812d	146	my ( @comments, @field_defs, @index_defs, @constraint_defs );
d9b22bfe	147
	148	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
	149
54c9812d	150	push @comments, map { "-- $_" } $table->comments;
54c9812d	151
d9b22bfe	152	#
	153	# Fields
	154	#
	155	my %field_name_scope;
54c9812d	156	for my $field ( $table->get_fields ) {
d9b22bfe	157	my $field_name = mk_name(
54c9812d	158	$field->name, '', \%field_name_scope, undef,1
d9b22bfe	159	);
d9b22bfe	160	my $field_name_ur = unreserve( $field_name, $table_name );
54c9812d	161	my $field_def = qq["$field_name_ur"];
	162	$field_def =~ s/\"//g;
	163	if ( $field_def =~ /identity/ ){
	164	$field_def =~ s/identity/pidentity/;
590f4d4a	165	}
d9b22bfe	166
	167	#
	168	# Datatype
	169	#
54c9812d	170	my $data_type = lc $field->data_type;
590f4d4a	171	my $orig_data_type = $data_type;
54c9812d	172	my %extra = $field->extra;
54c9812d	173	my $list = $extra{'list'} \|\| [];
77d74ea6	174	# \todo deal with embedded quotes
4524cf01	175	my $commalist = join( ', ', map { qq['$_'] } @$list );
d9b22bfe	176	my $seq_name;
	177
	178	if ( $data_type eq 'enum' ) {
590f4d4a	179	my $check_name = mk_name(
	180	$table_name.'_'.$field_name, 'chk' ,undef, 1
	181	);
54c9812d	182	push @constraint_defs,
d9b22bfe	183	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
54c9812d	184	$data_type .= 'character varying';
d9b22bfe	185	}
d9b22bfe	186	elsif ( $data_type eq 'set' ) {
54c9812d	187	$data_type .= 'character varying';
d9b22bfe	188	}
54c9812d	189	elsif ( $field->is_auto_increment ) {
54c9812d	190	$field_def .= ' IDENTITY';
d9b22bfe	191	}
d9b22bfe	192	else {
54c9812d	193	if ( defined $translate{ $data_type } ) {
54c9812d	194	$data_type = $translate{ $data_type };
d9b22bfe	195	}
54c9812d	196	else {
	197	warn "Unknown datatype: $data_type ",
	198	"($table_name.$field_name)\n" if $WARN;
590f4d4a	199	}
54c9812d	200	}
590f4d4a	201
54c9812d	202	my $size = $field->size;
	203	unless ( $size ) {
	204	if ( $data_type =~ /numeric/ ) {
	205	$size = '9,0';
	206	}
	207	elsif ( $orig_data_type eq 'text' ) {
590f4d4a	208	#interpret text fields as long varchars
54c9812d	209	$size = '255';
590f4d4a	210	}
54c9812d	211	elsif (
	212	$data_type eq 'varchar' &&
	213	$orig_data_type eq 'boolean'
	214	) {
	215	$size = '6';
590f4d4a	216	}
54c9812d	217	elsif ( $data_type eq 'varchar' ) {
54c9812d	218	$size = '255';
590f4d4a	219	}
d9b22bfe	220	}
d9b22bfe	221
54c9812d	222	$field_def .= " $data_type";
54c9812d	223	$field_def .= "($size)" if $size;
d9b22bfe	224
	225	#
	226	# Default value
	227	#
54c9812d	228	my $default = $field->default_value;
	229	if ( defined $default ) {
	230	$field_def .= sprintf( ' DEFAULT %s',
	231	( $field->is_auto_increment && $seq_name )
d9b22bfe	232	? qq[nextval('"$seq_name"'::text)] :
54c9812d	233	( $default =~ m/null/i ) ? 'NULL' : "'$default'"
d9b22bfe	234	);
	235	}
	236
	237	#
	238	# Not null constraint
	239	#
54c9812d	240	unless ( $field->is_nullable ) {
54c9812d	241	$field_def .= ' NOT NULL';
d9b22bfe	242	}
590f4d4a	243	else {
54c9812d	244	$field_def .= ' NULL' if $data_type ne 'bit';
590f4d4a	245	}
d9b22bfe	246
54c9812d	247	push @field_defs, $field_def;
d9b22bfe	248	}
	249
	250	#
	251	# Constraint Declarations
	252	#
	253	my @constraint_decs = ();
54c9812d	254	my $c_name_default;
	255	for my $constraint ( $table->get_constraints ) {
	256	my $name = $constraint->name \|\| '';
	257	my $type = $constraint->type \|\| NORMAL;
	258	my @fields = map { unreserve( $_, $table_name ) }
	259	$constraint->fields;
	260	my @rfields = map { unreserve( $_, $table_name ) }
	261	$constraint->reference_fields;
d9b22bfe	262	next unless @fields;
d9b22bfe	263
54c9812d	264	if ( $type eq PRIMARY_KEY ) {
	265	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
	266	push @constraint_defs,
	267	"CONSTRAINT $name PRIMARY KEY ".
d9b22bfe	268	'(' . join( ', ', @fields ) . ')';
d9b22bfe	269	}
54c9812d	270	elsif ( $type eq FOREIGN_KEY ) {
	271	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
	272	push @constraint_defs,
	273	"CONSTRAINT $name FOREIGN KEY".
	274	' (' . join( ', ', @fields ) . ') REFERENCES '.
	275	$constraint->reference_table.
	276	' (' . join( ', ', @rfields ) . ')';
d9b22bfe	277	}
54c9812d	278	elsif ( $type eq UNIQUE ) {
54c9812d	279	$name \|\|= mk_name(
590f4d4a	280	$table_name,
54c9812d	281	$name \|\| ++$c_name_default,undef, 1
d9b22bfe	282	);
54c9812d	283	push @constraint_defs,
54c9812d	284	"CONSTRAINT $name UNIQUE " .
d9b22bfe	285	'(' . join( ', ', @fields ) . ')';
d9b22bfe	286	}
54c9812d	287	}
	288
	289	#
	290	# Indices
	291	#
	292	for my $index ( $table->get_indices ) {
	293	push @index_defs,
	294	'CREATE INDEX ' . $index->name .
	295	" ON $table_name (".
	296	join( ', ', $index->fields ) . ");";
d9b22bfe	297	}
	298
	299	my $create_statement;
	300	$create_statement = qq[DROP TABLE $table_name_ur;\n]
	301	if $add_drop_table;
	302	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
54c9812d	303	join( ",\n",
	304	map { " $_" } @field_defs, @constraint_defs
	305	).
d9b22bfe	306	"\n);"
	307	;
	308
	309	$output .= join( "\n\n",
	310	@comments,
d9b22bfe	311	$create_statement,
54c9812d	312	@index_defs,
54c9812d	313	''
d9b22bfe	314	);
590f4d4a	315	}
590f4d4a	316
d9b22bfe	317	if ( $WARN ) {
	318	if ( %truncated ) {
	319	warn "Truncated " . keys( %truncated ) . " names:\n";
	320	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	321	}
	322
	323	if ( %unreserve ) {
	324	warn "Encounted " . keys( %unreserve ) .
	325	" unsafe names in schema (reserved or invalid):\n";
	326	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	327	}
	328	}
	329
	330	return $output;
	331	}
	332
	333	# -------------------------------------------------------------------
	334	sub mk_name {
54c9812d	335	my $basename = shift \|\| '';
	336	my $type = shift \|\| '';
	337	my $scope = shift \|\| '';
	338	my $critical = shift \|\| '';
d9b22bfe	339	my $basename_orig = $basename;
	340	my $max_name = $type
	341	? $max_id_length - (length($type) + 1)
	342	: $max_id_length;
	343	$basename = substr( $basename, 0, $max_name )
	344	if length( $basename ) > $max_name;
	345	my $name = $type ? "${type}_$basename" : $basename;
54c9812d	346
d9b22bfe	347	if ( $basename ne $basename_orig and $critical ) {
	348	my $show_type = $type ? "+'$type'" : "";
	349	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	350	"character limit to make '$name'\n" if $WARN;
	351	$truncated{ $basename_orig } = $name;
	352	}
	353
	354	$scope \|\|= \%global_names;
	355	if ( my $prev = $scope->{ $name } ) {
	356	my $name_orig = $name;
	357	$name .= sprintf( "%02d", ++$prev );
	358	substr($name, $max_id_length - 3) = "00"
	359	if length( $name ) > $max_id_length;
	360
	361	warn "The name '$name_orig' has been changed to ",
	362	"'$name' to make it unique.\n" if $WARN;
	363
	364	$scope->{ $name_orig }++;
	365	}
	366	$name = substr( $name, 0, $max_id_length )
	367	if ((length( $name ) > $max_id_length) && $critical);
	368	$scope->{ $name }++;
	369	return $name;
	370	}
	371
	372	# -------------------------------------------------------------------
	373	sub unreserve {
54c9812d	374	my $name = shift \|\| '';
54c9812d	375	my $schema_obj_name = shift \|\| '';
d9b22bfe	376	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	377
	378	# also trap fields that don't begin with a letter
54c9812d	379	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
d9b22bfe	380
	381	if ( $schema_obj_name ) {
	382	++$unreserve{"$schema_obj_name.$name"};
	383	}
	384	else {
	385	++$unreserve{"$name (table name)"};
	386	}
	387
	388	my $unreserve = sprintf '%s_', $name;
	389	return $unreserve.$suffix;
	390	}
	391
	392	1;
	393
	394	# -------------------------------------------------------------------
d9b22bfe	395
	396	=pod
	397
590f4d4a	398	=head1 AUTHORS
d9b22bfe	399
590f4d4a	400	Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
d9b22bfe	401	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	402
	403	=cut