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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.26 2003-10-15 19:00:35 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.26 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

use SQL::Translator::Schema::Constants;
use SQL::Translator::Utils qw(header_comment);

my %translate  = (
    #
    # MySQL types
    #
    bigint     => 'number',
    double     => 'number',
    decimal    => 'number',
    float      => 'number',
    int        => 'number',
    integer    => 'number',
    mediumint  => 'number',
    smallint   => 'number',
    tinyint    => 'number',
    char       => 'char',
    varchar    => 'varchar2',
    tinyblob   => 'blob',
    blob       => 'blob',
    mediumblob => 'blob',
    longblob   => 'blob',
    tinytext   => 'varchar2',
    text       => 'clob',
    longtext   => 'clob',
    mediumtext => 'clob',
    enum       => 'varchar2',
    set        => 'varchar2',
    date       => 'date',
    datetime   => 'date',
    time       => 'date',
    timestamp  => 'date',
    year       => 'date',

    #
    # PostgreSQL types
    #
    numeric             => 'number',
    'double precision'  => 'number',
    serial              => 'number',
    bigserial           => 'number',
    money               => 'number',
    character           => 'char',
    'character varying' => 'varchar2',
    bytea               => 'BLOB',
    interval            => 'number',
    boolean             => 'number',
    point               => 'number',
    line                => 'number',
    lseg                => 'number',
    box                 => 'number',
    path                => 'number',
    polygon             => 'number',
    circle              => 'number',
    cidr                => 'number',
    inet                => 'varchar2',
    macaddr             => 'varchar2',
    bit                 => 'number',
    'bit varying'       => 'number',

    #
    # Oracle types
    #
    number              => 'number',
    varchar2            => 'varchar2',
    long                => 'clob',
);

#
# Oracle reserved words from:
# http://technet.oracle.com/docs/products/oracle8i/doc_library/\
# 817_doc/server.817/a85397/ap_keywd.htm
#
my %ora_reserved = map { $_, 1 } qw(
    ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT 
    BETWEEN BY
    CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
    DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
    ELSE EXCLUSIVE EXISTS 
    FILE FLOAT FOR FROM
    GRANT GROUP 
    HAVING
    IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
    INTEGER INTERSECT INTO IS
    LEVEL LIKE LOCK LONG 
    MAXEXTENTS MINUS MLSLABEL MODE MODIFY 
    NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER 
    OF OFFLINE ON ONLINE OPTION OR ORDER
    PCTFREE PRIOR PRIVILEGES PUBLIC
    RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
    SELECT SESSION SET SHARE SIZE SMALLINT START 
    SUCCESSFUL SYNONYM SYSDATE 
    TABLE THEN TO TRIGGER 
    UID UNION UNIQUE UPDATE USER
    VALIDATE VALUES VARCHAR VARCHAR2 VIEW
    WHENEVER WHERE WITH
);

my $max_id_length    = 30;
my %used_identifiers = ();
my %global_names;
my %unreserve;
my %truncated;

