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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.10 2003-04-25 11:47:25 dlc Exp $
# -------------------------------------------------------------------
# Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>,
#                    Chris Mungall <cjm@fruitfly.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 $WARN ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

use SQL::Translator::Utils qw(header_comment);

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 = map { $_, 1 } 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 $max_id_length    = 30;
my %used_identifiers = ();
my %global_names;
my %unreserve;
my %truncated;

# -------------------------------------------------------------------
sub produce {
    my ( $translator, $data ) = @_;
    $DEBUG                    = $translator->debug;
    $WARN                     = $translator->show_warnings;
    my $no_comments           = $translator->no_comments;
    my $add_drop_table        = $translator->add_drop_table;
    my $output;

    $output .= header_comment unless ($no_comments);

    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
    #
    for my $table ( 
        map  { $_->[1] }
        sort { $a->[0] <=> $b->[0] }
        map  { [ $_->{'order'}, $_ ] }
        values %{ $data }
    ) { 
        my $table_name    = $table->{'table_name'};
        $table_name       = mk_name( $table_name, '', undef, 1 );
        my $table_name_ur = unreserve($table_name);

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

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

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

            #
            # Datatype
            #
            my $check;
            my $data_type = lc $field->{'data_type'};
            my $list      = $field->{'list'} || [];
            my $commalist = join ",", @$list;

            if ( $data_type eq 'enum' ) {
                my $len = 0;
                $len = ($len < length($_)) ? length($_) : $len for (@$list);
                $check = "CHECK ($field_name IN ($commalist))";
                $field_str .= " varchar2($len)";
            }
            elsif ( $data_type eq 'set' ) {
                # XXX add a CHECK constraint maybe 
                # (trickier and slower, than enum :)
                my $len     = length $commalist;
                $field_str .= " varchar2($len) /* set $commalist */ ";
            }
            else {
                $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 ( defined $field->{'default'} ) {
                $field_str .= sprintf(
                    ' DEFAULT %s',
                    $field->{'default'} =~ m/null/i ? 'NULL' : 
                    "'".$field->{'default'}."'"
                );
            }

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

            $field_str .= " $check" if $check;

            #
            # Auto_increment
            #
            if ( $field->{'is_auto_inc'} ) {
                my $base_name    = $table_name . "_". $field_name;
                my $seq_name     = mk_name( $base_name, 'sq' );
                my $trigger_name = mk_name( $base_name, 'ai' );

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

            if ( uc $field->{'data_type'} eq 'TIMESTAMP' ) {
                my $base_name = $table_name . "_". $field_name_ur;
                my $trig_name = mk_name( $base_name, 'ts' );
                push @trigger_decs, 
                    "CREATE OR REPLACE TRIGGER $trig_name\n".
                    "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
                    "FOR EACH ROW WHEN (new.$field_name_ur} IS NULL)\n".
                    "BEGIN \n".
                    " SELECT sysdate INTO :new.$field_name_ur} FROM dual;\n".
                    "END;\n/";
            }

            push @field_decs, $field_str;
        }

        #
        # Index Declarations
        #
        my @index_decs = ();
        my $idx_name_default;
        for my $index ( @{ $table->{'indices'} } ) {
            my $index_name = $index->{'name'} || '';
            my $index_type = $index->{'type'} || 'normal';
            my @fields     = map { unreserve( $_, $table_name ) }
                             @{ $index->{'fields'} };
            next unless @fields;

            if ( $index_type eq 'primary_key' ) {
                $index_name = mk_name( $table_name, 'pk' );
                push @field_decs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $index_type eq 'unique' ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }

            elsif ( $index_type eq 'normal' ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @index_decs, 
                    "CREATE INDEX $index_name on $table_name_ur (".
                        join( ', ', @fields ).  
                    ");"; 
            }
            else {
                warn "Unknown index type ($index_type) on table $table_name.\n"
                    if $WARN;
            }
        }

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

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

    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, $type, $scope, $critical) = @_;
    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 }++;
    }

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