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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.34 2005-08-10 16:33:39 duality72 Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
# 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
# -------------------------------------------------------------------

=head1 NAME

SQL::Translator::Producer::Oracle - Oracle SQL producer

=head1 SYNOPSIS

  use SQL::Translator;

  my $t = SQL::Translator->new( parser => '...', producer => 'Oracle' );
  print $translator->translate( $file );

=head1 DESCRIPTION

Creates an SQL DDL suitable for Oracle.

=cut

use strict;
use vars qw[ $VERSION $DEBUG $WARN ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.34 $ =~ /(\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 || 0;
    my $no_comments    = $translator->no_comments;
    my $add_drop_table = $translator->add_drop_table;
    my $schema         = $translator->schema;
    my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs);

    $create .= header_comment unless ($no_comments);

    if ( $translator->parser_type =~ /mysql/i ) {
        $create .= 
            "-- We assume that default NLS_DATE_FORMAT has been changed\n".
            "-- but we set it here anyway to be self-consistent.\n"
            unless $no_comments;

        $create .= 
        "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
    }

    for my $table ( $schema->get_tables ) { 
        my ( $table_def, $fk_def, $trigger_def, $index_def) = create_table(
            $table,
            {
                add_drop_table => $add_drop_table,
                show_warnings  => $WARN,
                no_comments    => $no_comments,
            }
        );
        push @table_defs, @$table_def;
        push @fk_defs, @$fk_def;
        push @trigger_defs, @$trigger_def;
        push @index_defs, @$index_def;
    }

    my (@view_defs);
    foreach my $view ( $schema->get_views ) {
        push @view_defs, create_view($view);
    }

    return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs) : $create . join ("\n\n", @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, '');
}

sub create_table {
    my ($table, $options) = @_;
    my $table_name = $table->name;
    
    my $item = '';
    my $drop;
    my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);

    push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
    push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};

    my $table_name_ur = unreserve($table_name) or next;

        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;
            $field->name( $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 } :
                              $data_type;
                $data_type ||= 'varchar2';
            }
            
            #
            # 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;
            }

            if ( $data_type eq 'clob' && $field->is_unique ) {
                $data_type = 'varchar2';
                $size[0]   = 4000;
                warn "CLOB cannot be a unique 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 eq 'now()' 
                    )
                ) {
                    $default = 'SYSDATE';
                }
                else {
                    $default = $default =~ m/null/i ? 'NULL' : "'$default'"
                } 

                $field_def .= " DEFAULT $default",
            }

            #
            # Not null constraint
            #
            unless ( $field->is_nullable ) {
                $field_def .= ' NOT NULL';
            }

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

            #
            # Auto_increment
            #
            if ( $field->is_auto_increment ) {
                my $base_name    = $table_name_ur . "_". $field_name;
                my $seq_name     = mk_name( $base_name, 'sq' );
                my $trigger_name = mk_name( $base_name, 'ai' );

            push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
            push @create, "CREATE SEQUENCE $seq_name;";
                push @trigger_defs, 
                    "CREATE OR REPLACE TRIGGER $trigger_name\n" .
                    "BEFORE INSERT ON $table_name_ur\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_ur . "_". $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 ) {
                $comment =~ s/'/''/g;
                push @field_comments, 
                    "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
                $comment . "';" unless $options->{no_comments};
            }
        }

        #
        # 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, ($name ? "CONSTRAINT $name " : '') .
                	'PRIMARY KEY (' . join( ', ', @fields ) . ')';
            }
            elsif ( $c->type eq UNIQUE ) {
            	# Don't create UNIQUE constraints identical to the primary key
            	if ( my $pk = $table->primary_key ) {
					my $u_fields = join(":", @fields);
					my $pk_fields = join(":", $pk->fields);
					next if $u_fields eq $pk_fields;
            	}

                $name ||= mk_name( $name || $table_name, 'u' );

                for my $f ( $c->fields ) {
                    my $field_def = $table->get_field( $f ) or next;
                    my $dtype     = $translate{ $field_def->data_type } or next;
                    if ( $WARN && $dtype =~ /clob/i ) {
                        warn "Oracle will not allow UNIQUE constraints on " .
                             "CLOB field '" . $field_def->table->name . '.' .
                             $field_def->name . ".'\n"
                    }
                }

                push @constraint_defs, "CONSTRAINT $name UNIQUE " .
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $c->type eq CHECK_C ) {
                $name ||= mk_name( $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 );
                }

            # disabled by plu 2007-12-29 - doesn't exist for oracle
            #if ( $c->on_update ) {
            #    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
            #}

            push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $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;

            my @index_options;
            for my $opt ( $index->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 @index_options, $key;
                    }
                    else {
                        push @index_options, "$key    $value";
                    }
                }
            }
            my $index_options = @index_options
              ? "\n".join("\n", @index_options) : '';

            if ( $index_type eq PRIMARY_KEY ) {
                $index_name = $index_name ? mk_name( $index_name ) 
                    : mk_name( $table_name, 'pk' );
                push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $index_type eq NORMAL ) {
                $index_name = $index_name ? mk_name( $index_name ) 
                    : mk_name( $table_name, $index_name || 'i' );
                push @index_defs, 
                    "CREATE INDEX $index_name on $table_name_ur (".
                        join( ', ', @fields ).  
                    ")$index_options;";
            }
            elsif ( $index_type eq UNIQUE ) {
                $index_name = $index_name ? mk_name( $index_name ) 
                    : mk_name( $table_name, $index_name || 'i' );
                push @index_defs, 
                    "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
                        join( ', ', @fields ).  
                    ")$index_options;"; 
            }
            else {
                warn "Unknown index type ($index_type) on table $table_name.\n"
                    if $WARN;
            }
        }

        if ( my @table_comments = $table->comments ) {
            for my $comment ( @table_comments ) {
                next unless $comment;
                $comment =~ s/'/''/g;
                push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
                $comment . "';" unless $options->{no_comments}
                ;
            }
        }

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

    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 \@create, \@fk_defs, \@trigger_defs, \@index_defs;
}

