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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.25 2003-10-04 01:21:10 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.25 $ =~ /(\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 .= ' 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 options
        #
        my @table_options;
        for my $opt ( $table->options ) {
            if ( ref $opt eq 'HASH' ) {
                my ( $key, $value ) = each %$opt;
                if ( ref $value eq 'ARRAY' ) {
                    push @table_options, "$key\n(\n".  join ("\n",
                        map { "  $_->[0]\t$_->[1]" } 
                        map { [ each %$_ ] }
                        @$value
                    )."\n)";
                }
                elsif ( !defined $value ) {
                    push @table_options, $key;
                }
                else {
                    push @table_options, "$key    $value";
                }
            }
        }

        #
        # 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."';"
                ;
            }
        }

        my $table_options = @table_options 
            ? "\n".join("\n", @table_options) : '';
        $create_statement .= "CREATE TABLE $table_name_ur (\n" .
            join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
            "\n)$table_options;"
        ;

        $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	# -------------------------------------------------------------------
02c2af3b	4	# $Id: Oracle.pm,v 1.25 2003-10-04 01:21:10 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 ];
02c2af3b	27	$VERSION = sprintf "%d.%02d", q$Revision: 1.25 $ =~ /(\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 ) {
02c2af3b	267	# my $constraint_name = mk_name(
	268	# join('_', $table_name_ur, $field_name_ur ), 'nn'
	269	# );
	270	# $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
	271	$field_def .= ' NOT NULL';
16dc9970	272	}
16dc9970	273
57f77285	274	$field_def .= " $check" if $check;
44fcd0b5	275
16dc9970	276	#
	277	# Auto_increment
	278	#
57f77285	279	if ( $field->is_auto_increment ) {
44fcd0b5	280	my $base_name = $table_name . "_". $field_name;
	281	my $seq_name = mk_name( $base_name, 'sq' );
	282	my $trigger_name = mk_name( $base_name, 'ai' );
16dc9970	283
57f77285	284	push @trigger_defs,
44fcd0b5	285	"CREATE SEQUENCE $seq_name;\n" .
d529894e	286	"CREATE OR REPLACE TRIGGER $trigger_name\n" .
d529894e	287	"BEFORE INSERT ON $table_name\n" .
44fcd0b5	288	"FOR EACH ROW WHEN (\n" .
	289	" new.$field_name_ur IS NULL".
	290	" OR new.$field_name_ur = 0\n".
	291	")\n".
d529894e	292	"BEGIN\n" .
44fcd0b5	293	" SELECT $seq_name.nextval\n" .
57f77285	294	" INTO :new." . $field->name."\n" .
16dc9970	295	" FROM dual;\n" .
44fcd0b5	296	"END;\n/";
16dc9970	297	;
	298	}
	299
57f77285	300	if ( lc $field->data_type eq 'timestamp' ) {
44fcd0b5	301	my $base_name = $table_name . "_". $field_name_ur;
96844cae	302	my $trig_name = mk_name( $base_name, 'ts' );
57f77285	303	push @trigger_defs,
44fcd0b5	304	"CREATE OR REPLACE TRIGGER $trig_name\n".
44fcd0b5	305	"BEFORE INSERT OR UPDATE ON $table_name_ur\n".
b6ab0fe7	306	"FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
44fcd0b5	307	"BEGIN \n".
b6ab0fe7	308	" SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
44fcd0b5	309	"END;\n/";
	310	}
	311
57f77285	312	push @field_defs, $field_def;
f6195129	313
	314	if ( my $comment = $field->comments ) {
	315	push @field_comments,
	316	"COMMENT ON COLUMN $table_name.$field_name_ur is\n '".
	317	$comment."';";
	318	}
57f77285	319	}
	320
	321	#
02c2af3b	322	# Table options
	323	#
	324	my @table_options;
	325	for my $opt ( $table->options ) {
	326	if ( ref $opt eq 'HASH' ) {
	327	my ( $key, $value ) = each %$opt;
	328	if ( ref $value eq 'ARRAY' ) {
	329	push @table_options, "$key\n(\n". join ("\n",
	330	map { " $_->[0]\t$_->[1]" }
	331	map { [ each %$_ ] }
	332	@$value
	333	)."\n)";
	334	}
	335	elsif ( !defined $value ) {
	336	push @table_options, $key;
	337	}
	338	else {
	339	push @table_options, "$key $value";
	340	}
	341	}
	342	}
	343
	344	#
