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

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

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