sub create_view {
    my ($view) = @_;

    my $out = sprintf("CREATE VIEW %s AS\n%s;",
                      $view->name,
                      $view->sql);

    return $out;
}

# -------------------------------------------------------------------
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;
        substr($name, $max_id_length - 2) = ""
            if length( $name ) >= $max_id_length - 1;
        $name        .= sprintf( "%02d", $prev++ );

        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
# -------------------------------------------------------------------

=pod

=head1 CREDITS

Mad props 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

SQL::Translator, DDL::Oracle, mysql2ora.

=cut
Commit	Line	Data
16dc9970	1	package SQL::Translator::Producer::Oracle;
16dc9970	2
077ebf34	3	# -------------------------------------------------------------------
54e61f1f	4	# $Id: Oracle.pm,v 1.34 2005-08-10 16:33:39 duality72 Exp $
077ebf34	5	# -------------------------------------------------------------------
977651a5	6	# Copyright (C) 2002-4 SQLFairy Authors
16dc9970	7	#
077ebf34	8	# This program is free software; you can redistribute it and/or
	9	# modify it under the terms of the GNU General Public License as
	10	# published by the Free Software Foundation; version 2.
	11	#
	12	# This program is distributed in the hope that it will be useful, but
	13	# WITHOUT ANY WARRANTY; without even the implied warranty of
	14	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	15	# General Public License for more details.
	16	#
	17	# You should have received a copy of the GNU General Public License
	18	# along with this program; if not, write to the Free Software
	19	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	20	# 02111-1307 USA
	21	# -------------------------------------------------------------------
	22
ba096dc4	23	=head1 NAME
	24
	25	SQL::Translator::Producer::Oracle - Oracle SQL producer
	26
	27	=head1 SYNOPSIS
	28
	29	use SQL::Translator;
	30
	31	my $t = SQL::Translator->new( parser => '...', producer => 'Oracle' );
	32	print $translator->translate( $file );
	33
	34	=head1 DESCRIPTION
	35
	36	Creates an SQL DDL suitable for Oracle.
	37
	38	=cut
	39
