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

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

# -------------------------------------------------------------------
# $Id: Sybase.pm,v 1.4 2003-06-11 04:00:44 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.4 $ =~ /(\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'} || [];
            my $commalist      = join ",", @$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	# -------------------------------------------------------------------
a1d94525	4	# $Id: Sybase.pm,v 1.4 2003-06-11 04:00:44 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 ];
a1d94525	34	$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\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;
	173	my $list = $extra{'list'} \|\| [];
	174	my $commalist = join ",", @$list;
d9b22bfe	175	my $seq_name;
	176
	177	if ( $data_type eq 'enum' ) {
590f4d4a	178	my $check_name = mk_name(
	179	$table_name.'_'.$field_name, 'chk' ,undef, 1
	180	);
54c9812d	181	push @constraint_defs,
d9b22bfe	182	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
54c9812d	183	$data_type .= 'character varying';
d9b22bfe	184	}
d9b22bfe	185	elsif ( $data_type eq 'set' ) {
54c9812d	186	$data_type .= 'character varying';
d9b22bfe	187	}
54c9812d	188	elsif ( $field->is_auto_increment ) {
54c9812d	189	$field_def .= ' IDENTITY';
d9b22bfe	190	}
d9b22bfe	191	else {
54c9812d	192	if ( defined $translate{ $data_type } ) {
54c9812d	193	$data_type = $translate{ $data_type };
d9b22bfe	194	}
54c9812d	195	else {
	196	warn "Unknown datatype: $data_type ",
	197	"($table_name.$field_name)\n" if $WARN;
590f4d4a	198	}
54c9812d	199	}
590f4d4a	200
54c9812d	201	my $size = $field->size;
	202	unless ( $size ) {
	203	if ( $data_type =~ /numeric/ ) {
	204	$size = '9,0';
	205	}
	206	elsif ( $orig_data_type eq 'text' ) {
590f4d4a	207	#interpret text fields as long varchars
54c9812d	208	$size = '255';
590f4d4a	209	}
54c9812d	210	elsif (
	211	$data_type eq 'varchar' &&
	212	$orig_data_type eq 'boolean'
	213	) {
	214	$size = '6';
590f4d4a	215	}
54c9812d	216	elsif ( $data_type eq 'varchar' ) {
54c9812d	217	$size = '255';
590f4d4a	218	}
d9b22bfe	219	}
d9b22bfe	220
54c9812d	221	$field_def .= " $data_type";
54c9812d	222	$field_def .= "($size)" if $size;
d9b22bfe	223
	224	#
	225	# Default value
	226	#
54c9812d	227	my $default = $field->default_value;
	228	if ( defined $default ) {
	229	$field_def .= sprintf( ' DEFAULT %s',
	230	( $field->is_auto_increment && $seq_name )
d9b22bfe	231	? qq[nextval('"$seq_name"'::text)] :
54c9812d	232	( $default =~ m/null/i ) ? 'NULL' : "'$default'"
d9b22bfe	233	);
	234	}
	235
	236	#
	237	# Not null constraint
	238	#
54c9812d	239	unless ( $field->is_nullable ) {
54c9812d	240	$field_def .= ' NOT NULL';
d9b22bfe	241	}
590f4d4a	242	else {
54c9812d	243	$field_def .= ' NULL' if $data_type ne 'bit';
590f4d4a	244	}
d9b22bfe	245
54c9812d	246	push @field_defs, $field_def;
d9b22bfe	247	}
	248
	249	#
	250	# Constraint Declarations
	251	#
	252	my @constraint_decs = ();
