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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.9 2003-01-27 17:04:46 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.9 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

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;

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