16dc9970	40	use strict;
96844cae	41	use vars qw[ $VERSION $DEBUG $WARN ];
54e61f1f	42	$VERSION = sprintf "%d.%02d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/;
d529894e	43	$DEBUG = 0 unless defined $DEBUG;
16dc9970	44
57f77285	45	use SQL::Translator::Schema::Constants;
5ee19df8	46	use SQL::Translator::Utils qw(header_comment);
5ee19df8	47
16dc9970	48	my %translate = (
d529894e	49	#
	50	# MySQL types
	51	#
16dc9970	52	bigint => 'number',
	53	double => 'number',
	54	decimal => 'number',
	55	float => 'number',
	56	int => 'number',
25966689	57	integer => 'number',
16dc9970	58	mediumint => 'number',
	59	smallint => 'number',
	60	tinyint => 'number',
16dc9970	61	char => 'char',
16dc9970	62	varchar => 'varchar2',
1f58ba76	63	tinyblob => 'blob',
	64	blob => 'blob',
	65	mediumblob => 'blob',
	66	longblob => 'blob',
9fc9bfb1	67	tinytext => 'varchar2',
9fc9bfb1	68	text => 'clob',
1f58ba76	69	longtext => 'clob',
1f58ba76	70	mediumtext => 'clob',
16dc9970	71	enum => 'varchar2',
16dc9970	72	set => 'varchar2',
16dc9970	73	date => 'date',
	74	datetime => 'date',
	75	time => 'date',
	76	timestamp => 'date',
	77	year => 'date',
d529894e	78
	79	#
	80	# PostgreSQL types
	81	#
57f77285	82	numeric => 'number',
	83	'double precision' => 'number',
	84	serial => 'number',
	85	bigserial => 'number',
	86	money => 'number',
	87	character => 'char',
	88	'character varying' => 'varchar2',
	89	bytea => 'BLOB',
	90	interval => 'number',
	91	boolean => 'number',
	92	point => 'number',
	93	line => 'number',
	94	lseg => 'number',
	95	box => 'number',
	96	path => 'number',
	97	polygon => 'number',
	98	circle => 'number',
	99	cidr => 'number',
	100	inet => 'varchar2',
	101	macaddr => 'varchar2',
	102	bit => 'number',
	103	'bit varying' => 'number',
ab8802d7	104
	105	#
	106	# Oracle types
	107	#
	108	number => 'number',
	109	varchar2 => 'varchar2',
	110	long => 'clob',
d529894e	111	);
	112
	113	#
	114	# Oracle reserved words from:
	115	# http://technet.oracle.com/docs/products/oracle8i/doc_library/\
	116	# 817_doc/server.817/a85397/ap_keywd.htm
	117	#
96844cae	118	my %ora_reserved = map { $_, 1 } qw(
d529894e	119	ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
	120	BETWEEN BY
	121	CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
	122	DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
	123	ELSE EXCLUSIVE EXISTS
	124	FILE FLOAT FOR FROM
	125	GRANT GROUP
	126	HAVING
	127	IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
	128	INTEGER INTERSECT INTO IS
	129	LEVEL LIKE LOCK LONG
	130	MAXEXTENTS MINUS MLSLABEL MODE MODIFY
	131	NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
	132	OF OFFLINE ON ONLINE OPTION OR ORDER
	133	PCTFREE PRIOR PRIVILEGES PUBLIC
	134	RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
	135	SELECT SESSION SET SHARE SIZE SMALLINT START
	136	SUCCESSFUL SYNONYM SYSDATE
	137	TABLE THEN TO TRIGGER
	138	UID UNION UNIQUE UPDATE USER
	139	VALIDATE VALUES VARCHAR VARCHAR2 VIEW
	140	WHENEVER WHERE WITH
16dc9970	141	);
16dc9970	142
96844cae	143	my $max_id_length = 30;
96844cae	144	my %used_identifiers = ();
d529894e	145	my %global_names;
	146	my %unreserve;
	147	my %truncated;
