[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;
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;
f27f9229	21	use warnings;
da06ac74	22	use vars qw[ $DEBUG $WARN $VERSION ];
11ad2df9	23	$VERSION = '1.59';
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;
	165
	166	if ( $data_type eq 'enum' ) {
ea93df61	167	my $check_name = mk_name(
590f4d4a	168	$table_name.'_'.$field_name, 'chk' ,undef, 1
590f4d4a	169	);
ea93df61	170	push @constraint_defs,
d9b22bfe	171	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
54c9812d	172	$data_type .= 'character varying';
d9b22bfe	173	}
d9b22bfe	174	elsif ( $data_type eq 'set' ) {
54c9812d	175	$data_type .= 'character varying';
d9b22bfe	176	}
54c9812d	177	elsif ( $field->is_auto_increment ) {
54c9812d	178	$field_def .= ' IDENTITY';
d9b22bfe	179	}
d9b22bfe	180	else {
54c9812d	181	if ( defined $translate{ $data_type } ) {
54c9812d	182	$data_type = $translate{ $data_type };
d9b22bfe	183	}
54c9812d	184	else {
	185	warn "Unknown datatype: $data_type ",
	186	"($table_name.$field_name)\n" if $WARN;
590f4d4a	187	}
54c9812d	188	}
590f4d4a	189
54c9812d	190	my $size = $field->size;
	191	unless ( $size ) {
	192	if ( $data_type =~ /numeric/ ) {
	193	$size = '9,0';
	194	}
	195	elsif ( $orig_data_type eq 'text' ) {
590f4d4a	196	#interpret text fields as long varchars
54c9812d	197	$size = '255';
590f4d4a	198	}
54c9812d	199	elsif (
ea93df61	200	$data_type eq 'varchar' &&
54c9812d	201	$orig_data_type eq 'boolean'
	202	) {
	203	$size = '6';
590f4d4a	204	}
54c9812d	205	elsif ( $data_type eq 'varchar' ) {
54c9812d	206	$size = '255';
590f4d4a	207	}
d9b22bfe	208	}
d9b22bfe	209
54c9812d	210	$field_def .= " $data_type";
54c9812d	211	$field_def .= "($size)" if $size;
d9b22bfe	212
	213	#
	214	# Default value
	215	#
54c9812d	216	my $default = $field->default_value;
	217	if ( defined $default ) {
	218	$field_def .= sprintf( ' DEFAULT %s',
	219	( $field->is_auto_increment && $seq_name )
d9b22bfe	220	? qq[nextval('"$seq_name"'::text)] :
54c9812d	221	( $default =~ m/null/i ) ? 'NULL' : "'$default'"
d9b22bfe	222	);
	223	}
	224
	225	#
	226	# Not null constraint
	227	#
54c9812d	228	unless ( $field->is_nullable ) {
54c9812d	229	$field_def .= ' NOT NULL';
d9b22bfe	230	}
590f4d4a	231	else {
54c9812d	232	$field_def .= ' NULL' if $data_type ne 'bit';
590f4d4a	233	}
d9b22bfe	234
54c9812d	235	push @field_defs, $field_def;
d9b22bfe	236	}
	237
	238	#
	239	# Constraint Declarations
	240	#
	241	my @constraint_decs = ();
54c9812d	242	my $c_name_default;
	243	for my $constraint ( $table->get_constraints ) {
	244	my $name = $constraint->name \|\| '';
	245	my $type = $constraint->type \|\| NORMAL;
	246	my @fields = map { unreserve( $_, $table_name ) }
	247	$constraint->fields;
	248	my @rfields = map { unreserve( $_, $table_name ) }
	249	$constraint->reference_fields;
d9b22bfe	250	next unless @fields;
d9b22bfe	251
54c9812d	252	if ( $type eq PRIMARY_KEY ) {
54c9812d	253	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
ea93df61	254	push @constraint_defs,
54c9812d	255	"CONSTRAINT $name PRIMARY KEY ".
d9b22bfe	256	'(' . join( ', ', @fields ) . ')';
d9b22bfe	257	}
54c9812d	258	elsif ( $type eq FOREIGN_KEY ) {
54c9812d	259	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
ea93df61	260	push @constraint_defs,
54c9812d	261	"CONSTRAINT $name FOREIGN KEY".
	262	' (' . join( ', ', @fields ) . ') REFERENCES '.
	263	$constraint->reference_table.
	264	' (' . join( ', ', @rfields ) . ')';
d9b22bfe	265	}
54c9812d	266	elsif ( $type eq UNIQUE ) {
ea93df61	267	$name \|\|= mk_name(
ea93df61	268	$table_name,
54c9812d	269	$name \|\| ++$c_name_default,undef, 1
d9b22bfe	270	);
ea93df61	271	push @constraint_defs,
54c9812d	272	"CONSTRAINT $name UNIQUE " .
d9b22bfe	273	'(' . join( ', ', @fields ) . ')';
d9b22bfe	274	}
54c9812d	275	}
	276
	277	#
	278	# Indices
	279	#
	280	for my $index ( $table->get_indices ) {
ea93df61	281	push @index_defs,
54c9812d	282	'CREATE INDEX ' . $index->name .
	283	" ON $table_name (".
	284	join( ', ', $index->fields ) . ");";
d9b22bfe	285	}
	286
	287	my $create_statement;