57f77285	345	# Table constraints
57f77285	346	#
57f77285	347	for my $c ( $table->get_constraints ) {
	348	my $name = $c->name \|\| '';
	349	my @fields = map { unreserve( $_, $table_name ) } $c->fields;
	350	my @rfields = map { unreserve( $_, $table_name ) }
	351	$c->reference_fields;
4dfb0380	352	next if !@fields && $c->type ne CHECK_C;
57f77285	353
	354	if ( $c->type eq PRIMARY_KEY ) {
	355	$name \|\|= mk_name( $table_name, 'pk' );
	356	push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
	357	'(' . join( ', ', @fields ) . ')';
	358	}
	359	elsif ( $c->type eq UNIQUE ) {
1c899510	360	$name \|\|= mk_name( $table_name, 'u' );
57f77285	361	push @constraint_defs, "CONSTRAINT $name UNIQUE " .
	362	'(' . join( ', ', @fields ) . ')';
	363	}
4dfb0380	364	elsif ( $c->type eq CHECK_C ) {
	365	$name \|\|= mk_name( $table_name, 'ck' );
	366	my $expression = $c->expression \|\| '';
	367	push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
	368	}
57f77285	369	elsif ( $c->type eq FOREIGN_KEY ) {
4dfb0380	370	$name \|\|= mk_name( join('_', $table_name, $c->fields), 'fk' );
cd617ba8	371	my $def = "CONSTRAINT $name FOREIGN KEY ";
	372
	373	if ( @fields ) {
1c899510	374	$def .= '(' . join( ', ', @fields ) . ')';
cd617ba8	375	}
cd617ba8	376
1c899510	377	my $ref_table = unreserve($c->reference_table);
	378
	379	$def .= " REFERENCES $ref_table";
57f77285	380
	381	if ( @rfields ) {
	382	$def .= ' (' . join( ', ', @rfields ) . ')';
	383	}
	384
	385	if ( $c->match_type ) {
	386	$def .= ' MATCH ' .
	387	( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
	388	}
	389
	390	if ( $c->on_delete ) {
	391	$def .= ' ON DELETE '.join( ' ', $c->on_delete );
	392	}
	393
	394	if ( $c->on_update ) {
	395	$def .= ' ON UPDATE '.join( ' ', $c->on_update );
	396	}
	397
	398	push @constraint_defs, $def;
	399	}
16dc9970	400	}
	401
	402	#
	403	# Index Declarations
	404	#
57f77285	405	my @index_defs = ();
57f77285	406	for my $index ( $table->get_indices ) {
	407	my $index_name = $index->name \|\| '';
	408	my $index_type = $index->type \|\| NORMAL;
44fcd0b5	409	my @fields = map { unreserve( $_, $table_name ) }
57f77285	410	$index->fields;
44fcd0b5	411	next unless @fields;
16dc9970	412
57f77285	413	if ( $index_type eq PRIMARY_KEY ) {
ab8802d7	414	$index_name \|\|= mk_name( $table_name, 'pk' );
57f77285	415	push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
16dc9970	416	'(' . join( ', ', @fields ) . ')';
16dc9970	417	}
57f77285	418	elsif ( $index_type eq NORMAL ) {
ab8802d7	419	$index_name \|\|= mk_name( $table_name, $index_name \|\| 'i' );
57f77285	420	push @index_defs,
da8e499e	421	"CREATE INDEX $index_name on $table_name_ur (".
	422	join( ', ', @fields ).
	423	");";
16dc9970	424	}
16dc9970	425	else {
96844cae	426	warn "Unknown index type ($index_type) on table $table_name.\n"
96844cae	427	if $WARN;
16dc9970	428	}
	429	}
	430
96844cae	431	my $create_statement;
96844cae	432	$create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
9fc9bfb1	433
	434	if ( my @table_comments = $table->comments ) {
	435	for my $comment ( @table_comments ) {
	436	next unless $comment;
	437	push @field_comments, "COMMENT ON TABLE $table_name is\n '".
	438	$comment."';"
	439	;
	440	}
	441	}
	442
02c2af3b	443	my $table_options = @table_options
02c2af3b	444	? "\n".join("\n", @table_options) : '';
9fc9bfb1	445	$create_statement .= "CREATE TABLE $table_name_ur (\n" .
57f77285	446	join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
02c2af3b	447	"\n)$table_options;"
16dc9970	448	;
	449
	450	$output .= join( "\n\n",
	451	@comments,
	452	$create_statement,
57f77285	453	@trigger_defs,
57f77285	454	@index_defs,
f6195129	455	@field_comments,
16dc9970	456	''
	457	);
	458	}
	459
