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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.17 2003-08-15 16:26:44 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.17 $ =~ /(\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',
    integer    => '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	# -------------------------------------------------------------------
b6ab0fe7	4	# $Id: Oracle.pm,v 1.17 2003-08-15 16:26:44 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 ];
b6ab0fe7	27	$VERSION = sprintf "%d.%02d", q$Revision: 1.17 $ =~ /(\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',
25966689	42	integer => 'number',
16dc9970	43	mediumint => 'number',
	44	smallint => 'number',
	45	tinyint => 'number',
16dc9970	46	char => 'char',
16dc9970	47	varchar => 'varchar2',
16dc9970	48	tinyblob => 'CLOB',
	49	blob => 'CLOB',
	50	mediumblob => 'CLOB',
	51	longblob => 'CLOB',
16dc9970	52	longtext => 'long',
	53	mediumtext => 'long',
	54	text => 'long',
	55	tinytext => 'long',
16dc9970	56	enum => 'varchar2',
16dc9970	57	set => 'varchar2',
16dc9970	58	date => 'date',
	59	datetime => 'date',
	60	time => 'date',
	61	timestamp => 'date',
	62	year => 'date',
d529894e	63
	64	#
	65	# PostgreSQL types
	66	#
57f77285	67	numeric => 'number',
	68	'double precision' => 'number',
	69	serial => 'number',
	70	bigserial => 'number',
	71	money => 'number',
	72	character => 'char',
	73	'character varying' => 'varchar2',
	74	bytea => 'BLOB',
	75	interval => 'number',
	76	boolean => 'number',
	77	point => 'number',
	78	line => 'number',
	79	lseg => 'number',
	80	box => 'number',
	81	path => 'number',
	82	polygon => 'number',
	83	circle => 'number',
	84	cidr => 'number',
	85	inet => 'varchar2',
	86	macaddr => 'varchar2',
	87	bit => 'number',
	88	'bit varying' => 'number',
d529894e	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 {
a1d94525	129	my $translator = shift;
	130	$DEBUG = $translator->debug;
	131	$WARN = $translator->show_warnings;
	132	my $no_comments = $translator->no_comments;
	133	my $add_drop_table = $translator->add_drop_table;
	134	my $schema = $translator->schema;
d529894e	135	my $output;
44fcd0b5	136
5ee19df8	137	$output .= header_comment unless ($no_comments);
077ebf34	138
d529894e	139	if ( $translator->parser_type =~ /mysql/i ) {
	140	$output .=
	141	"-- We assume that default NLS_DATE_FORMAT has been changed\n".
	142	"-- but we set it here anyway to be self-consistent.\n".
	143	"ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
	144	}
16dc9970	145
	146	#
	147	# Print create for each table
	148	#
57f77285	149	for my $table ( $schema->get_tables ) {
57f77285	150	my $table_name = $table->name or next;
44fcd0b5	151	$table_name = mk_name( $table_name, '', undef, 1 );
57f77285	152	my $table_name_ur = unreserve($table_name) or next;
16dc9970	153
57f77285	154	my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
16dc9970	155
44fcd0b5	156	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
16dc9970	157
f6195129	158	my ( %field_name_scope, @field_comments );
57f77285	159	for my $field ( $table->get_fields ) {
16dc9970	160	#
	161	# Field name
	162	#
44fcd0b5	163	my $field_name = mk_name(
57f77285	164	$field->name, '', \%field_name_scope, 1
44fcd0b5	165	);
44fcd0b5	166	my $field_name_ur = unreserve( $field_name, $table_name );
57f77285	167	my $field_def = $field_name_ur;
16dc9970	168
	169	#
	170	# Datatype
	171	#
44fcd0b5	172	my $check;
57f77285	173	my $data_type = lc $field->data_type;
	174	my @size = $field->size;
	175	my %extra = $field->extra;
	176	my $list = $extra{'list'} \|\| [];
44fcd0b5	177	my $commalist = join ",", @$list;
	178
	179	if ( $data_type eq 'enum' ) {
44fcd0b5	180	$check = "CHECK ($field_name IN ($commalist))";
57f77285	181	$data_type = 'varchar2';
44fcd0b5	182	}
	183	elsif ( $data_type eq 'set' ) {
	184	# XXX add a CHECK constraint maybe
	185	# (trickier and slower, than enum :)
57f77285	186	$data_type = 'varchar2';
44fcd0b5	187	}
	188	else {
	189	$data_type = defined $translate{ $data_type } ?
	190	$translate{ $data_type } :
	191	die "Unknown datatype: $data_type\n";
44fcd0b5	192	}
16dc9970	193
57f77285	194	$field_def .= " $data_type";
	195	if ( defined $size[0] && $size[0] > 0 ) {
	196	$field_def .= '(' . join( ', ', @size ) . ')';
	197	}
	198
16dc9970	199	#
	200	# Default value
	201	#
57f77285	202	my $default = $field->default_value;
	203	if ( defined $default ) {
	204	$field_def .= sprintf(
16dc9970	205	' DEFAULT %s',
57f77285	206	$default =~ m/null/i ? 'NULL' : "'$default'"
16dc9970	207	);
	208	}
	209
	210	#
	211	# Not null constraint
	212	#
57f77285	213	unless ( $field->is_nullable ) {
44fcd0b5	214	my $constraint_name = mk_name($field_name_ur, 'nn');
57f77285	215	$field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
16dc9970	216	}
16dc9970	217
57f77285	218	$field_def .= " $check" if $check;
44fcd0b5	219
16dc9970	220	#
	221	# Auto_increment
	222	#
57f77285	223	if ( $field->is_auto_increment ) {
44fcd0b5	224	my $base_name = $table_name . "_". $field_name;
	225	my $seq_name = mk_name( $base_name, 'sq' );
	226	my $trigger_name = mk_name( $base_name, 'ai' );
16dc9970	227
57f77285	228	push @trigger_defs,
44fcd0b5	229	"CREATE SEQUENCE $seq_name;\n" .
d529894e	230	"CREATE OR REPLACE TRIGGER $trigger_name\n" .
d529894e	231	"BEFORE INSERT ON $table_name\n" .
44fcd0b5	232	"FOR EACH ROW WHEN (\n" .
	233	" new.$field_name_ur IS NULL".
	234	" OR new.$field_name_ur = 0\n".
	235	")\n".
d529894e	236	"BEGIN\n" .
44fcd0b5	237	" SELECT $seq_name.nextval\n" .
57f77285	238	" INTO :new." . $field->name."\n" .
16dc9970	239	" FROM dual;\n" .
44fcd0b5	240	"END;\n/";
16dc9970	241	;
	242	}
	243
57f77285	244	if ( lc $field->data_type eq 'timestamp' ) {
44fcd0b5	245	my $base_name = $table_name . "_". $field_name_ur;
96844cae	246	my $trig_name = mk_name( $base_name, 'ts' );
57f77285	247	push @trigger_defs,
44fcd0b5	248	"CREATE OR REPLACE TRIGGER $trig_name\n".
44fcd0b5	249	"BEFORE INSERT OR UPDATE ON $table_name_ur\n".
b6ab0fe7	250	"FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
44fcd0b5	251	"BEGIN \n".
b6ab0fe7	252	" SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
44fcd0b5	253	"END;\n/";
	254	}
	255
57f77285	256	push @field_defs, $field_def;
f6195129	257
	258	if ( my $comment = $field->comments ) {
	259	push @field_comments,
	260	"COMMENT ON COLUMN $table_name.$field_name_ur is\n '".
	261	$comment."';";
	262	}
57f77285	263	}
	264
	265	#
	266	# Table constraints
	267	#
	268	my $constraint_name_default;
	269	for my $c ( $table->get_constraints ) {
	270	my $name = $c->name \|\| '';
	271	my @fields = map { unreserve( $_, $table_name ) } $c->fields;
	272	my @rfields = map { unreserve( $_, $table_name ) }
	273	$c->reference_fields;
	274	next unless @fields;
	275
	276	if ( $c->type eq PRIMARY_KEY ) {
	277	$name \|\|= mk_name( $table_name, 'pk' );
	278	push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
	279	'(' . join( ', ', @fields ) . ')';
	280	}
	281	elsif ( $c->type eq UNIQUE ) {
	282	$name \|\|= mk_name( $table_name, ++$constraint_name_default );
	283	push @constraint_defs, "CONSTRAINT $name UNIQUE " .
	284	'(' . join( ', ', @fields ) . ')';
	285	}
	286	elsif ( $c->type eq FOREIGN_KEY ) {
	287	$name \|\|= mk_name( $table_name, ++$constraint_name_default );
cd617ba8	288	my $def = "CONSTRAINT $name FOREIGN KEY ";
	289
	290	if ( @fields ) {
	291	$def .= join( ', ', @fields );
	292	}
	293
	294	$def .= ' REFERENCES ' . $c->reference_table;
57f77285	295
	296	if ( @rfields ) {
	297	$def .= ' (' . join( ', ', @rfields ) . ')';
	298	}
	299
	300	if ( $c->match_type ) {
	301	$def .= ' MATCH ' .
	302	( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
	303	}
	304
	305	if ( $c->on_delete ) {
	306	$def .= ' ON DELETE '.join( ' ', $c->on_delete );
	307	}
	308
	309	if ( $c->on_update ) {
	310	$def .= ' ON UPDATE '.join( ' ', $c->on_update );
	311	}
	312
	313	push @constraint_defs, $def;
	314	}
16dc9970	315	}
	316
	317	#
	318	# Index Declarations
	319	#
57f77285	320	my @index_defs = ();
44fcd0b5	321	my $idx_name_default;
57f77285	322	for my $index ( $table->get_indices ) {
	323	my $index_name = $index->name \|\| '';
	324	my $index_type = $index->type \|\| NORMAL;
44fcd0b5	325	my @fields = map { unreserve( $_, $table_name ) }
57f77285	326	$index->fields;
44fcd0b5	327	next unless @fields;
16dc9970	328
57f77285	329	if ( $index_type eq PRIMARY_KEY ) {
44fcd0b5	330	$index_name = mk_name( $table_name, 'pk' );
57f77285	331	push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
16dc9970	332	'(' . join( ', ', @fields ) . ')';
16dc9970	333	}
57f77285	334	elsif ( $index_type eq UNIQUE ) {
44fcd0b5	335	$index_name = mk_name(
	336	$table_name, $index_name \|\| ++$idx_name_default
	337	);
57f77285	338	push @field_defs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
16dc9970	339	'(' . join( ', ', @fields ) . ')';
	340	}
	341
57f77285	342	elsif ( $index_type eq NORMAL ) {
44fcd0b5	343	$index_name = mk_name(
	344	$table_name, $index_name \|\| ++$idx_name_default
	345	);
57f77285	346	push @index_defs,
da8e499e	347	"CREATE INDEX $index_name on $table_name_ur (".
	348	join( ', ', @fields ).
	349	");";
16dc9970	350	}
16dc9970	351	else {
96844cae	352	warn "Unknown index type ($index_type) on table $table_name.\n"
96844cae	353	if $WARN;
16dc9970	354	}
	355	}
	356
96844cae	357	my $create_statement;
96844cae	358	$create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
57f77285	359	$create_statement .=
	360	join( ",\n", map { "-- $_" } $table->comments ) .
	361	"CREATE TABLE $table_name_ur (\n" .
	362	join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
44fcd0b5	363	"\n);"
16dc9970	364	;
	365
	366	$output .= join( "\n\n",
	367	@comments,
	368	$create_statement,
57f77285	369	@trigger_defs,
57f77285	370	@index_defs,
f6195129	371	@field_comments,
16dc9970	372	''
	373	);
	374	}
	375
96844cae	376	if ( $WARN ) {
	377	if ( %truncated ) {
	378	warn "Truncated " . keys( %truncated ) . " names:\n";
	379	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	380	}
	381
	382	if ( %unreserve ) {
	383	warn "Encounted " . keys( %unreserve ) .
	384	" unsafe names in schema (reserved or invalid):\n";
	385	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	386	}
	387	}
	388
d529894e	389	return $output;
16dc9970	390	}
16dc9970	391
d529894e	392	# -------------------------------------------------------------------
d529894e	393	sub mk_name {
57f77285	394	my $basename = shift \|\| '';
	395	my $type = shift \|\| '';
	396	my $scope = shift \|\| '';
	397	my $critical = shift \|\| '';
d529894e	398	my $basename_orig = $basename;
f5087552	399	my $max_name = $type
	400	? $max_id_length - (length($type) + 1)
	401	: $max_id_length;
96844cae	402	$basename = substr( $basename, 0, $max_name )
96844cae	403	if length( $basename ) > $max_name;
d529894e	404	my $name = $type ? "${type}_$basename" : $basename;
	405
	406	if ( $basename ne $basename_orig and $critical ) {
	407	my $show_type = $type ? "+'$type'" : "";
	408	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
96844cae	409	"character limit to make '$name'\n" if $WARN;
96844cae	410	$truncated{ $basename_orig } = $name;
d529894e	411	}
	412
	413	$scope \|\|= \%global_names;
96844cae	414	if ( my $prev = $scope->{ $name } ) {
	415	my $name_orig = $name;
	416	$name .= sprintf( "%02d", ++$prev );
	417	substr($name, $max_id_length - 3) = "00"
	418	if length( $name ) > $max_id_length;
	419
	420	warn "The name '$name_orig' has been changed to ",
	421	"'$name' to make it unique.\n" if $WARN;
	422
	423	$scope->{ $name_orig }++;
	424	}
	425
	426	$scope->{ $name }++;
d529894e	427	return $name;
	428	}
	429
	430	# -------------------------------------------------------------------
	431	sub unreserve {
57f77285	432	my $name = shift \|\| '';
	433	my $schema_obj_name = shift \|\| '';
	434
96844cae	435	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
d529894e	436
d529894e	437	# also trap fields that don't begin with a letter
57f77285	438	return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
d529894e	439
	440	if ( $schema_obj_name ) {
	441	++$unreserve{"$schema_obj_name.$name"};
	442	}
	443	else {
	444	++$unreserve{"$name (table name)"};
	445	}
	446
	447	my $unreserve = sprintf '%s_', $name;
	448	return $unreserve.$suffix;
	449	}
	450
16dc9970	451	1;
16dc9970	452
d529894e	453	# -------------------------------------------------------------------
16dc9970	454	# All bad art is the result of good intentions.
16dc9970	455	# Oscar Wilde
d529894e	456	# -------------------------------------------------------------------
16dc9970	457
	458	=head1 NAME
	459
	460	SQL::Translator::Producer::Oracle - Oracle SQL producer
	461
	462	=head1 SYNOPSIS
	463
077ebf34	464	use SQL::Translator::Parser::MySQL;
16dc9970	465	use SQL::Translator::Producer::Oracle;
16dc9970	466
077ebf34	467	my $original_create = ""; # get this from somewhere...
	468	my $translator = SQL::Translator->new;
	469
	470	$translator->parser("SQL::Translator::Parser::MySQL");
	471	$translator->producer("SQL::Translator::Producer::Oracle");
	472
	473	my $new_create = $translator->translate($original_create);
	474
16dc9970	475	=head1 DESCRIPTION
16dc9970	476
077ebf34	477	SQL::Translator::Producer::Oracle takes a parsed data structure,
	478	created by a SQL::Translator::Parser subclass, and turns it into a
	479	create string suitable for use with an Oracle database.
16dc9970	480
d529894e	481	=head1 CREDITS
	482
	483	A hearty "thank-you" to Tim Bunce for much of the logic stolen from
	484	his "mysql2ora" script.
16dc9970	485
	486	=head1 AUTHOR
	487
d529894e	488	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
16dc9970	489
	490	=head1 SEE ALSO
	491
	492	perl(1).
	493
	494	=cut