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

package SQL::Translator::Producer::Oracle;

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.4 2002-11-22 03:03:40 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------


use strict;
use vars qw[ $VERSION $DEBUG ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

my $max_id_length = 30;
my %used_identifiers = ();

my %translate  = (
    #
    # MySQL types
    #
    bigint     => 'number',
    double     => 'number',
    decimal    => 'number',
    float      => 'number',
    int        => 'number',
    mediumint  => 'number',
    smallint   => 'number',
    tinyint    => 'number',
    char       => 'char',
    varchar    => 'varchar2',
    tinyblob   => 'CLOB',
    blob       => 'CLOB',
    mediumblob => 'CLOB',
    longblob   => 'CLOB',
    longtext   => 'long',
    mediumtext => 'long',
    text       => 'long',
    tinytext   => 'long',
    enum       => 'varchar2',
    set        => 'varchar2',
    date       => 'date',
    datetime   => 'date',
    time       => 'date',
    timestamp  => 'date',
    year       => 'date',

    #
    # PostgreSQL types
    #
    smallint            => '',
    integer             => '',
    bigint              => '',
    decimal             => '',
    numeric             => '',
    real                => '',
    'double precision'  => '',
    serial              => '',
    bigserial           => '',
    money               => '',
    character           => '',
    'character varying' => '',
    bytea               => '',
    interval            => '',
    boolean             => '',
    point               => '',
    line                => '',
    lseg                => '',
    box                 => '',
    path                => '',
    polygon             => '',
    circle              => '',
    cidr                => '',
    inet                => '',
    macaddr             => '',
    bit                 => '',
    'bit varying'       => '',
);

#
# Oracle reserved words from:
# http://technet.oracle.com/docs/products/oracle8i/doc_library/\
# 817_doc/server.817/a85397/ap_keywd.htm
#
my @ora_reserved = qw(
    ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT 
    BETWEEN BY
    CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
    DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
    ELSE EXCLUSIVE EXISTS 
    FILE FLOAT FOR FROM
    GRANT GROUP 
    HAVING
    IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
    INTEGER INTERSECT INTO IS
    LEVEL LIKE LOCK LONG 
    MAXEXTENTS MINUS MLSLABEL MODE MODIFY 
    NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER 
    OF OFFLINE ON ONLINE OPTION OR ORDER
    PCTFREE PRIOR PRIVILEGES PUBLIC
    RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
    SELECT SESSION SET SHARE SIZE SMALLINT START 
    SUCCESSFUL SYNONYM SYSDATE 
    TABLE THEN TO TRIGGER 
    UID UNION UNIQUE UPDATE USER
    VALIDATE VALUES VARCHAR VARCHAR2 VIEW
    WHENEVER WHERE WITH
);

my %ora_reserved = map { $_ => 1 } @ora_reserved;
my %global_names;
my %unreserve;
my %truncated;

sub produce {
    my ( $translator, $data ) = @_;
    $DEBUG                    = $translator->debug;
    my $no_comments           = $translator->no_comments;

    #print "got ", scalar keys %$data, " tables:\n";
    #print join(', ', keys %$data), "\n";
    #print Dumper( $data );

    my $output;
    unless ( $no_comments ) {
        $output .=  sprintf 
            "--\n-- Created by %s\n-- Created on %s\n--\n\n",
            __PACKAGE__, scalar localtime;
    }

    if ( $translator->parser_type =~ /mysql/i ) {
        $output .= 
        "-- We assume that default NLS_DATE_FORMAT has been changed\n".
        "-- but we set it here anyway to be self-consistent.\n".
        "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
    }

    #
    # Print create for each table
    #
    my ( $index_i, $trigger_i ) = ( 1, 1 );
    for my $table ( 
        # sort keys %$data 
        map  { $_->[1] }
        sort { $a->[0] <=> $b->[0] }
        map  { [ $_->{'order'}, $_ ] }
        values %{ $data }
    ) { 
        my $table_name = $table->{'table_name'};
#        check_identifier( $table_name );
        $table_name = mk_name( $table_name, '', undef, 1 );
#        my $tablename_ur = unreserve($table_name);

        my ( @comments, @field_decs, @trigger_decs );

        push @comments, "--\n-- Table: $table_name\n--" unless $no_comments;

        for my $field ( 
            map  { $_->[1] }
            sort { $a->[0] <=> $b->[0] }
            map  { [ $_->{'order'}, $_ ] }
            values %{ $table->{'fields'} }
        ) {
            #
            # Field name
            #
            my $field_str  = check_identifier( $field->{'name'} );

            #
            # Datatype
            #
            my $data_type  = $field->{'data_type'};
               $data_type  = defined $translate{ $data_type } ?
                             $translate{ $data_type } :
                             die "Unknown datatype: $data_type\n";
               $field_str .= ' '.$data_type;
               $field_str .= '('.join(',', @{ $field->{'size'} }).')' 
                if @{ $field->{'size'} || [] };

            #
            # Default value
            #
            if ( $field->{'default'} ) {
    #            next if $field->{'default'} eq 'NULL';
                $field_str .= sprintf(
                    ' DEFAULT %s',
                    $field->{'default'} =~ m/null/i ? 'NULL' : 
                    "'".$field->{'default'}."'"
                );
            }

            #
            # Not null constraint
            #
            unless ( $field->{'null'} ) {
                my $constraint_name = make_identifier($field->{'name'}, '_nn');
                $field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
            }

            #
            # Auto_increment
            #
            if ( $field->{'is_auto_inc'} ) {
                my $trigger_no       = $trigger_i++;
                my $trigger_sequence = 
                    join( '_', 'seq'    , $field->{'name'}, $trigger_no );
                my $trigger_name     = 
                    join( '_', 'autoinc', $field->{'name'}, $trigger_no );

                push @trigger_decs, 
                    "CREATE SEQUENCE $trigger_sequence;\n" .
                    "CREATE OR REPLACE TRIGGER $trigger_name\n" .
                    "BEFORE INSERT ON $table_name\n" .
                    "FOR EACH ROW WHEN (new.".$field->{'name'}." is null)\n".
                    "BEGIN\n" .
                        " SELECT $trigger_sequence.nextval\n" .
                        " INTO :new." . $field->{'name'}."\n" .
                        " FROM dual;\n" .
                    " END  $trigger_name;/"
                ;
            }

            push @field_decs, $field_str;
        }

        #
        # Index Declarations
        #
        my @index_decs = ();
        for my $index ( @{ $table->{'indices'} } ) {
            my $index_name = $index->{'name'} || '';
            my $index_type = $index->{'type'} || 'normal';
            my @fields     = @{ $index->{'fields'} } or next;

            if ( $index_type eq 'primary_key' ) {
                if ( !$index_name ) {
                    $index_name = make_identifier( $table_name, 'i_', '_pk' );
                }
                elsif ( $index_name !~ m/^i_/ ) {
                    $index_name = make_identifier( $table_name, 'i_' );
                }
                elsif ( $index_name !~ m/_pk$/ ) {
                    $index_name = make_identifier( $table_name, '_pk' );
                }
                else {
                    $index_name = make_identifier( $index_name );
                }

                push @field_decs, 'CONSTRAINT ' . $index_name . ' PRIMARY KEY ' .
                    '(' . join( ', ', @fields ) . ')';
            }

            elsif ( $index_type eq 'unique' ) {
                if ( !$index_name ) {
                    $index_name = make_identifier( join( '_', @fields ), 'u_' );
                }
                elsif ( $index_name !~ m/^u_/ ) {
                    $index_name = make_identifier( $index_name, 'u_' );
                }
                else {
                    $index_name = make_identifier( $index_name );
                }

                push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }

            elsif ( $index_type eq 'normal' ) {
                if ( !$index_name ) {
                    $index_name = 
                        make_identifier($table_name, 'i_', '_'.$index_i++ );
                }
                elsif ( $index_name !~ m/^i_/ ) {
                    $index_name = make_identifier( $index_name, 'i_' );
                }
                else {
                    $index_name = make_identifier( $index_name );
                }

                push @index_decs, "CREATE INDEX $index_name on $table_name (".
                    join( ', ', @{ $index->{'fields'} } ).
                    ");"
                ; 
            }

            else {
                warn "On table $table_name, unknown index type: $index_type\n";
            }
        }

        my $create_statement = "CREATE TABLE $table_name (\n".
            join( ",\n", map { "  $_" } @field_decs ).
             "\n);"
        ;

        $output .= join( "\n\n", 
            @comments,
            $create_statement, 
            @trigger_decs, 
            @index_decs, 
            '' 
        );
    }

    return $output;
}

#
# Used to make index names
#
sub make_identifier {
    my ( $identifier, @mutations ) = @_;
    my $length_of_mutations;
    for my $mutation ( @mutations ) {
        $length_of_mutations += length( $mutation );
    }

    if ( 
        length( $identifier ) + $length_of_mutations >
        $max_id_length
    ) {
        $identifier = substr( 
            $identifier, 
            0, 
            $max_id_length - $length_of_mutations
        );
    }

    for my $mutation ( @mutations ) {
        if ( $mutation =~ m/.+_$/ ) {
            $identifier = $mutation.$identifier;
        }
        elsif ( $mutation =~ m/^_.+/ ) {
            $identifier = $identifier.$mutation;
        }
    }

    if ( $used_identifiers{ $identifier } ) {
        my $index = 1;
        if ( $identifier =~ m/_(\d+)$/ ) {
            $index = $1;
            $identifier = substr( 
                $identifier, 
                0, 
                length( $identifier ) - ( length( $index ) + 1 )
            );
        }
        $index++;
        return make_identifier( $identifier, '_'.$index );
    }

    $used_identifiers{ $identifier } = 1;

    return $identifier;
}

#
# Checks to see if an identifier is not too long
#
sub check_identifier {
    my $identifier = shift;
    die "Identifier '$identifier' is too long, unrecoverable error.\n"
        if length( $identifier ) > $max_id_length;
    return $identifier;
}

# -------------------------------------------------------------------
sub mk_name {
    my ($basename, $type, $scope, $critical) = @_;
    my $basename_orig = $basename;
    my $max_name      = $max_id_length - (length($type) + 1);
    $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 $DEBUG;
        $truncated{$basename_orig} = $name;
    }

    $scope ||= \%global_names;
    return $name unless $scope->{$name}++;
    my $name_orig = $name;
    $name .= "02";
    substr($name, $max_id_length - 3) = "00" if length($name) > $max_id_length;
    ++$name while $scope->{$name};
    warn "The name '$name_orig' has been changed to ",
         "'$name' to make it unique\n" if $DEBUG;
    return $name;
}