96844cae	460	if ( $WARN ) {
	461	if ( %truncated ) {
	462	warn "Truncated " . keys( %truncated ) . " names:\n";
	463	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	464	}
	465
	466	if ( %unreserve ) {
	467	warn "Encounted " . keys( %unreserve ) .
	468	" unsafe names in schema (reserved or invalid):\n";
	469	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	470	}
	471	}
	472
d529894e	473	return $output;
16dc9970	474	}
16dc9970	475
d529894e	476	# -------------------------------------------------------------------
d529894e	477	sub mk_name {
57f77285	478	my $basename = shift \|\| '';
57f77285	479	my $type = shift \|\| '';
1c899510	480	$type = '' if $type =~ /^\d/;
57f77285	481	my $scope = shift \|\| '';
57f77285	482	my $critical = shift \|\| '';
d529894e	483	my $basename_orig = $basename;
f5087552	484	my $max_name = $type
	485	? $max_id_length - (length($type) + 1)
	486	: $max_id_length;
96844cae	487	$basename = substr( $basename, 0, $max_name )
96844cae	488	if length( $basename ) > $max_name;
d529894e	489	my $name = $type ? "${type}_$basename" : $basename;
	490
	491	if ( $basename ne $basename_orig and $critical ) {
	492	my $show_type = $type ? "+'$type'" : "";
	493	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
96844cae	494	"character limit to make '$name'\n" if $WARN;
96844cae	495	$truncated{ $basename_orig } = $name;
d529894e	496	}
	497
	498	$scope \|\|= \%global_names;
96844cae	499	if ( my $prev = $scope->{ $name } ) {
	500	my $name_orig = $name;
	501	$name .= sprintf( "%02d", ++$prev );
	502	substr($name, $max_id_length - 3) = "00"
	503	if length( $name ) > $max_id_length;
	504
	505	warn "The name '$name_orig' has been changed to ",
	506	"'$name' to make it unique.\n" if $WARN;
	507
	508	$scope->{ $name_orig }++;
	509	}
	510
	511	$scope->{ $name }++;
d529894e	512	return $name;
	513	}
	514
	515	# -------------------------------------------------------------------
	516	sub unreserve {
57f77285	517	my $name = shift \|\| '';
	518	my $schema_obj_name = shift \|\| '';
	519
96844cae	520	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
d529894e	521
d529894e	522	# also trap fields that don't begin with a letter
57f77285	523	return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
d529894e	524
	525	if ( $schema_obj_name ) {
	526	++$unreserve{"$schema_obj_name.$name"};
	527	}
	528	else {
	529	++$unreserve{"$name (table name)"};
	530	}
	531
	532	my $unreserve = sprintf '%s_', $name;
	533	return $unreserve.$suffix;
	534	}
	535
16dc9970	536	1;
16dc9970	537
d529894e	538	# -------------------------------------------------------------------
16dc9970	539	# All bad art is the result of good intentions.
16dc9970	540	# Oscar Wilde
d529894e	541	# -------------------------------------------------------------------
16dc9970	542
	543	=head1 NAME
	544
	545	SQL::Translator::Producer::Oracle - Oracle SQL producer
	546
	547	=head1 SYNOPSIS
	548
077ebf34	549	use SQL::Translator::Parser::MySQL;
16dc9970	550	use SQL::Translator::Producer::Oracle;
16dc9970	551
077ebf34	552	my $original_create = ""; # get this from somewhere...
	553	my $translator = SQL::Translator->new;
	554
	555	$translator->parser("SQL::Translator::Parser::MySQL");
	556	$translator->producer("SQL::Translator::Producer::Oracle");
	557
	558	my $new_create = $translator->translate($original_create);
	559
16dc9970	560	=head1 DESCRIPTION
16dc9970	561
077ebf34	562	SQL::Translator::Producer::Oracle takes a parsed data structure,
	563	created by a SQL::Translator::Parser subclass, and turns it into a
	564	create string suitable for use with an Oracle database.
16dc9970	565
d529894e	566	=head1 CREDITS
	567
	568	A hearty "thank-you" to Tim Bunce for much of the logic stolen from
	569	his "mysql2ora" script.
16dc9970	570
	571	=head1 AUTHOR
	572
d529894e	573	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
16dc9970	574
	575	=head1 SEE ALSO
	576
	577	perl(1).
	578
	579	=cut