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

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

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