16dc9970	148
96844cae	149	# -------------------------------------------------------------------
077ebf34	150	sub produce {
a1d94525	151	my $translator = shift;
a1d94525	152	$DEBUG = $translator->debug;
e56dabb7	153	$WARN = $translator->show_warnings \|\| 0;
a1d94525	154	my $no_comments = $translator->no_comments;
	155	my $add_drop_table = $translator->add_drop_table;
	156	my $schema = $translator->schema;
041e659f	157	my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs);
44fcd0b5	158
e56dabb7	159	$create .= header_comment unless ($no_comments);
077ebf34	160
d529894e	161	if ( $translator->parser_type =~ /mysql/i ) {
e56dabb7	162	$create .=
ba3cb849	163	"-- We assume that default NLS_DATE_FORMAT has been changed\n".
	164	"-- but we set it here anyway to be self-consistent.\n"
	165	unless $no_comments;
	166
e56dabb7	167	$create .=
d529894e	168	"ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
d529894e	169	}
16dc9970	170
57f77285	171	for my $table ( $schema->get_tables ) {
041e659f	172	my ( $table_def, $fk_def, $trigger_def, $index_def) = create_table(
e56dabb7	173	$table,
	174	{
	175	add_drop_table => $add_drop_table,
	176	show_warnings => $WARN,
	177	no_comments => $no_comments,
	178	}
	179	);
	180	push @table_defs, @$table_def;
	181	push @fk_defs, @$fk_def;
	182	push @trigger_defs, @$trigger_def;
041e659f	183	push @index_defs, @$index_def;
e56dabb7	184	}
	185
	186	my (@view_defs);
	187	foreach my $view ( $schema->get_views ) {
	188	push @view_defs, create_view($view);
	189	}
	190
