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

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

# -------------------------------------------------------------------
# $Id: Sybase.pm,v 1.1 2003-05-12 14:29:51 angiuoli Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>,
#                    Chris Mungall <cjm@fruitfly.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Producer::Sybase - Sybase producer for SQL::Translator

=cut

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

use Data::Dumper;

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;
    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, 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 .= ' CONSTRAINT '.$constraint_name.' NOT NULL';
                $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;

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