ea93df61	288	$create_statement = qq[DROP TABLE $table_name_ur;\n]
d9b22bfe	289	if $add_drop_table;
d9b22bfe	290	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
ea93df61	291	join( ",\n",
ea93df61	292	map { " $_" } @field_defs, @constraint_defs
54c9812d	293	).
d9b22bfe	294	"\n);"
	295	;
	296
ea93df61	297	$output .= join( "\n\n",
d9b22bfe	298	@comments,
ea93df61	299	$create_statement,
ea93df61	300	@index_defs,
54c9812d	301	''
d9b22bfe	302	);
590f4d4a	303	}
590f4d4a	304
f996e1ed	305	foreach my $view ( $schema->get_views ) {
	306	my (@comments, $view_name);
	307
	308	$view_name = $view->name();
	309	push @comments, "--\n-- View: $view_name\n--" unless $no_comments;
	310
	311	# text of view is already a 'create view' statement so no need
	312	# to do anything fancy.
	313
	314	$output .= join("\n\n",
	315	@comments,
	316	$view->sql(),
	317	);
	318	}
	319
	320
	321	foreach my $procedure ( $schema->get_procedures ) {
	322	my (@comments, $procedure_name);
	323
	324	$procedure_name = $procedure->name();
ea93df61	325	push @comments,
75c75c55	326	"--\n-- Procedure: $procedure_name\n--" unless $no_comments;
f996e1ed	327
75c75c55	328	# text of procedure already has the 'create procedure' stuff
	329	# so there is no need to do anything fancy. However, we should
	330	# think about doing fancy stuff with granting permissions and
	331	# so on.
f996e1ed	332
	333	$output .= join("\n\n",
	334	@comments,
	335	$procedure->sql(),
	336	);
	337	}
	338
d9b22bfe	339	if ( $WARN ) {
	340	if ( %truncated ) {
	341	warn "Truncated " . keys( %truncated ) . " names:\n";
	342	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	343	}
	344
	345	if ( %unreserve ) {
	346	warn "Encounted " . keys( %unreserve ) .
	347	" unsafe names in schema (reserved or invalid):\n";
	348	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	349	}
	350	}
	351
	352	return $output;
	353	}
	354
d9b22bfe	355	sub mk_name {
ea93df61	356	my $basename = shift \|\| '';
	357	my $type = shift \|\| '';
	358	my $scope = shift \|\| '';
54c9812d	359	my $critical = shift \|\| '';
d9b22bfe	360	my $basename_orig = $basename;
ea93df61	361	my $max_name = $type
ea93df61	362	? $max_id_length - (length($type) + 1)
d9b22bfe	363	: $max_id_length;
ea93df61	364	$basename = substr( $basename, 0, $max_name )
d9b22bfe	365	if length( $basename ) > $max_name;
d9b22bfe	366	my $name = $type ? "${type}_$basename" : $basename;
54c9812d	367
d9b22bfe	368	if ( $basename ne $basename_orig and $critical ) {
	369	my $show_type = $type ? "+'$type'" : "";
	370	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	371	"character limit to make '$name'\n" if $WARN;
	372	$truncated{ $basename_orig } = $name;
	373	}
	374
	375	$scope \|\|= \%global_names;
	376	if ( my $prev = $scope->{ $name } ) {
	377	my $name_orig = $name;
	378	$name .= sprintf( "%02d", ++$prev );
ea93df61	379	substr($name, $max_id_length - 3) = "00"
d9b22bfe	380	if length( $name ) > $max_id_length;
	381
	382	warn "The name '$name_orig' has been changed to ",
	383	"'$name' to make it unique.\n" if $WARN;
	384
	385	$scope->{ $name_orig }++;
	386	}
ea93df61	387	$name = substr( $name, 0, $max_id_length )
d9b22bfe	388	if ((length( $name ) > $max_id_length) && $critical);
	389	$scope->{ $name }++;
	390	return $name;
	391	}
	392
d9b22bfe	393	sub unreserve {
54c9812d	394	my $name = shift \|\| '';
54c9812d	395	my $schema_obj_name = shift \|\| '';
d9b22bfe	396	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	397
	398	# also trap fields that don't begin with a letter
ea93df61	399	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
d9b22bfe	400
	401	if ( $schema_obj_name ) {
	402	++$unreserve{"$schema_obj_name.$name"};
	403	}
	404	else {
	405	++$unreserve{"$name (table name)"};
	406	}
	407
	408	my $unreserve = sprintf '%s_', $name;
	409	return $unreserve.$suffix;
	410	}
	411
	412	1;
	413
d9b22bfe	414	=pod
d9b22bfe	415
75c75c55	416	=head1 SEE ALSO
	417
	418	SQL::Translator.
	419
590f4d4a	420	=head1 AUTHORS
d9b22bfe	421
590f4d4a	422	Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
75c75c55	423	Paul Harrington E<lt>harringp@deshaw.comE<gt>,
f997b9ab	424	Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
d9b22bfe	425
d9b22bfe	426	=cut