041e659f	191	return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs) : $create . join ("\n\n", @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, '');
e56dabb7	192	}
	193
	194	sub create_table {
	195	my ($table, $options) = @_;
	196	my $table_name = $table->name;
	197
	198	my $item = '';
	199	my $drop;
	200	my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
16dc9970	201
e56dabb7	202	push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
e56dabb7	203	push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};
16dc9970	204
e56dabb7	205	my $table_name_ur = unreserve($table_name) or next;
16dc9970	206
f6195129	207	my ( %field_name_scope, @field_comments );
57f77285	208	for my $field ( $table->get_fields ) {
16dc9970	209	#
	210	# Field name
	211	#
44fcd0b5	212	my $field_name = mk_name(
57f77285	213	$field->name, '', \%field_name_scope, 1
44fcd0b5	214	);
44fcd0b5	215	my $field_name_ur = unreserve( $field_name, $table_name );
57f77285	216	my $field_def = $field_name_ur;
ef373e64	217	$field->name( $field_name_ur );
16dc9970	218
	219	#
	220	# Datatype
	221	#
44fcd0b5	222	my $check;
57f77285	223	my $data_type = lc $field->data_type;
	224	my @size = $field->size;
	225	my %extra = $field->extra;
	226	my $list = $extra{'list'} \|\| [];
77d74ea6	227	# \todo deal with embedded quotes
e6f063bd	228	my $commalist = join( ', ', map { qq['$_'] } @$list );
44fcd0b5	229
44fcd0b5	230	if ( $data_type eq 'enum' ) {
1f58ba76	231	$check = "CHECK ($field_name_ur IN ($commalist))";
57f77285	232	$data_type = 'varchar2';
44fcd0b5	233	}
	234	elsif ( $data_type eq 'set' ) {
	235	# XXX add a CHECK constraint maybe
	236	# (trickier and slower, than enum :)
57f77285	237	$data_type = 'varchar2';
44fcd0b5	238	}
	239	else {
	240	$data_type = defined $translate{ $data_type } ?
	241	$translate{ $data_type } :
0a91d33e	242	$data_type;
0a91d33e	243	$data_type \|\|= 'varchar2';
44fcd0b5	244	}
1f58ba76	245
e6f063bd	246	#
	247	# Fixes ORA-02329: column of datatype LOB cannot be
	248	# unique or a primary key
	249	#
1f58ba76	250	if ( $data_type eq 'clob' && $field->is_primary_key ) {
1f58ba76	251	$data_type = 'varchar2';
9fc9bfb1	252	$size[0] = 4000;
e6f063bd	253	warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
e6f063bd	254	if $WARN;
1f58ba76	255	}
1f58ba76	256
ef373e64	257	if ( $data_type eq 'clob' && $field->is_unique ) {
	258	$data_type = 'varchar2';
	259	$size[0] = 4000;
	260	warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
	261	if $WARN;
	262	}
	263
9fc9bfb1	264	#
1f58ba76	265	# Fixes ORA-00907: missing right parenthesis
9fc9bfb1	266	#
9fc9bfb1	267	if ( $data_type =~ /(date\|clob)/i ) {
1f58ba76	268	undef @size;
1f58ba76	269	}
16dc9970	270
57f77285	271	$field_def .= " $data_type";
	272	if ( defined $size[0] && $size[0] > 0 ) {
	273	$field_def .= '(' . join( ', ', @size ) . ')';
	274	}
1f58ba76	275
16dc9970	276	#
	277	# Default value
	278	#
57f77285	279	my $default = $field->default_value;
57f77285	280	if ( defined $default ) {
1c899510	281	#
	282	# Wherein we try to catch a string being used as
	283	# a default value for a numerical field. If "true/false,"
	284	# then sub "1/0," otherwise just test the truthity of the
	285	# argument and use that (naive?).
	286	#
ab8802d7	287	if (
ab8802d7	288	$data_type =~ /^number$/i &&
54e61f1f	289	$default !~ /^-?\d+$/ &&
ab8802d7	290	$default !~ m/null/i
ab8802d7	291	) {
1c899510	292	if ( $default =~ /^true$/i ) {
	293	$default = "'1'";
	294	}
	295	elsif ( $default =~ /^false$/i ) {
	296	$default = "'0'";
	297	}
	298	else {
	299	$default = $default ? "'1'" : "'0'";
	300	}
	301	}
	302	elsif (
b0c196d4	303	$data_type =~ /date/ && (
	304	$default eq 'current_timestamp'
	305	\|\|
	306	$default eq 'now()'
	307	)
1c899510	308	) {
	309	$default = 'SYSDATE';
	310	}
	311	else {
	312	$default = $default =~ m/null/i ? 'NULL' : "'$default'"
	313	}
	314
	315	$field_def .= " DEFAULT $default",
16dc9970	316	}
	317
	318	#
	319	# Not null constraint
	320	#
57f77285	321	unless ( $field->is_nullable ) {
02c2af3b	322	$field_def .= ' NOT NULL';
16dc9970	323	}
16dc9970	324
57f77285	325	$field_def .= " $check" if $check;
44fcd0b5	326
16dc9970	327	#
	328	# Auto_increment
	329	#
57f77285	330	if ( $field->is_auto_increment ) {
ef373e64	331	my $base_name = $table_name_ur . "_". $field_name;
44fcd0b5	332	my $seq_name = mk_name( $base_name, 'sq' );
44fcd0b5	333	my $trigger_name = mk_name( $base_name, 'ai' );
16dc9970	334
e56dabb7	335	push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
e56dabb7	336	push @create, "CREATE SEQUENCE $seq_name;";
57f77285	337	push @trigger_defs,
d529894e	338	"CREATE OR REPLACE TRIGGER $trigger_name\n" .
b0c196d4	339	"BEFORE INSERT ON $table_name_ur\n" .
44fcd0b5	340	"FOR EACH ROW WHEN (\n" .
	341	" new.$field_name_ur IS NULL".
	342	" OR new.$field_name_ur = 0\n".
	343	")\n".
d529894e	344	"BEGIN\n" .
44fcd0b5	345	" SELECT $seq_name.nextval\n" .
57f77285	346	" INTO :new." . $field->name."\n" .
16dc9970	347	" FROM dual;\n" .
44fcd0b5	348	"END;\n/";
16dc9970	349	;
	350	}
	351
57f77285	352	if ( lc $field->data_type eq 'timestamp' ) {
ef373e64	353	my $base_name = $table_name_ur . "_". $field_name_ur;
96844cae	354	my $trig_name = mk_name( $base_name, 'ts' );
57f77285	355	push @trigger_defs,
44fcd0b5	356	"CREATE OR REPLACE TRIGGER $trig_name\n".
44fcd0b5	357	"BEFORE INSERT OR UPDATE ON $table_name_ur\n".
b6ab0fe7	358	"FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
44fcd0b5	359	"BEGIN \n".
b6ab0fe7	360	" SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
44fcd0b5	361	"END;\n/";
	362	}
	363
57f77285	364	push @field_defs, $field_def;
f6195129	365
f6195129	366	if ( my $comment = $field->comments ) {
b89d5635	367	$comment =~ s/'/''/g;
f6195129	368	push @field_comments,
b89d5635	369	"COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
e56dabb7	370	$comment . "';" unless $options->{no_comments};
f6195129	371	}
57f77285	372	}
	373
	374	#
