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

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

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