# -------------------------------------------------------------------
sub produce {
    my $translator     = shift;
    $DEBUG             = $translator->debug;
    $WARN              = $translator->show_warnings;
    my $no_comments    = $translator->no_comments;
    my $add_drop_table = $translator->add_drop_table;
    my $schema         = $translator->schema;
    my $output;

    $output .= header_comment unless ($no_comments);

    if ( $translator->parser_type =~ /mysql/i ) {
        $output .= 
        "-- We assume that default NLS_DATE_FORMAT has been changed\n".
        "-- but we set it here anyway to be self-consistent.\n".
        "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
    }

    #
    # Print create for each table
    #
    for my $table ( $schema->get_tables ) { 
        my $table_name    = $table->name or next;
        $table_name       = mk_name( $table_name, '', undef, 1 );
        my $table_name_ur = unreserve($table_name) or next;

        my ( @comments, @field_defs, @trigger_defs, @constraint_defs );

        push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;

        my ( %field_name_scope, @field_comments );
        for my $field ( $table->get_fields ) {
            #
            # Field name
            #
            my $field_name    = mk_name(
                $field->name, '', \%field_name_scope, 1 
            );
            my $field_name_ur = unreserve( $field_name, $table_name );
            my $field_def     = $field_name_ur;

            #
            # Datatype
            #
            my $check;
            my $data_type = lc $field->data_type;
            my @size      = $field->size;
            my %extra     = $field->extra;
            my $list      = $extra{'list'} || [];
            # \todo deal with embedded quotes
            my $commalist = join( ', ', map { qq['$_'] } @$list );

            if ( $data_type eq 'enum' ) {
                $check = "CHECK ($field_name_ur IN ($commalist))";
                $data_type = 'varchar2';
            }
            elsif ( $data_type eq 'set' ) {
                # XXX add a CHECK constraint maybe 
                # (trickier and slower, than enum :)
                $data_type = 'varchar2';
            }
            else {
                $data_type  = defined $translate{ $data_type } ?
                              $translate{ $data_type } :
                              die "Unknown datatype: $data_type\n";
            }
            
            #
            # Fixes ORA-02329: column of datatype LOB cannot be 
            # unique or a primary key
            #
            if ( $data_type eq 'clob' && $field->is_primary_key ) {
                $data_type = 'varchar2';
                $size[0]   = 4000;
                warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
                    if $WARN;
            }

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

            $field_def .= " $data_type";
            if ( defined $size[0] && $size[0] > 0 ) {
                $field_def .= '(' . join( ', ', @size ) . ')';
            }

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

                $field_def .= " DEFAULT $default",
            }

            #
            # Not null constraint
            #
            unless ( $field->is_nullable ) {
#                my $constraint_name = mk_name( 
#                    join('_', $table_name_ur, $field_name_ur ), 'nn' 
#                );
#                $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
                $field_def .= ' NOT NULL';
            }

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

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

                push @trigger_defs, 
                    "CREATE SEQUENCE $seq_name;\n" .
                    "CREATE OR REPLACE TRIGGER $trigger_name\n" .
                    "BEFORE INSERT ON $table_name\n" .
                    "FOR EACH ROW WHEN (\n" .
                        " new.$field_name_ur IS NULL".
                        " OR new.$field_name_ur = 0\n".
                    ")\n".
                    "BEGIN\n" .
                        " SELECT $seq_name.nextval\n" .
                        " INTO :new." . $field->name."\n" .
                        " FROM dual;\n" .
                    "END;\n/";
                ;
            }

            if ( lc $field->data_type eq 'timestamp' ) {
                my $base_name = $table_name . "_". $field_name_ur;
                my $trig_name = mk_name( $base_name, 'ts' );
                push @trigger_defs, 
                    "CREATE OR REPLACE TRIGGER $trig_name\n".
                    "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
                    "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
                    "BEGIN \n".
                    " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
                    "END;\n/";
            }

            push @field_defs, $field_def;

            if ( my $comment = $field->comments ) {
                push @field_comments, 
                    "COMMENT ON COLUMN $table_name.$field_name_ur is\n  '".
                    $comment."';";
            }
        }

        #
        # Table options
        #
        my @table_options;
        for my $opt ( $table->options ) {
            if ( ref $opt eq 'HASH' ) {
                my ( $key, $value ) = each %$opt;
                if ( ref $value eq 'ARRAY' ) {
                    push @table_options, "$key\n(\n".  join ("\n",
                        map { "  $_->[0]\t$_->[1]" } 
                        map { [ each %$_ ] }
                        @$value
                    )."\n)";
                }
                elsif ( !defined $value ) {
                    push @table_options, $key;
                }
                else {
                    push @table_options, "$key    $value";
                }
            }
        }

        #
        # Table constraints
        #
        for my $c ( $table->get_constraints ) {
            my $name    = $c->name || '';
            my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
            my @rfields = map { unreserve( $_, $table_name ) } 
                $c->reference_fields;
            next if !@fields && $c->type ne CHECK_C;

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

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

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

                $def .= " REFERENCES $ref_table";

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

                if ( $c->match_type ) {
                    $def .= ' MATCH ' . 
                        ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
                }

                if ( $c->on_delete ) {
                    $def .= ' ON DELETE '.join( ' ', $c->on_delete );
                }

                if ( $c->on_update ) {
                    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
                }

                push @constraint_defs, $def;
            }
        }

        #
        # Index Declarations
        #
        my @index_defs = ();
        for my $index ( $table->get_indices ) {
            my $index_name = $index->name || '';
            my $index_type = $index->type || NORMAL;
            my @fields     = map { unreserve( $_, $table_name ) }
                             $index->fields;
            next unless @fields;

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

        my $create_statement;
        $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;

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

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

        $output .= join( "\n\n", 
            @comments,
            $create_statement, 
            @trigger_defs, 
            @index_defs, 
            @field_comments, 
            '' 
        );
    }

    if ( $WARN ) {
        if ( %truncated ) {
            warn "Truncated " . keys( %truncated ) . " names:\n";
            warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
        }

        if ( %unreserve ) {
            warn "Encounted " . keys( %unreserve ) .
                " unsafe names in schema (reserved or invalid):\n";
            warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
        }
    }

    return $output;
}

