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

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

# -------------------------------------------------------------------
# $Id: Sybase.pm,v 1.8 2003-10-15 19:16:32 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
#   Paul Harrington <harringp@deshaw.com>,
#   Sam Angiuoli <angiuoli@users.sourceforge.net>.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

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

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