54c9812d	253	my $c_name_default;
	254	for my $constraint ( $table->get_constraints ) {
	255	my $name = $constraint->name \|\| '';
	256	my $type = $constraint->type \|\| NORMAL;
	257	my @fields = map { unreserve( $_, $table_name ) }
	258	$constraint->fields;
	259	my @rfields = map { unreserve( $_, $table_name ) }
	260	$constraint->reference_fields;
d9b22bfe	261	next unless @fields;
d9b22bfe	262
54c9812d	263	if ( $type eq PRIMARY_KEY ) {
	264	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
	265	push @constraint_defs,
	266	"CONSTRAINT $name PRIMARY KEY ".
d9b22bfe	267	'(' . join( ', ', @fields ) . ')';
d9b22bfe	268	}
54c9812d	269	elsif ( $type eq FOREIGN_KEY ) {
	270	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
	271	push @constraint_defs,
	272	"CONSTRAINT $name FOREIGN KEY".
	273	' (' . join( ', ', @fields ) . ') REFERENCES '.
	274	$constraint->reference_table.
	275	' (' . join( ', ', @rfields ) . ')';
d9b22bfe	276	}
54c9812d	277	elsif ( $type eq UNIQUE ) {
54c9812d	278	$name \|\|= mk_name(
590f4d4a	279	$table_name,
54c9812d	280	$name \|\| ++$c_name_default,undef, 1
d9b22bfe	281	);
54c9812d	282	push @constraint_defs,
54c9812d	283	"CONSTRAINT $name UNIQUE " .
d9b22bfe	284	'(' . join( ', ', @fields ) . ')';
d9b22bfe	285	}
54c9812d	286	}
	287
	288	#
	289	# Indices
	290	#
	291	for my $index ( $table->get_indices ) {
	292	push @index_defs,
	293	'CREATE INDEX ' . $index->name .
	294	" ON $table_name (".
	295	join( ', ', $index->fields ) . ");";
d9b22bfe	296	}
	297
	298	my $create_statement;
	299	$create_statement = qq[DROP TABLE $table_name_ur;\n]
	300	if $add_drop_table;
	301	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
54c9812d	302	join( ",\n",
	303	map { " $_" } @field_defs, @constraint_defs
	304	).
d9b22bfe	305	"\n);"
	306	;
	307
	308	$output .= join( "\n\n",
	309	@comments,
d9b22bfe	310	$create_statement,
54c9812d	311	@index_defs,
54c9812d	312	''
d9b22bfe	313	);
590f4d4a	314	}
590f4d4a	315
d9b22bfe	316	if ( $WARN ) {
	317	if ( %truncated ) {
	318	warn "Truncated " . keys( %truncated ) . " names:\n";
	319	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	320	}
	321
	322	if ( %unreserve ) {
	323	warn "Encounted " . keys( %unreserve ) .
	324	" unsafe names in schema (reserved or invalid):\n";
	325	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	326	}
	327	}
	328
	329	return $output;
	330	}
	331
	332	# -------------------------------------------------------------------
	333	sub mk_name {
54c9812d	334	my $basename = shift \|\| '';
	335	my $type = shift \|\| '';
	336	my $scope = shift \|\| '';
	337	my $critical = shift \|\| '';
d9b22bfe	338	my $basename_orig = $basename;
	339	my $max_name = $type
	340	? $max_id_length - (length($type) + 1)
	341	: $max_id_length;
	342	$basename = substr( $basename, 0, $max_name )
	343	if length( $basename ) > $max_name;
	344	my $name = $type ? "${type}_$basename" : $basename;
54c9812d	345
d9b22bfe	346	if ( $basename ne $basename_orig and $critical ) {
	347	my $show_type = $type ? "+'$type'" : "";
	348	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	349	"character limit to make '$name'\n" if $WARN;
	350	$truncated{ $basename_orig } = $name;
	351	}
	352
	353	$scope \|\|= \%global_names;
	354	if ( my $prev = $scope->{ $name } ) {
	355	my $name_orig = $name;
	356	$name .= sprintf( "%02d", ++$prev );
	357	substr($name, $max_id_length - 3) = "00"
	358	if length( $name ) > $max_id_length;
	359
	360	warn "The name '$name_orig' has been changed to ",
	361	"'$name' to make it unique.\n" if $WARN;
	362
	363	$scope->{ $name_orig }++;
	364	}
	365	$name = substr( $name, 0, $max_id_length )
	366	if ((length( $name ) > $max_id_length) && $critical);
	367	$scope->{ $name }++;
	368	return $name;
	369	}
	370
	371	# -------------------------------------------------------------------
	372	sub unreserve {
54c9812d	373	my $name = shift \|\| '';
54c9812d	374	my $schema_obj_name = shift \|\| '';
d9b22bfe	375	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	376
	377	# also trap fields that don't begin with a letter
54c9812d	378	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
d9b22bfe	379
	380	if ( $schema_obj_name ) {
	381	++$unreserve{"$schema_obj_name.$name"};
	382	}
	383	else {
	384	++$unreserve{"$name (table name)"};
	385	}
	386
	387	my $unreserve = sprintf '%s_', $name;
	388	return $unreserve.$suffix;
	389	}
	390
	391	1;
	392
	393	# -------------------------------------------------------------------
d9b22bfe	394
	395	=pod
	396
590f4d4a	397	=head1 AUTHORS
d9b22bfe	398
590f4d4a	399	Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
d9b22bfe	400	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
	401
	402	=cut