# -------------------------------------------------------------------
sub mk_name {
    my $basename      = shift || ''; 
    my $type          = shift || ''; 
       $type          = '' if $type =~ /^\d/;
    my $scope         = shift || ''; 
    my $critical      = shift || '';
    my $basename_orig = $basename;
    my $max_name      = $type 
                        ? $max_id_length - (length($type) + 1) 
                        : $max_id_length;
    $basename         = substr( $basename, 0, $max_name ) 
                        if length( $basename ) > $max_name;
    my $name          = $type ? "${type}_$basename" : $basename;

    if ( $basename ne $basename_orig and $critical ) {
        my $show_type = $type ? "+'$type'" : "";
        warn "Truncating '$basename_orig'$show_type to $max_id_length ",
            "character limit to make '$name'\n" if $WARN;
        $truncated{ $basename_orig } = $name;
    }

    $scope ||= \%global_names;
    if ( my $prev = $scope->{ $name } ) {
        my $name_orig = $name;
        $name        .= sprintf( "%02d", ++$prev );
        substr($name, $max_id_length - 3) = "00" 
            if length( $name ) > $max_id_length;

        warn "The name '$name_orig' has been changed to ",
             "'$name' to make it unique.\n" if $WARN;

        $scope->{ $name_orig }++;
    }

    $scope->{ $name }++;
    return $name;
}

# -------------------------------------------------------------------
sub unreserve {
    my $name            = shift || '';
    my $schema_obj_name = shift || '';

    my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';

    # also trap fields that don't begin with a letter
    return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i; 

    if ( $schema_obj_name ) {
        ++$unreserve{"$schema_obj_name.$name"};
    }
    else {
        ++$unreserve{"$name (table name)"};
    }

    my $unreserve = sprintf '%s_', $name;
    return $unreserve.$suffix;
}

1;

# -------------------------------------------------------------------
# All bad art is the result of good intentions.
# Oscar Wilde
# -------------------------------------------------------------------

=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	# -------------------------------------------------------------------
ba096dc4	4	# $Id: Oracle.pm,v 1.26 2003-10-15 19:00:35 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 ];
ba096dc4	44	$VERSION = sprintf "%d.%02d", q$Revision: 1.26 $ =~ /(\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 ) {
	164	$output .=
	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	"ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
	168	}
16dc9970	169
	170	#
	171	# Print create for each table
	172	#
