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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.24 2003-08-27 02:28:21 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.24 $ =~ /(\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   => 'blob',
    blob       => 'blob',
    mediumblob => 'blob',
    longblob   => 'blob',
    tinytext   => 'varchar2',
    text       => 'clob',
    longtext   => 'clob',
    mediumtext => 'clob',
    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 types
    #
    number              => 'number',
    varchar2            => 'varchar2',
    long                => 'clob',
);

#
# 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'} || [];
            # \todo deal with embedded quotes
            my $commalist = join( ', ', map { qq['$_'] } @$list );

            if ( $data_type eq 'enum' ) {
                $check = "CHECK ($field_name_ur 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";
            }
            
            #
            # Fixes ORA-02329: column of datatype LOB cannot be 
            # unique or a primary key
            #
            if ( $data_type eq 'clob' && $field->is_primary_key ) {
                $data_type = 'varchar2';
                $size[0]   = 4000;
                warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
                    if $WARN;
            }

            #
            # Fixes ORA-00907: missing right parenthesis
            #
            if ( $data_type =~ /(date|clob)/i ) {
                undef @size;
            }

            $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 ) {
                #
                # Wherein we try to catch a string being used as 
                # a default value for a numerical field.  If "true/false,"
                # then sub "1/0," otherwise just test the truthity of the
                # argument and use that (naive?).
                #
                if ( 
                    $data_type =~ /^number$/i && 
                    $default   !~ /^\d+$/     &&
                    $default   !~ m/null/i
                ) {
                    if ( $default =~ /^true$/i ) {
                        $default = "'1'";
                    }
                    elsif ( $default =~ /^false$/i ) {
                        $default = "'0'";
                    }
                    else {
                        $default = $default ? "'1'" : "'0'";
                    }
                }
                elsif ( 
                    $data_type =~ /date/ && $default eq 'current_timestamp' 
                ) {
                    $default = 'SYSDATE';
                }
                else {
                    $default = $default =~ m/null/i ? 'NULL' : "'$default'"
                } 

                $field_def .= " DEFAULT $default",
            }

            #
            # Not null constraint
            #
            unless ( $field->is_nullable ) {
                my $constraint_name = mk_name( 
                    join('_', $table_name_ur, $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
        #
        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 if !@fields && $c->type ne CHECK_C;

            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, 'u' );
                push @constraint_defs, "CONSTRAINT $name UNIQUE " .
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $c->type eq CHECK_C ) {
                $name ||= mk_name( $table_name, 'ck' );
                my $expression = $c->expression || '';
                push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
            }
            elsif ( $c->type eq FOREIGN_KEY ) {
                $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
                my $def = "CONSTRAINT $name FOREIGN KEY ";

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

                my $ref_table = unreserve($c->reference_table);

                $def .= " REFERENCES $ref_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 = ();
        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 NORMAL ) {
                $index_name ||= mk_name( $table_name, $index_name || 'i' );
                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;

        if ( my @table_comments = $table->comments ) {
            for my $comment ( @table_comments ) {
                next unless $comment;
                push @field_comments, "COMMENT ON TABLE $table_name is\n  '".
                    $comment."';"
                ;
            }
        }

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