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

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

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