57f77285	173	for my $table ( $schema->get_tables ) {
57f77285	174	my $table_name = $table->name or next;
44fcd0b5	175	$table_name = mk_name( $table_name, '', undef, 1 );
57f77285	176	my $table_name_ur = unreserve($table_name) or next;
16dc9970	177
57f77285	178	my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
16dc9970	179
44fcd0b5	180	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
16dc9970	181
f6195129	182	my ( %field_name_scope, @field_comments );
57f77285	183	for my $field ( $table->get_fields ) {
16dc9970	184	#
	185	# Field name
	186	#
44fcd0b5	187	my $field_name = mk_name(
57f77285	188	$field->name, '', \%field_name_scope, 1
44fcd0b5	189	);
44fcd0b5	190	my $field_name_ur = unreserve( $field_name, $table_name );
57f77285	191	my $field_def = $field_name_ur;
16dc9970	192
	193	#
	194	# Datatype
	195	#
44fcd0b5	196	my $check;
57f77285	197	my $data_type = lc $field->data_type;
	198	my @size = $field->size;
	199	my %extra = $field->extra;
	200	my $list = $extra{'list'} \|\| [];
77d74ea6	201	# \todo deal with embedded quotes
e6f063bd	202	my $commalist = join( ', ', map { qq['$_'] } @$list );
44fcd0b5	203
44fcd0b5	204	if ( $data_type eq 'enum' ) {
1f58ba76	205	$check = "CHECK ($field_name_ur IN ($commalist))";
57f77285	206	$data_type = 'varchar2';
44fcd0b5	207	}
	208	elsif ( $data_type eq 'set' ) {
	209	# XXX add a CHECK constraint maybe
	210	# (trickier and slower, than enum :)
57f77285	211	$data_type = 'varchar2';
44fcd0b5	212	}
	213	else {
	214	$data_type = defined $translate{ $data_type } ?
	215	$translate{ $data_type } :
	216	die "Unknown datatype: $data_type\n";
44fcd0b5	217	}
1f58ba76	218
e6f063bd	219	#
	220	# Fixes ORA-02329: column of datatype LOB cannot be
	221	# unique or a primary key
	222	#
1f58ba76	223	if ( $data_type eq 'clob' && $field->is_primary_key ) {
1f58ba76	224	$data_type = 'varchar2';
9fc9bfb1	225	$size[0] = 4000;
e6f063bd	226	warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
e6f063bd	227	if $WARN;
1f58ba76	228	}
1f58ba76	229
9fc9bfb1	230	#
1f58ba76	231	# Fixes ORA-00907: missing right parenthesis
9fc9bfb1	232	#
9fc9bfb1	233	if ( $data_type =~ /(date\|clob)/i ) {
1f58ba76	234	undef @size;
1f58ba76	235	}
16dc9970	236
57f77285	237	$field_def .= " $data_type";
	238	if ( defined $size[0] && $size[0] > 0 ) {
	239	$field_def .= '(' . join( ', ', @size ) . ')';
	240	}
1f58ba76	241
16dc9970	242	#
	243	# Default value
	244	#
57f77285	245	my $default = $field->default_value;
57f77285	246	if ( defined $default ) {
1c899510	247	#
	248	# Wherein we try to catch a string being used as
	249	# a default value for a numerical field. If "true/false,"
	250	# then sub "1/0," otherwise just test the truthity of the
	251	# argument and use that (naive?).
	252	#
ab8802d7	253	if (
	254	$data_type =~ /^number$/i &&
	255	$default !~ /^\d+$/ &&
	256	$default !~ m/null/i
	257	) {
1c899510	258	if ( $default =~ /^true$/i ) {
	259	$default = "'1'";
	260	}
	261	elsif ( $default =~ /^false$/i ) {
	262	$default = "'0'";
	263	}
	264	else {
	265	$default = $default ? "'1'" : "'0'";
	266	}
	267	}
	268	elsif (
	269	$data_type =~ /date/ && $default eq 'current_timestamp'
	270	) {
	271	$default = 'SYSDATE';
	272	}
	273	else {
	274	$default = $default =~ m/null/i ? 'NULL' : "'$default'"
	275	}
	276
	277	$field_def .= " DEFAULT $default",
16dc9970	278	}
	279
	280	#
	281	# Not null constraint
	282	#
57f77285	283	unless ( $field->is_nullable ) {
02c2af3b	284	# my $constraint_name = mk_name(
	285	# join('_', $table_name_ur, $field_name_ur ), 'nn'
	286	# );
	287	# $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
	288	$field_def .= ' NOT NULL';
16dc9970	289	}
16dc9970	290
57f77285	291	$field_def .= " $check" if $check;
44fcd0b5	292
16dc9970	293	#
	294	# Auto_increment
	295	#
57f77285	296	if ( $field->is_auto_increment ) {
44fcd0b5	297	my $base_name = $table_name . "_". $field_name;
	298	my $seq_name = mk_name( $base_name, 'sq' );
	299	my $trigger_name = mk_name( $base_name, 'ai' );
16dc9970	300
57f77285	301	push @trigger_defs,
44fcd0b5	302	"CREATE SEQUENCE $seq_name;\n" .
d529894e	303	"CREATE OR REPLACE TRIGGER $trigger_name\n" .
d529894e	304	"BEFORE INSERT ON $table_name\n" .
44fcd0b5	305	"FOR EACH ROW WHEN (\n" .
	306	" new.$field_name_ur IS NULL".
	307	" OR new.$field_name_ur = 0\n".
	308	")\n".
d529894e	309	"BEGIN\n" .
44fcd0b5	310	" SELECT $seq_name.nextval\n" .
57f77285	311	" INTO :new." . $field->name."\n" .
16dc9970	312	" FROM dual;\n" .
44fcd0b5	313	"END;\n/";
16dc9970	314	;
	315	}
	316
57f77285	317	if ( lc $field->data_type eq 'timestamp' ) {
44fcd0b5	318	my $base_name = $table_name . "_". $field_name_ur;
96844cae	319	my $trig_name = mk_name( $base_name, 'ts' );
57f77285	320	push @trigger_defs,
44fcd0b5	321	"CREATE OR REPLACE TRIGGER $trig_name\n".
44fcd0b5	322	"BEFORE INSERT OR UPDATE ON $table_name_ur\n".
b6ab0fe7	323	"FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
44fcd0b5	324	"BEGIN \n".
b6ab0fe7	325	" SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
44fcd0b5	326	"END;\n/";
	327	}
	328
57f77285	329	push @field_defs, $field_def;
f6195129	330
	331	if ( my $comment = $field->comments ) {
	332	push @field_comments,
	333	"COMMENT ON COLUMN $table_name.$field_name_ur is\n '".
	334	$comment."';";
	335	}
57f77285	336	}
	337
	338	#
02c2af3b	339	# Table options
	340	#
	341	my @table_options;
	342	for my $opt ( $table->options ) {
	343	if ( ref $opt eq 'HASH' ) {
	344	my ( $key, $value ) = each %$opt;
	345	if ( ref $value eq 'ARRAY' ) {
	346	push @table_options, "$key\n(\n". join ("\n",
	347	map { " $_->[0]\t$_->[1]" }
	348	map { [ each %$_ ] }
	349	@$value
	350	)."\n)";
	351	}
	352	elsif ( !defined $value ) {
	353	push @table_options, $key;
	354	}
	355	else {
	356	push @table_options, "$key $value";
	357	}
	358	}
	359	}
	360
	361	#
57f77285	362	# Table constraints
57f77285	363	#
57f77285	364	for my $c ( $table->get_constraints ) {
	365	my $name = $c->name \|\| '';
	366	my @fields = map { unreserve( $_, $table_name ) } $c->fields;
	367	my @rfields = map { unreserve( $_, $table_name ) }
	368	$c->reference_fields;
4dfb0380	369	next if !@fields && $c->type ne CHECK_C;
57f77285	370
	371	if ( $c->type eq PRIMARY_KEY ) {
	372	$name \|\|= mk_name( $table_name, 'pk' );
	373	push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
	374	'(' . join( ', ', @fields ) . ')';
	375	}
	376	elsif ( $c->type eq UNIQUE ) {
1c899510	377	$name \|\|= mk_name( $table_name, 'u' );
57f77285	378	push @constraint_defs, "CONSTRAINT $name UNIQUE " .
	379	'(' . join( ', ', @fields ) . ')';
	380	}
4dfb0380	381	elsif ( $c->type eq CHECK_C ) {
	382	$name \|\|= mk_name( $table_name, 'ck' );
	383	my $expression = $c->expression \|\| '';
	384	push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
	385	}
57f77285	386	elsif ( $c->type eq FOREIGN_KEY ) {
4dfb0380	387	$name \|\|= mk_name( join('_', $table_name, $c->fields), 'fk' );
cd617ba8	388	my $def = "CONSTRAINT $name FOREIGN KEY ";
	389
	390	if ( @fields ) {
1c899510	391	$def .= '(' . join( ', ', @fields ) . ')';
cd617ba8	392	}
cd617ba8	393
1c899510	394	my $ref_table = unreserve($c->reference_table);
	395
	396	$def .= " REFERENCES $ref_table";
57f77285	397
	398	if ( @rfields ) {
	399	$def .= ' (' . join( ', ', @rfields ) . ')';
	400	}
	401
	402	if ( $c->match_type ) {
	403	$def .= ' MATCH ' .
	404	( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
	405	}
	406
	407	if ( $c->on_delete ) {
	408	$def .= ' ON DELETE '.join( ' ', $c->on_delete );
	409	}
	410
	411	if ( $c->on_update ) {
	412	$def .= ' ON UPDATE '.join( ' ', $c->on_update );
	413	}
	414
	415	push @constraint_defs, $def;
	416	}
16dc9970	417	}
	418
	419	#
	420	# Index Declarations
	421	#
57f77285	422	my @index_defs = ();
57f77285	423	for my $index ( $table->get_indices ) {
	424	my $index_name = $index->name \|\| '';
	425	my $index_type = $index->type \|\| NORMAL;
44fcd0b5	426	my @fields = map { unreserve( $_, $table_name ) }
57f77285	427	$index->fields;
44fcd0b5	428	next unless @fields;
16dc9970	429
57f77285	430	if ( $index_type eq PRIMARY_KEY ) {
ab8802d7	431	$index_name \|\|= mk_name( $table_name, 'pk' );
57f77285	432	push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
16dc9970	433	'(' . join( ', ', @fields ) . ')';
16dc9970	434	}
57f77285	435	elsif ( $index_type eq NORMAL ) {
ab8802d7	436	$index_name \|\|= mk_name( $table_name, $index_name \|\| 'i' );
57f77285	437	push @index_defs,
da8e499e	438	"CREATE INDEX $index_name on $table_name_ur (".
	439	join( ', ', @fields ).
	440	");";
16dc9970	441	}
16dc9970	442	else {
96844cae	443	warn "Unknown index type ($index_type) on table $table_name.\n"
96844cae	444	if $WARN;
16dc9970	445	}
	446	}
	447
96844cae	448	my $create_statement;
96844cae	449	$create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
9fc9bfb1	450
	451	if ( my @table_comments = $table->comments ) {
	452	for my $comment ( @table_comments ) {
	453	next unless $comment;
	454	push @field_comments, "COMMENT ON TABLE $table_name is\n '".
	455	$comment."';"
	456	;
	457	}
	458	}
	459
02c2af3b	460	my $table_options = @table_options
02c2af3b	461	? "\n".join("\n", @table_options) : '';
9fc9bfb1	462	$create_statement .= "CREATE TABLE $table_name_ur (\n" .
57f77285	463	join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
02c2af3b	464	"\n)$table_options;"
16dc9970	465	;
	466
	467	$output .= join( "\n\n",
	468	@comments,
	469	$create_statement,
57f77285	470	@trigger_defs,
57f77285	471	@index_defs,
f6195129	472	@field_comments,
16dc9970	473	''
	474	);
	475	}
	476
96844cae	477	if ( $WARN ) {
	478	if ( %truncated ) {
	479	warn "Truncated " . keys( %truncated ) . " names:\n";
	480	warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
	481	}
	482
	483	if ( %unreserve ) {
	484	warn "Encounted " . keys( %unreserve ) .
	485	" unsafe names in schema (reserved or invalid):\n";
	486	warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
	487	}
	488	}
	489
d529894e	490	return $output;
16dc9970	491	}
16dc9970	492
d529894e	493	# -------------------------------------------------------------------
d529894e	494	sub mk_name {
57f77285	495	my $basename = shift \|\| '';
57f77285	496	my $type = shift \|\| '';
1c899510	497	$type = '' if $type =~ /^\d/;
57f77285	498	my $scope = shift \|\| '';
57f77285	499	my $critical = shift \|\| '';
d529894e	500	my $basename_orig = $basename;
f5087552	501	my $max_name = $type
	502	? $max_id_length - (length($type) + 1)
	503	: $max_id_length;
96844cae	504	$basename = substr( $basename, 0, $max_name )
96844cae	505	if length( $basename ) > $max_name;
d529894e	506	my $name = $type ? "${type}_$basename" : $basename;
	507
	508	if ( $basename ne $basename_orig and $critical ) {
	509	my $show_type = $type ? "+'$type'" : "";
	510	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
96844cae	511	"character limit to make '$name'\n" if $WARN;
96844cae	512	$truncated{ $basename_orig } = $name;
d529894e	513	}
	514
	515	$scope \|\|= \%global_names;
96844cae	516	if ( my $prev = $scope->{ $name } ) {
	517	my $name_orig = $name;
	518	$name .= sprintf( "%02d", ++$prev );
	519	substr($name, $max_id_length - 3) = "00"
	520	if length( $name ) > $max_id_length;
	521
	522	warn "The name '$name_orig' has been changed to ",
	523	"'$name' to make it unique.\n" if $WARN;
	524
	525	$scope->{ $name_orig }++;
	526	}
	527
	528	$scope->{ $name }++;
d529894e	529	return $name;
	530	}
	531
	532	# -------------------------------------------------------------------
	533	sub unreserve {
57f77285	534	my $name = shift \|\| '';
	535	my $schema_obj_name = shift \|\| '';
	536
96844cae	537	my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
d529894e	538
d529894e	539	# also trap fields that don't begin with a letter
57f77285	540	return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
d529894e	541
	542	if ( $schema_obj_name ) {
	543	++$unreserve{"$schema_obj_name.$name"};
	544	}
	545	else {
	546	++$unreserve{"$name (table name)"};
	547	}
	548
	549	my $unreserve = sprintf '%s_', $name;
	550	return $unreserve.$suffix;
	551	}
	552
16dc9970	553	1;
16dc9970	554
d529894e	555	# -------------------------------------------------------------------
16dc9970	556	# All bad art is the result of good intentions.
16dc9970	557	# Oscar Wilde
d529894e	558	# -------------------------------------------------------------------
16dc9970	559
ba096dc4	560	=pod
16dc9970	561
d529894e	562	=head1 CREDITS
d529894e	563
ba096dc4	564	Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
ba096dc4	565	script.
16dc9970	566
	567	=head1 AUTHOR
	568
ba096dc4	569	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
16dc9970	570
	571	=head1 SEE ALSO
	572
ba096dc4	573	SQL::Translator, DDL::Oracle, mysql2ora.
16dc9970	574
16dc9970	575	=cut