[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',
	46	serial => 'numeric',
	47	boolean => 'varchar',
	48	char => 'char',
	49	long => 'varchar',
d9b22bfe	50	);
	51
	52	my %reserved = map { $_, 1 } qw[
	53	ALL ANALYSE ANALYZE AND ANY AS ASC
	54	BETWEEN BINARY BOTH
	55	CASE CAST CHECK COLLATE COLUMN CONSTRAINT CROSS
	56	CURRENT_DATE CURRENT_TIME CURRENT_TIMESTAMP CURRENT_USER
	57	DEFAULT DEFERRABLE DESC DISTINCT DO
	58	ELSE END EXCEPT
	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
	63	NATURAL NEW NOT NOTNULL NULL
	64	OFF OFFSET OLD ON ONLY OR ORDER OUTER OVERLAPS
	65	PRIMARY PUBLIC REFERENCES RIGHT
	66	SELECT SESSION_USER SOME TABLE THEN TO TRAILING TRUE
	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
117	# -------------------------------------------------------------------
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(
54c9812d	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' ) {
590f4d4a	167	my $check_name = mk_name(
	168	$table_name.'_'.$field_name, 'chk' ,undef, 1
	169	);
54c9812d	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 (
	200	$data_type eq 'varchar' &&
	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 ) {
	253	$name \|\|= mk_name( $table_name, 'pk', undef,1 );
	254	push @constraint_defs,
	255	"CONSTRAINT $name PRIMARY KEY ".
d9b22bfe	256	'(' . join( ', ', @fields ) . ')';
d9b22bfe	257	}
54c9812d	258	elsif ( $type eq FOREIGN_KEY ) {
	259	$name \|\|= mk_name( $table_name, 'fk', undef,1 );
	260	push @constraint_defs,
	261	"CONSTRAINT $name FOREIGN KEY".
	262	' (' . join( ', ', @fields ) . ') REFERENCES '.
	263	$constraint->reference_table.
	264	' (' . join( ', ', @rfields ) . ')';
d9b22bfe	265	}
54c9812d	266	elsif ( $type eq UNIQUE ) {
54c9812d	267	$name \|\|= mk_name(
590f4d4a	268	$table_name,
54c9812d	269	$name \|\| ++$c_name_default,undef, 1
d9b22bfe	270	);
54c9812d	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 ) {
	281	push @index_defs,
	282	'CREATE INDEX ' . $index->name .
	283	" ON $table_name (".
	284	join( ', ', $index->fields ) . ");";
d9b22bfe	285	}
	286
	287	my $create_statement;
	288	$create_statement = qq[DROP TABLE $table_name_ur;\n]
	289	if $add_drop_table;
	290	$create_statement .= qq[CREATE TABLE $table_name_ur (\n].
54c9812d	291	join( ",\n",
	292	map { " $_" } @field_defs, @constraint_defs
	293	).
d9b22bfe	294	"\n);"
	295	;
	296
	297	$output .= join( "\n\n",
	298	@comments,
d9b22bfe	299	$create_statement,
54c9812d	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();
75c75c55	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
	355	# -------------------------------------------------------------------
	356	sub mk_name {
54c9812d	357	my $basename = shift \|\| '';
	358	my $type = shift \|\| '';
	359	my $scope = shift \|\| '';
	360	my $critical = shift \|\| '';
d9b22bfe	361	my $basename_orig = $basename;
	362	my $max_name = $type
	363	? $max_id_length - (length($type) + 1)
	364	: $max_id_length;
	365	$basename = substr( $basename, 0, $max_name )
	366	if length( $basename ) > $max_name;
	367	my $name = $type ? "${type}_$basename" : $basename;
54c9812d	368
d9b22bfe	369	if ( $basename ne $basename_orig and $critical ) {
	370	my $show_type = $type ? "+'$type'" : "";
	371	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	372	"character limit to make '$name'\n" if $WARN;
	373	$truncated{ $basename_orig } = $name;
	374	}
	375
	376	$scope \|\|= \%global_names;
	377	if ( my $prev = $scope->{ $name } ) {
	378	my $name_orig = $name;
	379	$name .= sprintf( "%02d", ++$prev );
	380	substr($name, $max_id_length - 3) = "00"
	381	if length( $name ) > $max_id_length;
	382
	383	warn "The name '$name_orig' has been changed to ",
	384	"'$name' to make it unique.\n" if $WARN;
	385
	386	$scope->{ $name_orig }++;
	387	}
	388	$name = substr( $name, 0, $max_id_length )
	389	if ((length( $name ) > $max_id_length) && $critical);
	390	$scope->{ $name }++;
	391	return $name;
	392	}
	393
	394	# -------------------------------------------------------------------
	395	sub unreserve {
54c9812d	396	my $name = shift \|\| '';
54c9812d	397	my $schema_obj_name = shift \|\| '';
d9b22bfe	398	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
	399
	400	# also trap fields that don't begin with a letter
54c9812d	401	return $name if !$reserved{ uc $name } && $name =~ /^[a-z]/i;
d9b22bfe	402
	403	if ( $schema_obj_name ) {
	404	++$unreserve{"$schema_obj_name.$name"};
	405	}
	406	else {
	407	++$unreserve{"$name (table name)"};
	408	}
	409
	410	my $unreserve = sprintf '%s_', $name;
	411	return $unreserve.$suffix;
	412	}
	413
	414	1;
	415
	416	# -------------------------------------------------------------------
d9b22bfe	417
	418	=pod
	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