[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 warnings;
our ( $DEBUG, $WARN );
our $VERSION = '1.60';
$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;

            my $identity = '';

            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';
            }
            else {
                if ( $field->is_auto_increment ) {
                    $identity = 'IDENTITY';
                }
                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;
            $field_def .= " $identity" if $identity;

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