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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.15 2003-08-04 21:04:04 kycl4rk 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.15 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

use SQL::Translator::Schema::Constants;
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
    #
    numeric             => 'number',
    'double precision'  => 'number',
    serial              => 'number',
    bigserial           => 'number',
    money               => 'number',
    character           => 'char',
    'character varying' => 'varchar2',
    bytea               => 'BLOB',
    interval            => 'number',
    boolean             => 'number',
    point               => 'number',
    line                => 'number',
    lseg                => 'number',
    box                 => 'number',
    path                => 'number',
    polygon             => 'number',
    circle              => 'number',
    cidr                => 'number',
    inet                => 'varchar2',
    macaddr             => 'varchar2',
    bit                 => 'number',
    'bit varying'       => 'number',
);

#
# 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     = shift;
    $DEBUG             = $translator->debug;
    $WARN              = $translator->show_warnings;
    my $no_comments    = $translator->no_comments;
    my $add_drop_table = $translator->add_drop_table;
    my $schema         = $translator->schema;
    my $output;

    $output .= header_comment unless ($no_comments);

    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 ( $schema->get_tables ) { 
        my $table_name    = $table->name or next;
        $table_name       = mk_name( $table_name, '', undef, 1 );
        my $table_name_ur = unreserve($table_name) or next;

        my ( @comments, @field_defs, @trigger_defs, @constraint_defs );

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

        my ( %field_name_scope, @field_comments );
        for my $field ( $table->get_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_def     = $field_name_ur;

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

            if ( $data_type eq 'enum' ) {
                $check = "CHECK ($field_name IN ($commalist))";
                $data_type = 'varchar2';
            }
            elsif ( $data_type eq 'set' ) {
                # XXX add a CHECK constraint maybe 
                # (trickier and slower, than enum :)
                $data_type = 'varchar2';
            }
            else {
                $data_type  = defined $translate{ $data_type } ?
                              $translate{ $data_type } :
                              die "Unknown datatype: $data_type\n";
            }

            $field_def .= " $data_type";
            if ( defined $size[0] && $size[0] > 0 ) {
                $field_def .= '(' . join( ', ', @size ) . ')';
            }
        
            #
            # Default value
            #
            my $default = $field->default_value;
            if ( defined $default ) {
                $field_def .= sprintf(
                    ' DEFAULT %s',
                    $default =~ m/null/i ? 'NULL' : "'$default'"
                );
            }

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

            $field_def .= " $check" if $check;

            #
            # Auto_increment
            #
            if ( $field->is_auto_increment ) {
                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_defs, 
                    "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 ( lc $field->data_type eq 'timestamp' ) {
                my $base_name = $table_name . "_". $field_name_ur;
                my $trig_name = mk_name( $base_name, 'ts' );
                push @trigger_defs, 
                    "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_defs, $field_def;

            if ( my $comment = $field->comments ) {
                push @field_comments, 
                    "COMMENT ON COLUMN $table_name.$field_name_ur is\n  '".
                    $comment."';";
            }
        }

        #
        # Table constraints
        #
        my $constraint_name_default;
        for my $c ( $table->get_constraints ) {
            my $name    = $c->name || '';
            my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
            my @rfields = map { unreserve( $_, $table_name ) } 
                $c->reference_fields;
            next unless @fields;

            if ( $c->type eq PRIMARY_KEY ) {
                $name ||= mk_name( $table_name, 'pk' );
                push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $c->type eq UNIQUE ) {
                $name ||= mk_name( $table_name, ++$constraint_name_default );
                push @constraint_defs, "CONSTRAINT $name UNIQUE " .
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $c->type eq FOREIGN_KEY ) {
                $name ||= mk_name( $table_name, ++$constraint_name_default );
                my $def = "CONSTRAINT $name FOREIGN KEY ";

                if ( @fields ) {
                    $def .= join( ', ', @fields );
                }

                $def .= ' REFERENCES ' . $c->reference_table;

                if ( @rfields ) {
                    $def .= ' (' . join( ', ', @rfields ) . ')';
                }

                if ( $c->match_type ) {
                    $def .= ' MATCH ' . 
                        ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
                }

                if ( $c->on_delete ) {
                    $def .= ' ON DELETE '.join( ' ', $c->on_delete );
                }

                if ( $c->on_update ) {
                    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
                }

                push @constraint_defs, $def;
            }
        }

        #
        # Index Declarations
        #
        my @index_defs = ();
        my $idx_name_default;
        for my $index ( $table->get_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_defs, '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_defs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }

            elsif ( $index_type eq NORMAL ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @index_defs, 
                    "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 .= 
            join( ",\n", map { "-- $_" } $table->comments ) .
            "CREATE TABLE $table_name_ur (\n" .
            join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
            "\n);"
        ;

        $output .= join( "\n\n", 
            @comments,
            $create_statement, 
            @trigger_defs, 
            @index_defs, 
            @field_comments, 
            '' 
        );
    }

    if ( $WARN ) {
        if ( %truncated ) {
            warn "Truncated " . keys( %truncated ) . " names:\n";
            warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
        }

        if ( %unreserve ) {
            warn "Encounted " . keys( %unreserve ) .
                " unsafe names in schema (reserved or invalid):\n";
            warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
        }
    }

    return $output;
}

# -------------------------------------------------------------------
sub mk_name {
    my $basename      = shift || ''; 
    my $type          = shift || ''; 
    my $scope         = shift || ''; 
    my $critical      = shift || '';
    my $basename_orig = $basename;
    my $max_name      = $type 
                        ? $max_id_length - (length($type) + 1) 
                        : $max_id_length;
    $basename         = substr( $basename, 0, $max_name ) 
                        if length( $basename ) > $max_name;
    my $name          = $type ? "${type}_$basename" : $basename;

    if ( $basename ne $basename_orig and $critical ) {
        my $show_type = $type ? "+'$type'" : "";
        warn "Truncating '$basename_orig'$show_type to $max_id_length ",
            "character limit to make '$name'\n" if $WARN;
        $truncated{ $basename_orig } = $name;
    }

    $scope ||= \%global_names;
    if ( my $prev = $scope->{ $name } ) {
        my $name_orig = $name;
        $name        .= sprintf( "%02d", ++$prev );
        substr($name, $max_id_length - 3) = "00" 
            if length( $name ) > $max_id_length;

        warn "The name '$name_orig' has been changed to ",
             "'$name' to make it unique.\n" if $WARN;

        $scope->{ $name_orig }++;
    }

    $scope->{ $name }++;
    return $name;
}

# -------------------------------------------------------------------
sub unreserve {
    my $name            = shift || '';
    my $schema_obj_name = shift || '';

    my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';

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