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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.5 2002-11-23 01:26:56 kycl4rk Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
#                    darren chamberlain <darren@cpan.org>
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation; version 2.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
# 02111-1307  USA
# -------------------------------------------------------------------

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

my $max_id_length = 30;
my %used_identifiers = ();

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

    #
    # PostgreSQL types
    #
    smallint            => '',
    integer             => '',
    bigint              => '',
    decimal             => '',
    numeric             => '',
    real                => '',
    'double precision'  => '',
    serial              => '',
    bigserial           => '',
    money               => '',
    character           => '',
    'character varying' => '',
    bytea               => '',
    interval            => '',
    boolean             => '',
    point               => '',
    line                => '',
    lseg                => '',
    box                 => '',
    path                => '',
    polygon             => '',
    circle              => '',
    cidr                => '',
    inet                => '',
    macaddr             => '',
    bit                 => '',
    'bit varying'       => '',
);

#
# Oracle reserved words from:
# http://technet.oracle.com/docs/products/oracle8i/doc_library/\
# 817_doc/server.817/a85397/ap_keywd.htm
#
my @ora_reserved = 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 %ora_reserved = map { $_ => 1 } @ora_reserved;
my %global_names;
my %unreserve;
my %truncated;

sub produce {
    my ( $translator, $data ) = @_;
    $DEBUG                    = $translator->debug;
    my $no_comments           = $translator->no_comments;
    my $output;

    unless ( $no_comments ) {
        $output .=  sprintf 
            "--\n-- Created by %s\n-- Created on %s\n--\n\n",
            __PACKAGE__, scalar localtime;
    }

    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 ( 
        map  { $_->[1] }
        sort { $a->[0] <=> $b->[0] }
        map  { [ $_->{'order'}, $_ ] }
        values %{ $data }
    ) { 
        my $table_name    = $table->{'table_name'};
        $table_name       = mk_name( $table_name, '', undef, 1 );
        my $table_name_ur = unreserve($table_name);

        my ( @comments, @field_decs, @trigger_decs );

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

        my %field_name_scope;
        for my $field ( 
            map  { $_->[1] }
            sort { $a->[0] <=> $b->[0] }
            map  { [ $_->{'order'}, $_ ] }
            values %{ $table->{'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_str     = $field_name_ur;

            #
            # Datatype
            #
            my $check;
            my $data_type = lc $field->{'data_type'};
            my $list      = $field->{'list'} || [];
            my $commalist = join ",", @$list;

            if ( $data_type eq 'enum' ) {
                my $len = 0;
                $len = ($len < length($_)) ? length($_) : $len for (@$list);
                $check = "CHECK ($field_name IN ($commalist))";
                $field_str .= " varchar2($len)";
            }
            elsif ( $data_type eq 'set' ) {
                # XXX add a CHECK constraint maybe 
                # (trickier and slower, than enum :)
                my $len     = length $commalist;
                $field_str .= " varchar2($len) /* set $commalist */ ";
            }
            else {
                $data_type  = defined $translate{ $data_type } ?
                              $translate{ $data_type } :
                              die "Unknown datatype: $data_type\n";
                $field_str .= ' '.$data_type;
                $field_str .= '('.join(',', @{ $field->{'size'} }).')' 
                    if @{ $field->{'size'} || [] };
            }

            #
            # Default value
            #
            if ( $field->{'default'} ) {
                $field_str .= sprintf(
                    ' DEFAULT %s',
                    $field->{'default'} =~ m/null/i ? 'NULL' : 
                    "'".$field->{'default'}."'"
                );
            }

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

            $field_str .= " $check" if $check;

            #
            # Auto_increment
            #
            if ( $field->{'is_auto_inc'} ) {
                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_decs, 
                    "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 ( uc $field->{'data_type'} eq 'TIMESTAMP' ) {
                my $base_name = $table_name . "_". $field_name_ur;
                my $trig_name = mk_name($base_name,'ts');
                push @trigger_decs, 
                    "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_decs, $field_str;
        }

        #
        # Index Declarations
        #
        my @index_decs = ();
        my $idx_name_default;
        for my $index ( @{ $table->{'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_decs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
                    '(' . join( ', ', @fields ) . ')';
            }
            elsif ( $index_type eq 'unique' ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }

            elsif ( $index_type eq 'normal' ) {
                $index_name = mk_name( 
                    $table_name, $index_name || ++$idx_name_default
                );
                push @index_decs, "CREATE INDEX $index_name on $table_name (".
                    join( ', ', @fields ).  ");"; 
            }
            else {
                warn "Unknown index type ($index_type) on table $table_name.\n";
            }
        }

        my $create_statement = "CREATE TABLE $table_name_ur (\n".
            join( ",\n", map { "  $_" } @field_decs ).
            "\n);"
        ;

        $output .= join( "\n\n", 
            @comments,
            $create_statement, 
            @trigger_decs, 
            @index_decs, 
            '' 
        );
    }

    return $output;
}

# -------------------------------------------------------------------
sub mk_name {
    my ($basename, $type, $scope, $critical) = @_;
    my $basename_orig = $basename;
    my $max_name      = $max_id_length - (length($type) + 1);
    $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 $DEBUG;
        $truncated{$basename_orig} = $name;
    }

    $scope ||= \%global_names;
    return $name unless $scope->{$name}++;
    my $name_orig = $name;
    $name .= "02";
    substr($name, $max_id_length - 3) = "00" if length($name) > $max_id_length;
    ++$name while $scope->{$name};
    warn "The name '$name_orig' has been changed to ",
         "'$name' to make it unique\n" if $DEBUG;
    return $name;
}

# -------------------------------------------------------------------
sub unreserve {
    my ($name, $schema_obj_name) = @_;
    my ($suffix) = ($name =~ s/(\W.*)$//) ? $1 : '';

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

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

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

1;

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

=head1 NAME

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

=head1 SYNOPSIS

  use SQL::Translator::Parser::MySQL;
  use SQL::Translator::Producer::Oracle;

  my $original_create = ""; # get this from somewhere...
  my $translator = SQL::Translator->new;

  $translator->parser("SQL::Translator::Parser::MySQL");
  $translator->producer("SQL::Translator::Producer::Oracle");

  my $new_create = $translator->translate($original_create);

=head1 DESCRIPTION

SQL::Translator::Producer::Oracle takes a parsed data structure,
created by a SQL::Translator::Parser subclass, and turns it into a
create string suitable for use with an Oracle database.

=head1 BUGS

Problem with SQL::Translator::Producer::Oracle: it is keeping track
of the last sequence number used, so as not to duplicate them, which
is reasonable.  However on runs past the first, it seems to be
creating multiple constraint lines, that look like:

    CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
    CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)

This is a very preliminary finding, and needs to be investigated more
thoroughly, of course.

=head1 CREDITS

A hearty "thank-you" to Tim Bunce for much of the logic stolen from 
his "mysql2ora" script.

=head1 AUTHOR

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

=head1 SEE ALSO

perl(1).

=cut

__END__
!!!!!Code Graveyard!!!!!
#
# Used to make index names
#
sub make_identifier {
    my ( $identifier, @mutations ) = @_;
    my $length_of_mutations;
    for my $mutation ( @mutations ) {
        $length_of_mutations += length( $mutation );
    }

    if ( 
        length( $identifier ) + $length_of_mutations >
        $max_id_length
    ) {
        $identifier = substr( 
            $identifier, 
            0, 
            $max_id_length - $length_of_mutations
        );
    }

    for my $mutation ( @mutations ) {
        if ( $mutation =~ m/.+_$/ ) {
            $identifier = $mutation.$identifier;
        }
        elsif ( $mutation =~ m/^_.+/ ) {
            $identifier = $identifier.$mutation;
        }
    }

    if ( $used_identifiers{ $identifier } ) {
        my $index = 1;
        if ( $identifier =~ m/_(\d+)$/ ) {
            $index = $1;
            $identifier = substr( 
                $identifier, 
                0, 
                length( $identifier ) - ( length( $index ) + 1 )
            );
        }
        $index++;
        return make_identifier( $identifier, '_'.$index );
    }

    $used_identifiers{ $identifier } = 1;

    return $identifier;
}

#
# Checks to see if an identifier is not too long
#
sub check_identifier {
    my $identifier = shift;
    die "Identifier '$identifier' is too long, unrecoverable error.\n"
        if length( $identifier ) > $max_id_length;
    return $identifier;
}
Commit	Line	Data
16dc9970	1	package SQL::Translator::Producer::Oracle;
16dc9970	2
077ebf34	3	# -------------------------------------------------------------------
44fcd0b5	4	# $Id: Oracle.pm,v 1.5 2002-11-23 01:26:56 kycl4rk Exp $
077ebf34	5	# -------------------------------------------------------------------
d529894e	6	# Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
077ebf34	7	# darren chamberlain <darren@cpan.org>
16dc9970	8	#
077ebf34	9	# This program is free software; you can redistribute it and/or
	10	# modify it under the terms of the GNU General Public License as
	11	# published by the Free Software Foundation; version 2.
	12	#
	13	# This program is distributed in the hope that it will be useful, but
	14	# WITHOUT ANY WARRANTY; without even the implied warranty of
	15	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	16	# General Public License for more details.
	17	#
	18	# You should have received a copy of the GNU General Public License
	19	# along with this program; if not, write to the Free Software
	20	# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
	21	# 02111-1307 USA
	22	# -------------------------------------------------------------------
	23
16dc9970	24	use strict;
d529894e	25	use vars qw[ $VERSION $DEBUG ];
44fcd0b5	26	$VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
d529894e	27	$DEBUG = 0 unless defined $DEBUG;
16dc9970	28
d529894e	29	my $max_id_length = 30;
16dc9970	30	my %used_identifiers = ();
	31
	32	my %translate = (
d529894e	33	#
	34	# MySQL types
	35	#
16dc9970	36	bigint => 'number',
	37	double => 'number',
	38	decimal => 'number',
	39	float => 'number',
	40	int => 'number',
	41	mediumint => 'number',
	42	smallint => 'number',
	43	tinyint => 'number',
16dc9970	44	char => 'char',
16dc9970	45	varchar => 'varchar2',
16dc9970	46	tinyblob => 'CLOB',
	47	blob => 'CLOB',
	48	mediumblob => 'CLOB',
	49	longblob => 'CLOB',
16dc9970	50	longtext => 'long',
	51	mediumtext => 'long',
	52	text => 'long',
	53	tinytext => 'long',
16dc9970	54	enum => 'varchar2',
16dc9970	55	set => 'varchar2',
16dc9970	56	date => 'date',
	57	datetime => 'date',
	58	time => 'date',
	59	timestamp => 'date',
	60	year => 'date',
d529894e	61
	62	#
	63	# PostgreSQL types
	64	#
	65	smallint => '',
	66	integer => '',
	67	bigint => '',
	68	decimal => '',
	69	numeric => '',
	70	real => '',
	71	'double precision' => '',
	72	serial => '',
	73	bigserial => '',
	74	money => '',
	75	character => '',
	76	'character varying' => '',
	77	bytea => '',
	78	interval => '',
	79	boolean => '',
	80	point => '',
	81	line => '',
	82	lseg => '',
	83	box => '',
	84	path => '',
	85	polygon => '',
	86	circle => '',
	87	cidr => '',
	88	inet => '',
	89	macaddr => '',
	90	bit => '',
	91	'bit varying' => '',
	92	);
	93
	94	#
	95	# Oracle reserved words from:
	96	# http://technet.oracle.com/docs/products/oracle8i/doc_library/\
	97	# 817_doc/server.817/a85397/ap_keywd.htm
	98	#
	99	my @ora_reserved = qw(
	100	ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
	101	BETWEEN BY
	102	CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
	103	DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
	104	ELSE EXCLUSIVE EXISTS
	105	FILE FLOAT FOR FROM
	106	GRANT GROUP
	107	HAVING
	108	IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
	109	INTEGER INTERSECT INTO IS
	110	LEVEL LIKE LOCK LONG
	111	MAXEXTENTS MINUS MLSLABEL MODE MODIFY
	112	NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
	113	OF OFFLINE ON ONLINE OPTION OR ORDER
	114	PCTFREE PRIOR PRIVILEGES PUBLIC
	115	RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
	116	SELECT SESSION SET SHARE SIZE SMALLINT START
	117	SUCCESSFUL SYNONYM SYSDATE
	118	TABLE THEN TO TRIGGER
	119	UID UNION UNIQUE UPDATE USER
	120	VALIDATE VALUES VARCHAR VARCHAR2 VIEW
	121	WHENEVER WHERE WITH
16dc9970	122	);
16dc9970	123
d529894e	124	my %ora_reserved = map { $_ => 1 } @ora_reserved;
	125	my %global_names;
	126	my %unreserve;
	127	my %truncated;
16dc9970	128
077ebf34	129	sub produce {
077ebf34	130	my ( $translator, $data ) = @_;
d529894e	131	$DEBUG = $translator->debug;
d529894e	132	my $no_comments = $translator->no_comments;
d529894e	133	my $output;
44fcd0b5	134
d529894e	135	unless ( $no_comments ) {
	136	$output .= sprintf
	137	"--\n-- Created by %s\n-- Created on %s\n--\n\n",
	138	__PACKAGE__, scalar localtime;
	139	}
077ebf34	140
d529894e	141	if ( $translator->parser_type =~ /mysql/i ) {
	142	$output .=
	143	"-- We assume that default NLS_DATE_FORMAT has been changed\n".
	144	"-- but we set it here anyway to be self-consistent.\n".
	145	"ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
	146	}
16dc9970	147
	148	#
	149	# Print create for each table
	150	#
d529894e	151	for my $table (
d529894e	152	map { $_->[1] }
	153	sort { $a->[0] <=> $b->[0] }
	154	map { [ $_->{'order'}, $_ ] }
	155	values %{ $data }
	156	) {
44fcd0b5	157	my $table_name = $table->{'table_name'};
	158	$table_name = mk_name( $table_name, '', undef, 1 );
	159	my $table_name_ur = unreserve($table_name);
16dc9970	160
	161	my ( @comments, @field_decs, @trigger_decs );
	162
44fcd0b5	163	push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
16dc9970	164
44fcd0b5	165	my %field_name_scope;
16dc9970	166	for my $field (
	167	map { $_->[1] }
	168	sort { $a->[0] <=> $b->[0] }
	169	map { [ $_->{'order'}, $_ ] }
	170	values %{ $table->{'fields'} }
	171	) {
	172	#
	173	# Field name
	174	#
44fcd0b5	175	my $field_name = mk_name(
	176	$field->{'name'}, '', \%field_name_scope, 1
	177	);
	178	my $field_name_ur = unreserve( $field_name, $table_name );
	179	my $field_str = $field_name_ur;
16dc9970	180
	181	#
	182	# Datatype
	183	#
44fcd0b5	184	my $check;
	185	my $data_type = lc $field->{'data_type'};
	186	my $list = $field->{'list'} \|\| [];
	187	my $commalist = join ",", @$list;
	188
	189	if ( $data_type eq 'enum' ) {
	190	my $len = 0;
	191	$len = ($len < length($_)) ? length($_) : $len for (@$list);
	192	$check = "CHECK ($field_name IN ($commalist))";
	193	$field_str .= " varchar2($len)";
	194	}
	195	elsif ( $data_type eq 'set' ) {
	196	# XXX add a CHECK constraint maybe
	197	# (trickier and slower, than enum :)
	198	my $len = length $commalist;
	199	$field_str .= " varchar2($len) /* set $commalist */ ";
	200	}
	201	else {
	202	$data_type = defined $translate{ $data_type } ?
	203	$translate{ $data_type } :
	204	die "Unknown datatype: $data_type\n";
	205	$field_str .= ' '.$data_type;
	206	$field_str .= '('.join(',', @{ $field->{'size'} }).')'
	207	if @{ $field->{'size'} \|\| [] };
	208	}
16dc9970	209
	210	#
	211	# Default value
	212	#
	213	if ( $field->{'default'} ) {
16dc9970	214	$field_str .= sprintf(
	215	' DEFAULT %s',
	216	$field->{'default'} =~ m/null/i ? 'NULL' :
	217	"'".$field->{'default'}."'"
	218	);
	219	}
	220
	221	#
	222	# Not null constraint
	223	#
	224	unless ( $field->{'null'} ) {
44fcd0b5	225	my $constraint_name = mk_name($field_name_ur, 'nn');
16dc9970	226	$field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
	227	}
	228
44fcd0b5	229	$field_str .= " $check" if $check;
44fcd0b5	230
16dc9970	231	#
	232	# Auto_increment
	233	#
	234	if ( $field->{'is_auto_inc'} ) {
44fcd0b5	235	my $base_name = $table_name . "_". $field_name;
	236	my $seq_name = mk_name( $base_name, 'sq' );
	237	my $trigger_name = mk_name( $base_name, 'ai' );
16dc9970	238
16dc9970	239	push @trigger_decs,
44fcd0b5	240	"CREATE SEQUENCE $seq_name;\n" .
d529894e	241	"CREATE OR REPLACE TRIGGER $trigger_name\n" .
d529894e	242	"BEFORE INSERT ON $table_name\n" .
44fcd0b5	243	"FOR EACH ROW WHEN (\n" .
	244	" new.$field_name_ur IS NULL".
	245	" OR new.$field_name_ur = 0\n".
	246	")\n".
d529894e	247	"BEGIN\n" .
44fcd0b5	248	" SELECT $seq_name.nextval\n" .
d529894e	249	" INTO :new." . $field->{'name'}."\n" .
16dc9970	250	" FROM dual;\n" .
44fcd0b5	251	"END;\n/";
16dc9970	252	;
	253	}
	254
44fcd0b5	255	if ( uc $field->{'data_type'} eq 'TIMESTAMP' ) {
	256	my $base_name = $table_name . "_". $field_name_ur;
	257	my $trig_name = mk_name($base_name,'ts');
	258	push @trigger_decs,
	259	"CREATE OR REPLACE TRIGGER $trig_name\n".
	260	"BEFORE INSERT OR UPDATE ON $table_name_ur\n".
	261	"FOR EACH ROW WHEN (new.$field_name_ur} IS NULL)\n".
	262	"BEGIN \n".
	263	" SELECT sysdate INTO :new.$field_name_ur} FROM dual;\n".
	264	"END;\n/";
	265	}
	266
16dc9970	267	push @field_decs, $field_str;
	268	}
	269
	270	#
	271	# Index Declarations
	272	#
	273	my @index_decs = ();
44fcd0b5	274	my $idx_name_default;
49e1eb70	275	for my $index ( @{ $table->{'indices'} } ) {
16dc9970	276	my $index_name = $index->{'name'} \|\| '';
16dc9970	277	my $index_type = $index->{'type'} \|\| 'normal';
44fcd0b5	278	my @fields = map { unreserve( $_, $table_name ) }
	279	@{ $index->{'fields'} };
	280	next unless @fields;
16dc9970	281
16dc9970	282	if ( $index_type eq 'primary_key' ) {
44fcd0b5	283	$index_name = mk_name( $table_name, 'pk' );
44fcd0b5	284	push @field_decs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
16dc9970	285	'(' . join( ', ', @fields ) . ')';
16dc9970	286	}
16dc9970	287	elsif ( $index_type eq 'unique' ) {
44fcd0b5	288	$index_name = mk_name(
	289	$table_name, $index_name \|\| ++$idx_name_default
	290	);
16dc9970	291	push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
	292	'(' . join( ', ', @fields ) . ')';
	293	}
	294
	295	elsif ( $index_type eq 'normal' ) {
44fcd0b5	296	$index_name = mk_name(
	297	$table_name, $index_name \|\| ++$idx_name_default
	298	);
16dc9970	299	push @index_decs, "CREATE INDEX $index_name on $table_name (".
44fcd0b5	300	join( ', ', @fields ). ");";
16dc9970	301	}
16dc9970	302	else {
44fcd0b5	303	warn "Unknown index type ($index_type) on table $table_name.\n";
16dc9970	304	}
	305	}
	306
44fcd0b5	307	my $create_statement = "CREATE TABLE $table_name_ur (\n".
16dc9970	308	join( ",\n", map { " $_" } @field_decs ).
44fcd0b5	309	"\n);"
16dc9970	310	;
	311
	312	$output .= join( "\n\n",
	313	@comments,
	314	$create_statement,
	315	@trigger_decs,
	316	@index_decs,
	317	''
	318	);
	319	}
	320
d529894e	321	return $output;
16dc9970	322	}
16dc9970	323
d529894e	324	# -------------------------------------------------------------------
	325	sub mk_name {
	326	my ($basename, $type, $scope, $critical) = @_;
	327	my $basename_orig = $basename;
	328	my $max_name = $max_id_length - (length($type) + 1);
	329	$basename = substr($basename, 0, $max_name)
	330	if length($basename) > $max_name;
	331	my $name = $type ? "${type}_$basename" : $basename;
	332
	333	if ( $basename ne $basename_orig and $critical ) {
	334	my $show_type = $type ? "+'$type'" : "";
	335	warn "Truncating '$basename_orig'$show_type to $max_id_length ",
	336	"character limit to make '$name'\n" if $DEBUG;
	337	$truncated{$basename_orig} = $name;
	338	}
	339
	340	$scope \|\|= \%global_names;
	341	return $name unless $scope->{$name}++;
	342	my $name_orig = $name;
	343	$name .= "02";
	344	substr($name, $max_id_length - 3) = "00" if length($name) > $max_id_length;
	345	++$name while $scope->{$name};
	346	warn "The name '$name_orig' has been changed to ",
	347	"'$name' to make it unique\n" if $DEBUG;
	348	return $name;
	349	}
	350
	351	# -------------------------------------------------------------------
	352	sub unreserve {
	353	my ($name, $schema_obj_name) = @_;
	354	my ($suffix) = ($name =~ s/(\W.*)$//) ? $1 : '';
	355
	356	# also trap fields that don't begin with a letter
	357	return $_[0] if !$ora_reserved{uc $name}
	358	&& $name =~ /^[a-z]/i;
	359
	360	if ( $schema_obj_name ) {
	361	++$unreserve{"$schema_obj_name.$name"};
	362	}
	363	else {
	364	++$unreserve{"$name (table name)"};
	365	}
	366
	367	my $unreserve = sprintf '%s_', $name;
	368	return $unreserve.$suffix;
	369	}
	370
16dc9970	371	1;
16dc9970	372
d529894e	373	# -------------------------------------------------------------------
16dc9970	374	# All bad art is the result of good intentions.
16dc9970	375	# Oscar Wilde
d529894e	376	# -------------------------------------------------------------------
16dc9970	377
	378	=head1 NAME
	379
	380	SQL::Translator::Producer::Oracle - Oracle SQL producer
	381
	382	=head1 SYNOPSIS
	383
077ebf34	384	use SQL::Translator::Parser::MySQL;
16dc9970	385	use SQL::Translator::Producer::Oracle;
16dc9970	386
077ebf34	387	my $original_create = ""; # get this from somewhere...
	388	my $translator = SQL::Translator->new;
	389
	390	$translator->parser("SQL::Translator::Parser::MySQL");
	391	$translator->producer("SQL::Translator::Producer::Oracle");
	392
	393	my $new_create = $translator->translate($original_create);
	394
16dc9970	395	=head1 DESCRIPTION
16dc9970	396
077ebf34	397	SQL::Translator::Producer::Oracle takes a parsed data structure,
	398	created by a SQL::Translator::Parser subclass, and turns it into a
	399	create string suitable for use with an Oracle database.
16dc9970	400
efd49776	401	=head1 BUGS
	402
	403	Problem with SQL::Translator::Producer::Oracle: it is keeping track
	404	of the last sequence number used, so as not to duplicate them, which
	405	is reasonable. However on runs past the first, it seems to be
	406	creating multiple constraint lines, that look like:
	407
	408	CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
	409	CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)
	410
	411	This is a very preliminary finding, and needs to be investigated more
	412	thoroughly, of course.
	413
d529894e	414	=head1 CREDITS
	415
	416	A hearty "thank-you" to Tim Bunce for much of the logic stolen from
	417	his "mysql2ora" script.
16dc9970	418
	419	=head1 AUTHOR
	420
d529894e	421	Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
16dc9970	422
	423	=head1 SEE ALSO
	424
	425	perl(1).
	426
	427	=cut
44fcd0b5	428
	429	__END__
	430	!!!!!Code Graveyard!!!!!
	431	#
	432	# Used to make index names
	433	#
	434	sub make_identifier {
	435	my ( $identifier, @mutations ) = @_;
	436	my $length_of_mutations;
	437	for my $mutation ( @mutations ) {
	438	$length_of_mutations += length( $mutation );
	439	}
	440
	441	if (
	442	length( $identifier ) + $length_of_mutations >
	443	$max_id_length
	444	) {
	445	$identifier = substr(
	446	$identifier,
	447	0,
	448	$max_id_length - $length_of_mutations
	449	);
	450	}
	451
	452	for my $mutation ( @mutations ) {
	453	if ( $mutation =~ m/.+_$/ ) {
	454	$identifier = $mutation.$identifier;
	455	}
	456	elsif ( $mutation =~ m/^_.+/ ) {
	457	$identifier = $identifier.$mutation;
	458	}
	459	}
	460
	461	if ( $used_identifiers{ $identifier } ) {
	462	my $index = 1;
	463	if ( $identifier =~ m/_(\d+)$/ ) {
	464	$index = $1;
	465	$identifier = substr(
	466	$identifier,
	467	0,
	468	length( $identifier ) - ( length( $index ) + 1 )
	469	);
	470	}
	471	$index++;
	472	return make_identifier( $identifier, '_'.$index );
	473	}
	474
	475	$used_identifiers{ $identifier } = 1;
	476
	477	return $identifier;
	478	}
	479
	480	#
	481	# Checks to see if an identifier is not too long
	482	#
	483	sub check_identifier {
	484	my $identifier = shift;
	485	die "Identifier '$identifier' is too long, unrecoverable error.\n"
	486	if length( $identifier ) > $max_id_length;
	487	return $identifier;
	488	}
	489