[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;
    push @output, header_comment unless ($no_comments);

    my @foreign_keys;

    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 @foreign_keys,
                    "ALTER TABLE $table ADD 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 $drop_statement = $add_drop_table
            ? qq[DROP TABLE $table_name_ur] : '';
        my $create_statement = qq[CREATE TABLE $table_name_ur (\n].
            join( ",\n",
                map { "  $_" } @field_defs, @constraint_defs
            ).
            "\n)"
        ;

        $create_statement = join("\n\n", @comments) . "\n\n" . $create_statement;
        push @output,
            $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.

        push @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.

        push @output, join("\n\n",
                       @comments,
                       $procedure->sql(),
                       );
    }
    push @output, @foreign_keys;

    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 wantarray ? @output : join ";\n\n", @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
ee468516	126	my @output;
	127	push @output, header_comment unless ($no_comments);
	128
	129	my @foreign_keys;
d9b22bfe	130
54c9812d	131	for my $table ( $schema->get_tables ) {
54c9812d	132	my $table_name = $table->name or next;
d9b22bfe	133	$table_name = mk_name( $table_name, '', undef, 1 );
54c9812d	134	my $table_name_ur = unreserve($table_name) \|\| '';
d9b22bfe	135
54c9812d	136	my ( @comments, @field_defs, @index_defs, @constraint_defs );
d9b22bfe	137
	138	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
	139
54c9812d	140	push @comments, map { "-- $_" } $table->comments;
54c9812d	141
d9b22bfe	142	#
	143	# Fields
	144	#
	145	my %field_name_scope;
54c9812d	146	for my $field ( $table->get_fields ) {
d9b22bfe	147	my $field_name = mk_name(
ea93df61	148	$field->name, '', \%field_name_scope, undef,1
d9b22bfe	149	);
d9b22bfe	150	my $field_name_ur = unreserve( $field_name, $table_name );
54c9812d	151	my $field_def = qq["$field_name_ur"];
	152	$field_def =~ s/\"//g;
	153	if ( $field_def =~ /identity/ ){
	154	$field_def =~ s/identity/pidentity/;
590f4d4a	155	}
d9b22bfe	156
	157	#
	158	# Datatype
	159	#
54c9812d	160	my $data_type = lc $field->data_type;
590f4d4a	161	my $orig_data_type = $data_type;
54c9812d	162	my %extra = $field->extra;
54c9812d	163	my $list = $extra{'list'} \|\| [];
77d74ea6	164	# \todo deal with embedded quotes
4524cf01	165	my $commalist = join( ', ', map { qq['$_'] } @$list );
d9b22bfe	166	my $seq_name;
d9b22bfe	167
bde41930	168	my $identity = '';
bde41930	169
d9b22bfe	170	if ( $data_type eq 'enum' ) {
ea93df61	171	my $check_name = mk_name(
590f4d4a	172	$table_name.'_'.$field_name, 'chk' ,undef, 1
590f4d4a	173	);
ea93df61	174	push @constraint_defs,
d9b22bfe	175	"CONSTRAINT $check_name CHECK ($field_name IN ($commalist))";
54c9812d	176	$data_type .= 'character varying';
d9b22bfe	177	}
d9b22bfe	178	elsif ( $data_type eq 'set' ) {
54c9812d	179	$data_type .= 'character varying';
d9b22bfe	180	}
d9b22bfe	181	else {
bde41930	182	if ( $field->is_auto_increment ) {
	183	$identity = 'IDENTITY';
	184	}
54c9812d	185	if ( defined $translate{ $data_type } ) {
54c9812d	186	$data_type = $translate{ $data_type };
d9b22bfe	187	}
54c9812d	188	else {
	189	warn "Unknown datatype: $data_type ",
	190	"($table_name.$field_name)\n" if $WARN;
590f4d4a	191	}
54c9812d	192	}
590f4d4a	193
54c9812d	194	my $size = $field->size;
	195	unless ( $size ) {
	196	if ( $data_type =~ /numeric/ ) {
	197	$size = '9,0';
	198	}
	199	elsif ( $orig_data_type eq 'text' ) {
590f4d4a	200	#interpret text fields as long varchars
54c9812d	201	$size = '255';
590f4d4a	202	}
54c9812d	203	elsif (
ea93df61	204	$data_type eq 'varchar' &&
54c9812d	205	$orig_data_type eq 'boolean'
	206	) {
	207	$size = '6';
590f4d4a	208	}
54c9812d	209	elsif ( $data_type eq 'varchar' ) {
54c9812d	210	$size = '255';
590f4d4a	211	}
d9b22bfe	212	}
d9b22bfe	213
54c9812d	214	$field_def .= " $data_type";
54c9812d	215	$field_def .= "($size)" if $size;
bde41930	216	$field_def .= " $identity" if $identity;
d9b22bfe	217
	218	#
	219	# Default value
	220	#
54c9812d	221	my $default = $field->default_value;
	222	if ( defined $default ) {
	223	$field_def .= sprintf( ' DEFAULT %s',
	224	( $field->is_auto_increment && $seq_name )
d9b22bfe	225	? qq[nextval('"$seq_name"'::text)] :
54c9812d	226	( $default =~ m/null/i ) ? 'NULL' : "'$default'"
d9b22bfe	227	);
	228	}
	229
	230	#
	231	# Not null constraint
	232	#
54c9812d	233	unless ( $field->is_nullable ) {
54c9812d	234	$field_def .= ' NOT NULL';
d9b22bfe	235	}
590f4d4a	236	else {
54c9812d	237	$field_def .= ' NULL' if $data_type ne 'bit';
590f4d4a	238	}
d9b22bfe	239
54c9812d	240	push @field_defs, $field_def;
d9b22bfe	241	}
	242
	243	#
	244	# Constraint Declarations
	245	#
	246	my @constraint_decs = ();
54c9812d	247	my $c_name_default;
	248	for my $constraint ( $table->get_constraints ) {
	249	my $name = $constraint->name \|\| '';
	250	my $type = $constraint->type \|\| NORMAL;
	251	my @fields = map { unreserve( $_, $table_name ) }
	252	$constraint->fields;
	253	my @rfields = map { unreserve( $_, $table_name ) }
	254	$constraint->reference_fields;
d9b22bfe	255	next unless @fields;
d9b22bfe	256
54c9812d	257	if ( $type eq PRIMARY_KEY ) {
54c9812d	258	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
ea93df61	259	push @constraint_defs,
54c9812d	260	"CONSTRAINT $name PRIMARY KEY ".
d9b22bfe	261	'(' . join( ', ', @fields ) . ')';
d9b22bfe	262	}
54c9812d	263	elsif ( $type eq FOREIGN_KEY ) {
54c9812d	264	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
ee468516	265	push @foreign_keys,
ee468516	266	"ALTER TABLE $table ADD CONSTRAINT $name FOREIGN KEY".
54c9812d	267	' (' . join( ', ', @fields ) . ') REFERENCES '.
	268	$constraint->reference_table.
	269	' (' . join( ', ', @rfields ) . ')';
d9b22bfe	270	}
54c9812d	271	elsif ( $type eq UNIQUE ) {
ea93df61	272	$name \|\|= mk_name(
ea93df61	273	$table_name,
54c9812d	274	$name \|\| ++$c_name_default,undef, 1
d9b22bfe	275	);
ea93df61	276	push @constraint_defs,
54c9812d	277	"CONSTRAINT $name UNIQUE " .
d9b22bfe	278	'(' . join( ', ', @fields ) . ')';
d9b22bfe	279	}
54c9812d	280	}
	281
	282	#
	283	# Indices
	284	#
	285	for my $index ( $table->get_indices ) {
ea93df61	286	push @index_defs,
54c9812d	287	'CREATE INDEX ' . $index->name .
54c9812d	288	" ON $table_name (".
ee468516	289	join( ', ', $index->fields ) . ")";
d9b22bfe	290	}
d9b22bfe	291
ee468516	292	my $drop_statement = $add_drop_table
	293	? qq[DROP TABLE $table_name_ur] : '';
	294	my $create_statement = qq[CREATE TABLE $table_name_ur (\n].
ea93df61	295	join( ",\n",
ea93df61	296	map { " $_" } @field_defs, @constraint_defs
54c9812d	297	).
ee468516	298	"\n)"
d9b22bfe	299	;
d9b22bfe	300
ee468516	301	$create_statement = join("\n\n", @comments) . "\n\n" . $create_statement;
ee468516	302	push @output,
ea93df61	303	$create_statement,
ea93df61	304	@index_defs,
ee468516	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
ee468516	317	push @output, join("\n\n",
f996e1ed	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
ee468516	336	push @output, join("\n\n",
f996e1ed	337	@comments,
	338	$procedure->sql(),
	339	);
	340	}
ee468516	341	push @output, @foreign_keys;
f996e1ed	342
d9b22bfe	343	if ( $WARN ) {
	344	if ( %truncated ) {
	345	warn "Truncated " . keys( %truncated ) . " names:\n";
	346	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	347	}
	348
	349	if ( %unreserve ) {
	350	warn "Encounted " . keys( %unreserve ) .
	351	" unsafe names in schema (reserved or invalid):\n";
	352	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	353	}
	354	}
	355
ee468516	356	return wantarray ? @output : join ";\n\n", @output;
d9b22bfe	357	}
d9b22bfe	358
d9b22bfe	359	sub mk_name {
ea93df61	360	my $basename = shift \|\| '';
	361	my $type = shift \|\| '';
	362	my $scope = shift \|\| '';
54c9812d	363	my $critical = shift \|\| '';
d9b22bfe	364	my $basename_orig = $basename;
ea93df61	365	my $max_name = $type
ea93df61	366	? $max_id_length - (length($type) + 1)
d9b22bfe	367	: $max_id_length;
ea93df61	368	$basename = substr( $basename, 0, $max_name )
d9b22bfe	369	if length( $basename ) > $max_name;
d9b22bfe	370	my $name = $type ? "${type}_$basename" : $basename;
54c9812d	371
d9b22bfe	372	if ( $basename ne $basename_orig and $critical ) {
	373	my $show_type = $type ? "+'$type'" : "";
	374	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	375	"character limit to make '$name'\n" if $WARN;
	376	$truncated{ $basename_orig } = $name;
	377	}
	378
	379	$scope \|\|= \%global_names;
	380	if ( my $prev = $scope->{ $name } ) {
	381	my $name_orig = $name;
	382	$name .= sprintf( "%02d", ++$prev );
ea93df61	383	substr($name, $max_id_length - 3) = "00"
d9b22bfe	384	if length( $name ) > $max_id_length;
	385
	386	warn "The name '$name_orig' has been changed to ",
	387	"'$name' to make it unique.\n" if $WARN;
	388
	389	$scope->{ $name_orig }++;
	390	}
ea93df61	391	$name = substr( $name, 0, $max_id_length )
d9b22bfe	392	if ((length( $name ) > $max_id_length) && $critical);
	393	$scope->{ $name }++;
	394	return $name;
	395	}
	396
d9b22bfe	397	sub unreserve {
54c9812d	398	my $name = shift \|\| '';
54c9812d	399	my $schema_obj_name = shift \|\| '';
d9b22bfe	400	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	401
	402	# also trap fields that don't begin with a letter
ea93df61	403	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
d9b22bfe	404
	405	if ( $schema_obj_name ) {
	406	++$unreserve{"$schema_obj_name.$name"};
	407	}
	408	else {
	409	++$unreserve{"$name (table name)"};
	410	}
	411
	412	my $unreserve = sprintf '%s_', $name;
	413	return $unreserve.$suffix;
	414	}
	415
	416	1;
	417
d9b22bfe	418	=pod
d9b22bfe	419
75c75c55	420	=head1 SEE ALSO
	421
	422	SQL::Translator.
	423
590f4d4a	424	=head1 AUTHORS
d9b22bfe	425
590f4d4a	426	Sam Angiuoli E<lt>angiuoli@users.sourceforge.netE<gt>,
75c75c55	427	Paul Harrington E<lt>harringp@deshaw.comE<gt>,
f997b9ab	428	Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
d9b22bfe	429
d9b22bfe	430	=cut