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

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

# -------------------------------------------------------------------
# $Id$
# -------------------------------------------------------------------
# Copyright (C) 2002-2009 SQLFairy Authors
#
# 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

=head1 SYNOPSIS

  use SQL::Translator;

  my $t = SQL::Translator->new( parser => '...', producer => 'Sybase' );
  $t->translate;

=head1 DESCRIPTION

This module will produce text output of the schema suitable for Sybase.

=cut

use strict;
use vars qw[ $DEBUG $WARN $VERSION ];
$VERSION = '1.99';
$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, 
            ''
        );
    }

    foreach my $view ( $schema->get_views ) {
        my (@comments, $view_name);

        $view_name = $view->name();
        push @comments, "--\n-- View: $view_name\n--" unless $no_comments;

        # text of view is already a 'create view' statement so no need
        # to do anything fancy.

        $output .= join("\n\n",
                       @comments,
                       $view->sql(),
                       );
    }


    foreach my $procedure ( $schema->get_procedures ) {
        my (@comments, $procedure_name);

        $procedure_name = $procedure->name();
        push @comments, 
            "--\n-- Procedure: $procedure_name\n--" unless $no_comments;

        # text of procedure  already has the 'create procedure' stuff
        # so there is no need to do anything fancy. However, we should
        # think about doing fancy stuff with granting permissions and
        # so on.

        $output .= join("\n\n",
                       @comments,
                       $procedure->sql(),
                       );
    }

    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 SEE ALSO

SQL::Translator.

=head1 AUTHORS

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

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