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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.29 2004-01-25 18:12:54 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
# -------------------------------------------------------------------

=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.29 $ =~ /(\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"
            unless $no_comments;

        $output .= 
        "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 } :
                              $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;
            }

            #
            # 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 . "_". $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_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 . "_". $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."';" unless $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, "CONSTRAINT $name PRIMARY KEY ".
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $c->type eq UNIQUE ) {
                $name ||= mk_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( $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."';" unless $no_comments
                ;
            }
        }

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

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