02c2af3b	375	# Table options
	376	#
	377	my @table_options;
	378	for my $opt ( $table->options ) {
	379	if ( ref $opt eq 'HASH' ) {
	380	my ( $key, $value ) = each %$opt;
	381	if ( ref $value eq 'ARRAY' ) {
	382	push @table_options, "$key\n(\n". join ("\n",
	383	map { " $_->[0]\t$_->[1]" }
	384	map { [ each %$_ ] }
	385	@$value
	386	)."\n)";
	387	}
	388	elsif ( !defined $value ) {
	389	push @table_options, $key;
	390	}
	391	else {
	392	push @table_options, "$key $value";
	393	}
	394	}
	395	}
	396
	397	#
57f77285	398	# Table constraints
57f77285	399	#
57f77285	400	for my $c ( $table->get_constraints ) {
	401	my $name = $c->name \|\| '';
	402	my @fields = map { unreserve( $_, $table_name ) } $c->fields;
	403	my @rfields = map { unreserve( $_, $table_name ) }
	404	$c->reference_fields;
4dfb0380	405	next if !@fields && $c->type ne CHECK_C;
57f77285	406
57f77285	407	if ( $c->type eq PRIMARY_KEY ) {
54e61f1f	408	#$name \|\|= mk_name( $table_name, 'pk' );
	409	push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
	410	'PRIMARY KEY (' . join( ', ', @fields ) . ')';
57f77285	411	}
57f77285	412	elsif ( $c->type eq UNIQUE ) {
54e61f1f	413	# Don't create UNIQUE constraints identical to the primary key
	414	if ( my $pk = $table->primary_key ) {
	415	my $u_fields = join(":", @fields);
	416	my $pk_fields = join(":", $pk->fields);
	417	next if $u_fields eq $pk_fields;
	418	}
	419
	420	$name \|\|= mk_name( $name \|\| $table_name, 'u' );
6d4ce9b6	421
b0c196d4	422	for my $f ( $c->fields ) {
	423	my $field_def = $table->get_field( $f ) or next;
	424	my $dtype = $translate{ $field_def->data_type } or next;
	425	if ( $WARN && $dtype =~ /clob/i ) {
	426	warn "Oracle will not allow UNIQUE constraints on " .
	427	"CLOB field '" . $field_def->table->name . '.' .
	428	$field_def->name . ".'\n"
	429	}
	430	}
6d4ce9b6	431
57f77285	432	push @constraint_defs, "CONSTRAINT $name UNIQUE " .
	433	'(' . join( ', ', @fields ) . ')';
	434	}
4dfb0380	435	elsif ( $c->type eq CHECK_C ) {
54e61f1f	436	$name \|\|= mk_name( $name \|\| $table_name, 'ck' );
4dfb0380	437	my $expression = $c->expression \|\| '';
	438	push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
	439	}
57f77285	440	elsif ( $c->type eq FOREIGN_KEY ) {
e56dabb7	441	$name = mk_name( join('_', $table_name, $c->fields). '_fk' );
cd617ba8	442	my $def = "CONSTRAINT $name FOREIGN KEY ";
	443
	444	if ( @fields ) {
1c899510	445	$def .= '(' . join( ', ', @fields ) . ')';
cd617ba8	446	}
cd617ba8	447
1c899510	448	my $ref_table = unreserve($c->reference_table);
	449
	450	$def .= " REFERENCES $ref_table";
57f77285	451
	452	if ( @rfields ) {
	453	$def .= ' (' . join( ', ', @rfields ) . ')';
	454	}
	455
	456	if ( $c->match_type ) {
	457	$def .= ' MATCH ' .
	458	( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
	459	}
	460
	461	if ( $c->on_delete ) {
	462	$def .= ' ON DELETE '.join( ' ', $c->on_delete );
	463	}
	464
e56dabb7	465	# disabled by plu 2007-12-29 - doesn't exist for oracle
	466	#if ( $c->on_update ) {
	467	# $def .= ' ON UPDATE '.join( ' ', $c->on_update );
	468	#}
57f77285	469
e56dabb7	470	push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
57f77285	471	}
16dc9970	472	}
	473
	474	#
	475	# Index Declarations
	476	#
57f77285	477	my @index_defs = ();
57f77285	478	for my $index ( $table->get_indices ) {
	479	my $index_name = $index->name \|\| '';
	480	my $index_type = $index->type \|\| NORMAL;
44fcd0b5	481	my @fields = map { unreserve( $_, $table_name ) }
57f77285	482	$index->fields;
44fcd0b5	483	next unless @fields;
16dc9970	484
bdd8e79a	485	my @index_options;
	486	for my $opt ( $index->options ) {
	487	if ( ref $opt eq 'HASH' ) {
	488	my ( $key, $value ) = each %$opt;
	489	if ( ref $value eq 'ARRAY' ) {
	490	push @table_options, "$key\n(\n". join ("\n",
	491	map { " $_->[0]\t$_->[1]" }
	492	map { [ each %$_ ] }
	493	@$value
	494	)."\n)";
	495	}
	496	elsif ( !defined $value ) {
	497	push @index_options, $key;
	498	}
	499	else {
	500	push @index_options, "$key $value";
	501	}
	502	}
	503	}
	504	my $index_options = @index_options
	505	? "\n".join("\n", @index_options) : '';
	506
57f77285	507	if ( $index_type eq PRIMARY_KEY ) {
6d4ce9b6	508	$index_name = $index_name ? mk_name( $index_name )
6d4ce9b6	509	: mk_name( $table_name, 'pk' );
57f77285	510	push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
16dc9970	511	'(' . join( ', ', @fields ) . ')';
16dc9970	512	}
57f77285	513	elsif ( $index_type eq NORMAL ) {
6d4ce9b6	514	$index_name = $index_name ? mk_name( $index_name )
6d4ce9b6	515	: mk_name( $table_name, $index_name \|\| 'i' );
57f77285	516	push @index_defs,
da8e499e	517	"CREATE INDEX $index_name on $table_name_ur (".
da8e499e	518	join( ', ', @fields ).
bdd8e79a	519	")$index_options;";
16dc9970	520	}
041e659f	521	elsif ( $index_type eq UNIQUE ) {
	522	$index_name = $index_name ? mk_name( $index_name )
	523	: mk_name( $table_name, $index_name \|\| 'i' );
	524	push @index_defs,
	525	"CREATE UNIQUE INDEX $index_name on $table_name_ur (".
	526	join( ', ', @fields ).
bdd8e79a	527	")$index_options;";
041e659f	528	}
16dc9970	529	else {
96844cae	530	warn "Unknown index type ($index_type) on table $table_name.\n"
96844cae	531	if $WARN;
16dc9970	532	}
	533	}
	534
9fc9bfb1	535	if ( my @table_comments = $table->comments ) {
	536	for my $comment ( @table_comments ) {
	537	next unless $comment;
b89d5635	538	$comment =~ s/'/''/g;
b89d5635	539	push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
e56dabb7	540	$comment . "';" unless $options->{no_comments}
9fc9bfb1	541	;
	542	}
	543	}
	544
02c2af3b	545	my $table_options = @table_options
02c2af3b	546	? "\n".join("\n", @table_options) : '';
e56dabb7	547	push @create, "CREATE TABLE $table_name_ur (\n" .
57f77285	548	join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
e56dabb7	549	"\n)$table_options;";
16dc9970	550
96844cae	551	if ( $WARN ) {
	552	if ( %truncated ) {
	553	warn "Truncated " . keys( %truncated ) . " names:\n";
	554	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	555	}
	556
	557	if ( %unreserve ) {
	558	warn "Encounted " . keys( %unreserve ) .
	559	" unsafe names in schema (reserved or invalid):\n";
	560	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	561	}
	562	}
	563
041e659f	564	return \@create, \@fk_defs, \@trigger_defs, \@index_defs;
e56dabb7	565	}
	566
	567	sub create_view {
	568	my ($view) = @_;
	569
	570	my $out = sprintf("CREATE VIEW %s AS\n%s;",
	571	$view->name,
	572	$view->sql);
	573
	574	return $out;
16dc9970	575	}
16dc9970	576
d529894e	577	# -------------------------------------------------------------------
d529894e	578	sub mk_name {
57f77285	579	my $basename = shift \|\| '';
57f77285	580	my $type = shift \|\| '';
1c899510	581	$type = '' if $type =~ /^\d/;
57f77285	582	my $scope = shift \|\| '';
57f77285	583	my $critical = shift \|\| '';
d529894e	584	my $basename_orig = $basename;
f5087552	585	my $max_name = $type
	586	? $max_id_length - (length($type) + 1)
	587	: $max_id_length;
96844cae	588	$basename = substr( $basename, 0, $max_name )
96844cae	589	if length( $basename ) > $max_name;
d529894e	590	my $name = $type ? "${type}_$basename" : $basename;
	591
	592	if ( $basename ne $basename_orig and $critical ) {
	593	my $show_type = $type ? "+'$type'" : "";
	594	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
96844cae	595	"character limit to make '$name'\n" if $WARN;
96844cae	596	$truncated{ $basename_orig } = $name;
d529894e	597	}
	598
	599	$scope \|\|= \%global_names;
96844cae	600	if ( my $prev = $scope->{ $name } ) {
96844cae	601	my $name_orig = $name;
b89d5635	602	substr($name, $max_id_length - 2) = ""
	603	if length( $name ) >= $max_id_length - 1;
	604	$name .= sprintf( "%02d", $prev++ );
96844cae	605
	606	warn "The name '$name_orig' has been changed to ",
	607	"'$name' to make it unique.\n" if $WARN;
	608
	609	$scope->{ $name_orig }++;
	610	}
	611
	612	$scope->{ $name }++;
d529894e	613	return $name;
	614	}
	615
	616	# -------------------------------------------------------------------
	617	sub unreserve {
57f77285	618	my $name = shift \|\| '';
	619	my $schema_obj_name = shift \|\| '';
	620
96844cae	621	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
d529894e	622
d529894e	623	# also trap fields that don't begin with a letter
57f77285	624	return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
d529894e	625
	626	if ( $schema_obj_name ) {
	627	++$unreserve{"$schema_obj_name.$name"};
	628	}
	629	else {
	630	++$unreserve{"$name (table name)"};
	631	}
	632
	633	my $unreserve = sprintf '%s_', $name;
	634	return $unreserve.$suffix;
	635	}
	636
16dc9970	637	1;
16dc9970	638
d529894e	639	# -------------------------------------------------------------------
16dc9970	640	# All bad art is the result of good intentions.
16dc9970	641	# Oscar Wilde
d529894e	642	# -------------------------------------------------------------------
16dc9970	643
ba096dc4	644	=pod
16dc9970	645
d529894e	646	=head1 CREDITS
d529894e	647
ba096dc4	648	Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
ba096dc4	649	script.
16dc9970	650
	651	=head1 AUTHOR
	652
ba096dc4	653	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
16dc9970	654
	655	=head1 SEE ALSO
	656
ba096dc4	657	SQL::Translator, DDL::Oracle, mysql2ora.
16dc9970	658
16dc9970	659	=cut