# -------------------------------------------------------------------
sub unreserve {
    my ($name, $schema_obj_name) = @_;
    my ($suffix) = ($name =~ s/(\W.*)$//) ? $1 : '';

    # also trap fields that don't begin with a letter
    return $_[0] if !$ora_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;

# -------------------------------------------------------------------
# All bad art is the result of good intentions.
# Oscar Wilde
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Producer::Oracle - Oracle SQL producer

=head1 SYNOPSIS

  use SQL::Translator::Parser::MySQL;
  use SQL::Translator::Producer::Oracle;

  my $original_create = ""; # get this from somewhere...
  my $translator = SQL::Translator->new;

  $translator->parser("SQL::Translator::Parser::MySQL");
  $translator->producer("SQL::Translator::Producer::Oracle");

  my $new_create = $translator->translate($original_create);

=head1 DESCRIPTION

SQL::Translator::Producer::Oracle takes a parsed data structure,
created by a SQL::Translator::Parser subclass, and turns it into a
create string suitable for use with an Oracle database.

=head1 BUGS

Problem with SQL::Translator::Producer::Oracle: it is keeping track
of the last sequence number used, so as not to duplicate them, which
is reasonable.  However on runs past the first, it seems to be
creating multiple constraint lines, that look like:

    CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
    CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)

This is a very preliminary finding, and needs to be investigated more
thoroughly, of course.

=head1 CREDITS

A hearty "thank-you" to Tim Bunce for much of the logic stolen from 
his "mysql2ora" script.

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>

=head1 SEE ALSO

perl(1).

=cut
Commit	Line	Data
16dc9970	1	package SQL::Translator::Producer::Oracle;
16dc9970	2
077ebf34	3	# -------------------------------------------------------------------
d529894e	4	# $Id: Oracle.pm,v 1.4 2002-11-22 03:03:40 kycl4rk Exp $
077ebf34	5	# -------------------------------------------------------------------
d529894e	6	# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
077ebf34	7	# darren chamberlain <darren@cpan.org>
16dc9970	8	#
077ebf34	9	# This program is free software; you can redistribute it and/or
	10	# modify it under the terms of the GNU General Public License as
	11	# published by the Free Software Foundation; version 2.
	12	#
	13	# This program is distributed in the hope that it will be useful, but
	14	# WITHOUT ANY WARRANTY; without even the implied warranty of
	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	16	# General Public License for more details.
	17	#
	18	# You should have received a copy of the GNU General Public License
	19	# along with this program; if not, write to the Free Software
	20	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	21	# 02111-1307 USA
	22	# -------------------------------------------------------------------
	23
16dc9970	24
16dc9970	25	use strict;
d529894e	26	use vars qw[ $VERSION $DEBUG ];
	27	$VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
	28	$DEBUG = 0 unless defined $DEBUG;
16dc9970	29
d529894e	30	my $max_id_length = 30;
16dc9970	31	my %used_identifiers = ();
	32
	33	my %translate = (
d529894e	34	#
	35	# MySQL types
	36	#
16dc9970	37	bigint => 'number',
	38	double => 'number',
	39	decimal => 'number',
	40	float => 'number',
	41	int => 'number',
	42	mediumint => 'number',
	43	smallint => 'number',
	44	tinyint => 'number',
16dc9970	45	char => 'char',
16dc9970	46	varchar => 'varchar2',
16dc9970	47	tinyblob => 'CLOB',
	48	blob => 'CLOB',
	49	mediumblob => 'CLOB',
	50	longblob => 'CLOB',
16dc9970	51	longtext => 'long',
	52	mediumtext => 'long',
	53	text => 'long',
	54	tinytext => 'long',
16dc9970	55	enum => 'varchar2',
16dc9970	56	set => 'varchar2',
16dc9970	57	date => 'date',
	58	datetime => 'date',
	59	time => 'date',
	60	timestamp => 'date',
	61	year => 'date',
d529894e	62
	63	#
	64	# PostgreSQL types
	65	#
	66	smallint => '',
	67	integer => '',
	68	bigint => '',
	69	decimal => '',
	70	numeric => '',
	71	real => '',
	72	'double precision' => '',
	73	serial => '',
	74	bigserial => '',
	75	money => '',
	76	character => '',
	77	'character varying' => '',
	78	bytea => '',
	79	interval => '',
	80	boolean => '',
	81	point => '',
	82	line => '',
	83	lseg => '',
	84	box => '',
	85	path => '',
	86	polygon => '',
	87	circle => '',
	88	cidr => '',
	89	inet => '',
	90	macaddr => '',
	91	bit => '',
	92	'bit varying' => '',
	93	);
	94
	95	#
	96	# Oracle reserved words from:
	97	# http://technet.oracle.com/docs/products/oracle8i/doc_library/\
	98	# 817_doc/server.817/a85397/ap_keywd.htm
	99	#
	100	my @ora_reserved = qw(
	101	ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
	102	BETWEEN BY
	103	CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
	104	DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
	105	ELSE EXCLUSIVE EXISTS
	106	FILE FLOAT FOR FROM
	107	GRANT GROUP
	108	HAVING
	109	IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
	110	INTEGER INTERSECT INTO IS
	111	LEVEL LIKE LOCK LONG
	112	MAXEXTENTS MINUS MLSLABEL MODE MODIFY
	113	NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
	114	OF OFFLINE ON ONLINE OPTION OR ORDER
	115	PCTFREE PRIOR PRIVILEGES PUBLIC
	116	RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
	117	SELECT SESSION SET SHARE SIZE SMALLINT START
	118	SUCCESSFUL SYNONYM SYSDATE
	119	TABLE THEN TO TRIGGER
	120	UID UNION UNIQUE UPDATE USER
	121	VALIDATE VALUES VARCHAR VARCHAR2 VIEW
	122	WHENEVER WHERE WITH
16dc9970	123	);
16dc9970	124
d529894e	125	my %ora_reserved = map { $_ => 1 } @ora_reserved;
	126	my %global_names;
	127	my %unreserve;
	128	my %truncated;
16dc9970	129
077ebf34	130	sub produce {
077ebf34	131	my ( $translator, $data ) = @_;
d529894e	132	$DEBUG = $translator->debug;
d529894e	133	my $no_comments = $translator->no_comments;
16dc9970	134
	135	#print "got ", scalar keys %$data, " tables:\n";
	136	#print join(', ', keys %$data), "\n";
	137	#print Dumper( $data );
	138
d529894e	139	my $output;
	140	unless ( $no_comments ) {
	141	$output .= sprintf
	142	"--\n-- Created by %s\n-- Created on %s\n--\n\n",
	143	__PACKAGE__, scalar localtime;
	144	}
077ebf34	145
d529894e	146	if ( $translator->parser_type =~ /mysql/i ) {
	147	$output .=
	148	"-- We assume that default NLS_DATE_FORMAT has been changed\n".
	149	"-- but we set it here anyway to be self-consistent.\n".
	150	"ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
	151	}
16dc9970	152
	153	#
	154	# Print create for each table
	155	#
	156	my ( $index_i, $trigger_i ) = ( 1, 1 );
d529894e	157	for my $table (
	158	# sort keys %$data
	159	map { $_->[1] }
	160	sort { $a->[0] <=> $b->[0] }
	161	map { [ $_->{'order'}, $_ ] }
	162	values %{ $data }
	163	) {
	164	my $table_name = $table->{'table_name'};
	165	# check_identifier( $table_name );
	166	$table_name = mk_name( $table_name, '', undef, 1 );
	167	# my $tablename_ur = unreserve($table_name);
16dc9970	168
	169	my ( @comments, @field_decs, @trigger_decs );
	170
d529894e	171	push @comments, "--\n-- Table: $table_name\n--" unless $no_comments;
16dc9970	172
	173	for my $field (
	174	map { $_->[1] }
	175	sort { $a->[0] <=> $b->[0] }
	176	map { [ $_->{'order'}, $_ ] }
	177	values %{ $table->{'fields'} }
	178	) {
	179	#
	180	# Field name
	181	#
	182	my $field_str = check_identifier( $field->{'name'} );
	183
	184	#
	185	# Datatype
	186	#
	187	my $data_type = $field->{'data_type'};
	188	$data_type = defined $translate{ $data_type } ?
	189	$translate{ $data_type } :
	190	die "Unknown datatype: $data_type\n";
	191	$field_str .= ' '.$data_type;
d529894e	192	$field_str .= '('.join(',', @{ $field->{'size'} }).')'
d529894e	193	if @{ $field->{'size'} \|\| [] };
16dc9970	194
	195	#
	196	# Default value
	197	#
	198	if ( $field->{'default'} ) {
	199	# next if $field->{'default'} eq 'NULL';
	200	$field_str .= sprintf(
	201	' DEFAULT %s',
	202	$field->{'default'} =~ m/null/i ? 'NULL' :
	203	"'".$field->{'default'}."'"
	204	);
	205	}
	206
	207	#
	208	# Not null constraint
	209	#
	210	unless ( $field->{'null'} ) {
	211	my $constraint_name = make_identifier($field->{'name'}, '_nn');
	212	$field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
	213	}
	214
	215	#
	216	# Auto_increment
	217	#
	218	if ( $field->{'is_auto_inc'} ) {
	219	my $trigger_no = $trigger_i++;
	220	my $trigger_sequence =
	221	join( '_', 'seq' , $field->{'name'}, $trigger_no );
	222	my $trigger_name =
	223	join( '_', 'autoinc', $field->{'name'}, $trigger_no );
	224
	225	push @trigger_decs,
d529894e	226	"CREATE SEQUENCE $trigger_sequence;\n" .
	227	"CREATE OR REPLACE TRIGGER $trigger_name\n" .
	228	"BEFORE INSERT ON $table_name\n" .
	229	"FOR EACH ROW WHEN (new.".$field->{'name'}." is null)\n".
	230	"BEGIN\n" .
	231	" SELECT $trigger_sequence.nextval\n" .
	232	" INTO :new." . $field->{'name'}."\n" .
16dc9970	233	" FROM dual;\n" .
d529894e	234	" END $trigger_name;/"
16dc9970	235	;
	236	}
	237
	238	push @field_decs, $field_str;
	239	}
	240
	241	#
	242	# Index Declarations
	243	#
	244	my @index_decs = ();
49e1eb70	245	for my $index ( @{ $table->{'indices'} } ) {
16dc9970	246	my $index_name = $index->{'name'} \|\| '';
	247	my $index_type = $index->{'type'} \|\| 'normal';
	248	my @fields = @{ $index->{'fields'} } or next;
	249
	250	if ( $index_type eq 'primary_key' ) {
	251	if ( !$index_name ) {
	252	$index_name = make_identifier( $table_name, 'i_', '_pk' );
	253	}
	254	elsif ( $index_name !~ m/^i_/ ) {
	255	$index_name = make_identifier( $table_name, 'i_' );
	256	}
	257	elsif ( $index_name !~ m/_pk$/ ) {
	258	$index_name = make_identifier( $table_name, '_pk' );
	259	}
	260	else {
	261	$index_name = make_identifier( $index_name );
	262	}
	263
	264	push @field_decs, 'CONSTRAINT ' . $index_name . ' PRIMARY KEY ' .
	265	'(' . join( ', ', @fields ) . ')';
	266	}
	267
	268	elsif ( $index_type eq 'unique' ) {
	269	if ( !$index_name ) {
	270	$index_name = make_identifier( join( '_', @fields ), 'u_' );
	271	}
	272	elsif ( $index_name !~ m/^u_/ ) {
	273	$index_name = make_identifier( $index_name, 'u_' );
	274	}
	275	else {
	276	$index_name = make_identifier( $index_name );
	277	}
	278
	279	push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
	280	'(' . join( ', ', @fields ) . ')';
	281	}
	282
	283	elsif ( $index_type eq 'normal' ) {
	284	if ( !$index_name ) {
	285	$index_name =
	286	make_identifier($table_name, 'i_', '_'.$index_i++ );
	287	}
	288	elsif ( $index_name !~ m/^i_/ ) {
	289	$index_name = make_identifier( $index_name, 'i_' );
	290	}
	291	else {
	292	$index_name = make_identifier( $index_name );
	293	}
	294
	295	push @index_decs, "CREATE INDEX $index_name on $table_name (".
	296	join( ', ', @{ $index->{'fields'} } ).
	297	");"
	298	;
	299	}
	300
	301	else {
	302	warn "On table $table_name, unknown index type: $index_type\n";
	303	}
	304	}
	305
	306	my $create_statement = "CREATE TABLE $table_name (\n".
	307	join( ",\n", map { " $_" } @field_decs ).
	308	"\n);"
	309	;
310
311	$output .= join( "\n\n",
312	@comments,
313	$create_statement,
314	@trigger_decs,
315	@index_decs,
316	''
317	);
318	}
319
d529894e	320	return $output;
16dc9970	321	}
	322
	323	#
	324	# Used to make index names
	325	#
	326	sub make_identifier {
	327	my ( $identifier, @mutations ) = @_;
	328	my $length_of_mutations;
	329	for my $mutation ( @mutations ) {
	330	$length_of_mutations += length( $mutation );
	331	}
	332
	333	if (
	334	length( $identifier ) + $length_of_mutations >
d529894e	335	$max_id_length
16dc9970	336	) {
	337	$identifier = substr(
	338	$identifier,
	339	0,
d529894e	340	$max_id_length - $length_of_mutations
16dc9970	341	);
	342	}
	343
	344	for my $mutation ( @mutations ) {
	345	if ( $mutation =~ m/.+_$/ ) {
	346	$identifier = $mutation.$identifier;
	347	}
	348	elsif ( $mutation =~ m/^_.+/ ) {
	349	$identifier = $identifier.$mutation;
	350	}
	351	}
	352
	353	if ( $used_identifiers{ $identifier } ) {
	354	my $index = 1;
	355	if ( $identifier =~ m/_(\d+)$/ ) {
	356	$index = $1;
	357	$identifier = substr(
	358	$identifier,
	359	0,
	360	length( $identifier ) - ( length( $index ) + 1 )
	361	);
	362	}
	363	$index++;
	364	return make_identifier( $identifier, '_'.$index );
	365	}
	366
	367	$used_identifiers{ $identifier } = 1;
	368
	369	return $identifier;
	370	}
	371
	372	#
	373	# Checks to see if an identifier is not too long
	374	#
	375	sub check_identifier {
	376	my $identifier = shift;
	377	die "Identifier '$identifier' is too long, unrecoverable error.\n"
d529894e	378	if length( $identifier ) > $max_id_length;
16dc9970	379	return $identifier;
	380	}
	381
d529894e	382	# -------------------------------------------------------------------
	383	sub mk_name {
	384	my ($basename, $type, $scope, $critical) = @_;
	385	my $basename_orig = $basename;
	386	my $max_name = $max_id_length - (length($type) + 1);
	387	$basename = substr($basename, 0, $max_name)
	388	if length($basename) > $max_name;
	389	my $name = $type ? "${type}_$basename" : $basename;
	390
	391	if ( $basename ne $basename_orig and $critical ) {
	392	my $show_type = $type ? "+'$type'" : "";
	393	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	394	"character limit to make '$name'\n" if $DEBUG;
	395	$truncated{$basename_orig} = $name;
	396	}
	397
	398	$scope \|\|= \%global_names;
	399	return $name unless $scope->{$name}++;
	400	my $name_orig = $name;
	401	$name .= "02";
	402	substr($name, $max_id_length - 3) = "00" if length($name) > $max_id_length;
	403	++$name while $scope->{$name};
	404	warn "The name '$name_orig' has been changed to ",
	405	"'$name' to make it unique\n" if $DEBUG;
	406	return $name;
	407	}
	408
	409	# -------------------------------------------------------------------
	410	sub unreserve {
	411	my ($name, $schema_obj_name) = @_;
	412	my ($suffix) = ($name =~ s/(\W.*)$//) ? $1 : '';
	413
	414	# also trap fields that don't begin with a letter
	415	return $_[0] if !$ora_reserved{uc $name}
	416	&& $name =~ /^[a-z]/i;
	417
	418	if ( $schema_obj_name ) {
	419	++$unreserve{"$schema_obj_name.$name"};
	420	}
	421	else {
	422	++$unreserve{"$name (table name)"};
	423	}
	424
	425	my $unreserve = sprintf '%s_', $name;
	426	return $unreserve.$suffix;
	427	}
	428
16dc9970	429	1;
16dc9970	430
d529894e	431	# -------------------------------------------------------------------
16dc9970	432	# All bad art is the result of good intentions.
16dc9970	433	# Oscar Wilde
d529894e	434	# -------------------------------------------------------------------
16dc9970	435
	436	=head1 NAME
	437
	438	SQL::Translator::Producer::Oracle - Oracle SQL producer
	439
	440	=head1 SYNOPSIS
	441
077ebf34	442	use SQL::Translator::Parser::MySQL;
16dc9970	443	use SQL::Translator::Producer::Oracle;
16dc9970	444
077ebf34	445	my $original_create = ""; # get this from somewhere...
	446	my $translator = SQL::Translator->new;
	447
	448	$translator->parser("SQL::Translator::Parser::MySQL");
	449	$translator->producer("SQL::Translator::Producer::Oracle");
	450
	451	my $new_create = $translator->translate($original_create);
	452
16dc9970	453	=head1 DESCRIPTION
16dc9970	454
077ebf34	455	SQL::Translator::Producer::Oracle takes a parsed data structure,
	456	created by a SQL::Translator::Parser subclass, and turns it into a
	457	create string suitable for use with an Oracle database.
16dc9970	458
efd49776	459	=head1 BUGS
	460
	461	Problem with SQL::Translator::Producer::Oracle: it is keeping track
	462	of the last sequence number used, so as not to duplicate them, which
	463	is reasonable. However on runs past the first, it seems to be
	464	creating multiple constraint lines, that look like:
	465
	466	CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
	467	CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)
	468
	469	This is a very preliminary finding, and needs to be investigated more
	470	thoroughly, of course.
	471
d529894e	472	=head1 CREDITS
	473
	474	A hearty "thank-you" to Tim Bunce for much of the logic stolen from
	475	his "mysql2ora" script.
16dc9970	476
	477	=head1 AUTHOR
	478
d529894e	479	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
16dc9970	480
	481	=head1 SEE ALSO
	482
	483	perl(1).
	484
	485	=cut