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

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

# -------------------------------------------------------------------
# $Id: Sybase.pm,v 1.2 2003-05-12 15:00:34 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.2 $ =~ /(\d+)\.(\d+)/;
$DEBUG = 1 unless defined $DEBUG;

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

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

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, $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, undef,1 
            );
            my $field_name_ur = unreserve( $field_name, $table_name );
            my $field_str     = qq["$field_name_ur"];
            $field_str =~ s/\"//g;
            if ($field_str =~ /identity/){
                $field_str =~ s/identity/pidentity/;
            }

            #
            # Datatype
            #
            my $data_type = lc $field->{'data_type'};
            my $orig_data_type = $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' ,undef, 1
                );
                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 .= ' IDENTITY';
            }
            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|decimal)/i ) {
                    $field_str .= '('.join(',', @{ $field->{'size'} }).')' 
                        if @{ $field->{'size'} || [] };
                }
                elsif( $data_type =~ /numeric/){
                    $field_str .= '(9,0)';
                }

                if( $orig_data_type eq 'text'){
                    #interpret text fields as long varchars
                    $field_str .= '(255)';
                }
                elsif($data_type eq "varchar" && $orig_data_type eq "boolean"){
                    $field_str .= '(6)';
                }
                elsif($data_type eq "varchar" && (!$field->{'size'})){
                    $field_str .= '(255)';
                }
            }


            #
            # 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',undef,1);
                $field_str .= ' NOT NULL';
            }
            else {
                $field_str .= ' NULL' if($data_type ne "bit");
            }

            push @field_decs, $field_str;
        }

        #
        # Constraint Declarations
        #
        my @constraint_decs = ();
        my $idx_name_default;
        for my $constraint ( @{ $table->{'constraints'} } ) {
            my $constraint_name = $constraint->{'name'} || '';
            my $constraint_type = $constraint->{'type'} || 'normal';
            my @fields     = map { unreserve( $_, $table_name ) }
                             @{ $constraint->{'fields'} };
            next unless @fields;

            if ( $constraint_type eq 'primary_key' ) {
                $constraint_name = mk_name( $table_name, 'pk',undef,1 );
                push @constraints, 
                    'CONSTRAINT '.$constraint_name.' PRIMARY KEY '.
                    '(' . join( ', ', @fields ) . ')';
            }
            if ( $constraint_type eq 'foreign_key' ) {
                $constraint_name = mk_name( $table_name, 'fk',undef,1 );
                push @constraints, 
                    'CONSTRAINT '.$constraint_name.' FOREIGN KEY '.
                    '(' . join( ', ', @fields ) . ') '.
                    "REFERENCES $constraint->{'reference_table'}($constraint->{'reference_fields'}[0])";
            }
            elsif ( $constraint_type eq 'unique' ) {
                $constraint_name = mk_name( 
                    $table_name, 
                    $constraint_name || ++$idx_name_default,undef, 1
                );
                push @constraints, 
                    'CONSTRAINT ' . $constraint_name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $constraint_type eq 'normal' ) {
                $constraint_name = mk_name( 
                    $table_name, 
                    $constraint_name || ++$idx_name_default, undef, 1
                );
                push @constraint_decs, 
                    qq[CREATE CONSTRAINT "$constraint_name" on $table_name_ur (].
                    join( ', ', @fields ).  
                    ');'; 
            }
            else {
                warn "Unknown constraint type ($constraint_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, 
            @constraint_decs, 
            '' 
        );
    }

    #
    # Index Declarations
    #
    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 @index_decs = ();
        for my $index ( @{ $table->{'indices'} } ) {
            my $unique = ($index->{'name'} eq 'unique') ? 'unique' : '';
            $output .= "CREATE $unique INDEX $index->{'name'} ".
                "ON $table->{'table_name'} (".
                join(',',@{$index->{'fields'}}).");\n";
        }
    }

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

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

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