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

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

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