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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.34 2005-08-10 16:33:39 duality72 Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002-4 SQLFairy Authors
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

=head1 NAME

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

=head1 SYNOPSIS

  use SQL::Translator;

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

=head1 DESCRIPTION

Creates an SQL DDL suitable for Oracle.

=cut

use strict;
use vars qw[ $VERSION $DEBUG $WARN ];
$VERSION = sprintf "%d.%02d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/;
$DEBUG   = 0 unless defined $DEBUG;

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

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

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

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

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

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

# -------------------------------------------------------------------
sub produce {
    my $translator     = shift;
    $DEBUG             = $translator->debug;
    $WARN              = $translator->show_warnings;
    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;
            $field->name( $field_name_ur );

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

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

            if ( $data_type eq 'clob' && $field->is_unique ) {
                $data_type = 'varchar2';
                $size[0]   = 4000;
                warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
                    if $WARN;
            }


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

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

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

                $field_def .= " DEFAULT $default",
            }

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

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

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

                push @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_ur . "_". $field_name_ur;
                my $trig_name = mk_name( $base_name, 'ts' );
                push @trigger_defs, 
                    "CREATE OR REPLACE TRIGGER $trig_name\n".
                    "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
                    "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
                    "BEGIN \n".
                    " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
                    "END;\n/";
            }

            push @field_defs, $field_def;

            if ( my $comment = $field->comments ) {
                $comment =~ s/'/''/g;
                push @field_comments, 
                    "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
                    $comment . "';" unless $no_comments;
            }
        }

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

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

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

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

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

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

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

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

                $def .= " REFERENCES $ref_table";

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

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

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

                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 = $index_name ? mk_name( $index_name ) 
                    : mk_name( $table_name, 'pk' );
                push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $index_type eq NORMAL ) {
                $index_name = $index_name ? mk_name( $index_name ) 
                    : mk_name( $table_name, $index_name || 'i' );
                push @index_defs, 
                    "CREATE INDEX $index_name on $table_name_ur (".
                        join( ', ', @fields ).  
                    ");"; 
            }
            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;
                $comment =~ s/'/''/g;
                push @field_comments, "COMMENT ON TABLE $table_name_ur 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;
        substr($name, $max_id_length - 2) = ""
            if length( $name ) >= $max_id_length - 1;
        $name        .= sprintf( "%02d", $prev++ );

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

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

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

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

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

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

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

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

1;

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

=pod

=head1 CREDITS

Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
script.

=head1 AUTHOR

Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.

=head1 SEE ALSO

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

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