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

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

# -------------------------------------------------------------------
# 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.59';
$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 Youens-Clark E<lt>kclark@cpan.orgE<gt>.

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