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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.1.1.1.2.2 2002-03-18 20:30:37 dlc Exp $
# -------------------------------------------------------------------
# Copyright (C) 2002 Ken Y. Clark <kycl4rk@users.sourceforge.net>,
#                    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 );
$VERSION = sprintf "%d.%02d", q$Revision: 1.1.1.1.2.2 $ =~ /(\d+)\.(\d+)/;

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

my %translate  = (
    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',
);

# This is for testing only, and probably needs to be removed
*translate = *produce;

sub produce {
    my ( $translator, $data ) = @_;

    #print "got ", scalar keys %$data, " tables:\n";
    #print join(', ', keys %$data), "\n";
    #print Dumper( $data );

    #
    # Output
    #
    my $output = sprintf "
#
# Created by %s, version %s
# Datasource: %s
#

", __PACKAGE__, $VERSION, $translator->parser_type;

    #
    # Print create for each table
    #
    my ( $index_i, $trigger_i ) = ( 1, 1 );
    for my $table_name ( sort keys %$data ) { 
        check_identifier( $table_name );

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

        my $table = $data->{ $table_name };
        push @comments, "#\n# Table: $table_name\n#";

        for my $field ( 
            map  { $_->[1] }
            sort { $a->[0] <=> $b->[0] }
            map  { [ $_->{'order'}, $_ ] }
            values %{ $table->{'fields'} }
        ) {
            #
            # Field name
            #
            my $field_str  = check_identifier( $field->{'name'} );

            #
            # Datatype
            #
            my $data_type  = $field->{'data_type'};
               $data_type  = defined $translate{ $data_type } ?
                             $translate{ $data_type } :
                             die "Unknown datatype: $data_type\n";
               $field_str .= ' '.$data_type;
               $field_str .= '('.$field->{'size'}.')' if defined $field->{'size'};

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

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

            #
            # Auto_increment
            #
            if ( $field->{'is_auto_inc'} ) {
                my $trigger_no       = $trigger_i++;
                my $trigger_sequence = 
                    join( '_', 'seq'    , $field->{'name'}, $trigger_no );
                my $trigger_name     = 
                    join( '_', 'autoinc', $field->{'name'}, $trigger_no );

                push @trigger_decs, 
                    'CREATE SEQUENCE ' . $trigger_sequence . ";" .
                    'CREATE OR REPLACE TRIGGER ' . $trigger_name .
                    ' BEFORE INSERT ON ' . $table_name .
                    ' FOR EACH ROW WHEN (new.' . $field->{'name'} . ' is null) ' .
                    ' BEGIN ' .
                        ' SELECT ' . $trigger_sequence . '.nextval ' .
                        ' INTO :new.' . $field->{'name'} .
                        " FROM dual;\n" .
                    ' END ' . $trigger_name . ";/"
                ;
            }

            push @field_decs, $field_str;
        }

        #
        # Index Declarations
        #
        my @index_decs = ();
        for my $index ( @{ $table->{'indeces'} } ) {
            my $index_name = $index->{'name'} || '';
            my $index_type = $index->{'type'} || 'normal';
            my @fields     = @{ $index->{'fields'} } or next;

            if ( $index_type eq 'primary_key' ) {
                if ( !$index_name ) {
                    $index_name = make_identifier( $table_name, 'i_', '_pk' );
                }
                elsif ( $index_name !~ m/^i_/ ) {
                    $index_name = make_identifier( $table_name, 'i_' );
                }
                elsif ( $index_name !~ m/_pk$/ ) {
                    $index_name = make_identifier( $table_name, '_pk' );
                }
                else {
                    $index_name = make_identifier( $index_name );
                }

                push @field_decs, 'CONSTRAINT ' . $index_name . ' PRIMARY KEY ' .
                    '(' . join( ', ', @fields ) . ')';
            }

            elsif ( $index_type eq 'unique' ) {
                if ( !$index_name ) {
                    $index_name = make_identifier( join( '_', @fields ), 'u_' );
                }
                elsif ( $index_name !~ m/^u_/ ) {
                    $index_name = make_identifier( $index_name, 'u_' );
                }
                else {
                    $index_name = make_identifier( $index_name );
                }

                push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
                    '(' . join( ', ', @fields ) . ')';
            }

            elsif ( $index_type eq 'normal' ) {
                if ( !$index_name ) {
                    $index_name = 
                        make_identifier($table_name, 'i_', '_'.$index_i++ );
                }
                elsif ( $index_name !~ m/^i_/ ) {
                    $index_name = make_identifier( $index_name, 'i_' );
                }
                else {
                    $index_name = make_identifier( $index_name );
                }

                push @index_decs, "CREATE INDEX $index_name on $table_name (".
                    join( ', ', @{ $index->{'fields'} } ).
                    ");"
                ; 
            }

            else {
                warn "On table $table_name, unknown index type: $index_type\n";
            }
        }

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

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

    $output .= "#\n# End\n#\n";
}

#
# 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_identifier_length
    ) {
        $identifier = substr( 
            $identifier, 
            0, 
            $max_identifier_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_identifier_length;
    return $identifier;
}

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 AUTHOR

Ken Y. Clark, kclark@logsoft.com

=head1 SEE ALSO

perl(1).

=cut
Commit	Line	Data
16dc9970	1	package SQL::Translator::Producer::Oracle;
16dc9970	2
077ebf34	3	# -------------------------------------------------------------------
efd49776	4	# $Id: Oracle.pm,v 1.1.1.1.2.2 2002-03-18 20:30:37 dlc Exp $
077ebf34	5	# -------------------------------------------------------------------
	6	# Copyright (C) 2002 Ken Y. Clark <kycl4rk@users.sourceforge.net>,
	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
16dc9970	25	use strict;
16dc9970	26	use vars qw( $VERSION );
efd49776	27	$VERSION = sprintf "%d.%02d", q$Revision: 1.1.1.1.2.2 $ =~ /(\d+)\.(\d+)/;
16dc9970	28
	29	my $max_identifier_length = 30;
	30	my %used_identifiers = ();
	31
	32	my %translate = (
	33	bigint => 'number',
	34	double => 'number',
	35	decimal => 'number',
	36	float => 'number',
	37	int => 'number',
	38	mediumint => 'number',
	39	smallint => 'number',
	40	tinyint => 'number',
	41
	42	char => 'char',
	43
	44	varchar => 'varchar2',
	45
	46	tinyblob => 'CLOB',
	47	blob => 'CLOB',
	48	mediumblob => 'CLOB',
	49	longblob => 'CLOB',
	50
	51	longtext => 'long',
	52	mediumtext => 'long',
	53	text => 'long',
	54	tinytext => 'long',
	55
	56	enum => 'varchar2',
	57	set => 'varchar2',
	58
	59	date => 'date',
	60	datetime => 'date',
	61	time => 'date',
	62	timestamp => 'date',
	63	year => 'date',
	64	);
	65
077ebf34	66	# This is for testing only, and probably needs to be removed
077ebf34	67	translate = produce;
16dc9970	68
077ebf34	69	sub produce {
077ebf34	70	my ( $translator, $data ) = @_;
16dc9970	71
	72	#print "got ", scalar keys %$data, " tables:\n";
	73	#print join(', ', keys %$data), "\n";
	74	#print Dumper( $data );
	75
	76	#
	77	# Output
	78	#
077ebf34	79	my $output = sprintf "
	80	#
	81	# Created by %s, version %s
	82	# Datasource: %s
	83	#
	84
	85	", __PACKAGE__, $VERSION, $translator->parser_type;
16dc9970	86
	87	#
	88	# Print create for each table
	89	#
	90	my ( $index_i, $trigger_i ) = ( 1, 1 );
	91	for my $table_name ( sort keys %$data ) {
	92	check_identifier( $table_name );
	93
	94	my ( @comments, @field_decs, @trigger_decs );
	95
	96	my $table = $data->{ $table_name };
	97	push @comments, "#\n# Table: $table_name\n#";
	98
	99	for my $field (
	100	map { $_->[1] }
	101	sort { $a->[0] <=> $b->[0] }
	102	map { [ $_->{'order'}, $_ ] }
	103	values %{ $table->{'fields'} }
	104	) {
	105	#
	106	# Field name
	107	#
	108	my $field_str = check_identifier( $field->{'name'} );
	109
	110	#
	111	# Datatype
	112	#
	113	my $data_type = $field->{'data_type'};
	114	$data_type = defined $translate{ $data_type } ?
	115	$translate{ $data_type } :
	116	die "Unknown datatype: $data_type\n";
	117	$field_str .= ' '.$data_type;
	118	$field_str .= '('.$field->{'size'}.')' if defined $field->{'size'};
	119
	120	#
	121	# Default value
	122	#
	123	if ( $field->{'default'} ) {
	124	# next if $field->{'default'} eq 'NULL';
	125	$field_str .= sprintf(
	126	' DEFAULT %s',
	127	$field->{'default'} =~ m/null/i ? 'NULL' :
	128	"'".$field->{'default'}."'"
	129	);
	130	}
	131
	132	#
	133	# Not null constraint
	134	#
	135	unless ( $field->{'null'} ) {
	136	my $constraint_name = make_identifier($field->{'name'}, '_nn');
	137	$field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
	138	}
	139
	140	#
	141	# Auto_increment
	142	#
	143	if ( $field->{'is_auto_inc'} ) {
	144	my $trigger_no = $trigger_i++;
	145	my $trigger_sequence =
	146	join( '_', 'seq' , $field->{'name'}, $trigger_no );
	147	my $trigger_name =
	148	join( '_', 'autoinc', $field->{'name'}, $trigger_no );
	149
150	push @trigger_decs,
151	'CREATE SEQUENCE ' . $trigger_sequence . ";" .
152	'CREATE OR REPLACE TRIGGER ' . $trigger_name .
153	' BEFORE INSERT ON ' . $table_name .
154	' FOR EACH ROW WHEN (new.' . $field->{'name'} . ' is null) ' .
155	' BEGIN ' .
156	' SELECT ' . $trigger_sequence . '.nextval ' .
157	' INTO :new.' . $field->{'name'} .
158	" FROM dual;\n" .
159	' END ' . $trigger_name . ";/"
160	;
161	}
162
163	push @field_decs, $field_str;
164	}
165
166	#
167	# Index Declarations
168	#
169	my @index_decs = ();
170	for my $index ( @{ $table->{'indeces'} } ) {
171	my $index_name = $index->{'name'} \|\| '';
172	my $index_type = $index->{'type'} \|\| 'normal';
173	my @fields = @{ $index->{'fields'} } or next;
174
175	if ( $index_type eq 'primary_key' ) {
176	if ( !$index_name ) {
177	$index_name = make_identifier( $table_name, 'i_', '_pk' );
178	}
179	elsif ( $index_name !~ m/^i_/ ) {
180	$index_name = make_identifier( $table_name, 'i_' );
181	}
182	elsif ( $index_name !~ m/_pk$/ ) {
183	$index_name = make_identifier( $table_name, '_pk' );
184	}
185	else {
186	$index_name = make_identifier( $index_name );
187	}
188
189	push @field_decs, 'CONSTRAINT ' . $index_name . ' PRIMARY KEY ' .
190	'(' . join( ', ', @fields ) . ')';
191	}
192
193	elsif ( $index_type eq 'unique' ) {
194	if ( !$index_name ) {
195	$index_name = make_identifier( join( '_', @fields ), 'u_' );
196	}
197	elsif ( $index_name !~ m/^u_/ ) {
198	$index_name = make_identifier( $index_name, 'u_' );
199	}
200	else {
201	$index_name = make_identifier( $index_name );
202	}
203
204	push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
205	'(' . join( ', ', @fields ) . ')';
206	}
207
208	elsif ( $index_type eq 'normal' ) {
209	if ( !$index_name ) {
210	$index_name =
211	make_identifier($table_name, 'i_', '_'.$index_i++ );
212	}
213	elsif ( $index_name !~ m/^i_/ ) {
214	$index_name = make_identifier( $index_name, 'i_' );
215	}
216	else {
217	$index_name = make_identifier( $index_name );
218	}
219
220	push @index_decs, "CREATE INDEX $index_name on $table_name (".
221	join( ', ', @{ $index->{'fields'} } ).
222	");"
223	;
224	}
225
226	else {
227	warn "On table $table_name, unknown index type: $index_type\n";
228	}
229	}
230
231	my $create_statement = "CREATE TABLE $table_name (\n".
232	join( ",\n", map { " $_" } @field_decs ).
233	"\n);"
234	;
235
236	$output .= join( "\n\n",
237	@comments,
238	$create_statement,
239	@trigger_decs,
240	@index_decs,
241	''
242	);
243	}
244
245	$output .= "#\n# End\n#\n";
246	}
247
248	#
249	# Used to make index names
250	#
251	sub make_identifier {
252	my ( $identifier, @mutations ) = @_;
253	my $length_of_mutations;
254	for my $mutation ( @mutations ) {
255	$length_of_mutations += length( $mutation );
256	}
257
258	if (
259	length( $identifier ) + $length_of_mutations >
260	$max_identifier_length
261	) {
262	$identifier = substr(
263	$identifier,
264	0,
265	$max_identifier_length - $length_of_mutations
266	);
267	}
268
269	for my $mutation ( @mutations ) {
270	if ( $mutation =~ m/.+_$/ ) {
271	$identifier = $mutation.$identifier;
272	}
273	elsif ( $mutation =~ m/^_.+/ ) {
274	$identifier = $identifier.$mutation;
275	}
276	}
277
278	if ( $used_identifiers{ $identifier } ) {
279	my $index = 1;
280	if ( $identifier =~ m/_(\d+)$/ ) {
281	$index = $1;
282	$identifier = substr(
283	$identifier,
284	0,
285	length( $identifier ) - ( length( $index ) + 1 )
286	);
287	}
288	$index++;
289	return make_identifier( $identifier, '_'.$index );
290	}
291
292	$used_identifiers{ $identifier } = 1;
293
294	return $identifier;
295	}
296
297	#
298	# Checks to see if an identifier is not too long
299	#
300	sub check_identifier {
301	my $identifier = shift;
302	die "Identifier '$identifier' is too long, unrecoverable error.\n"
303	if length( $identifier ) > $max_identifier_length;
304	return $identifier;
305	}
306
307	1;
308
309	#-----------------------------------------------------
310	# All bad art is the result of good intentions.
311	# Oscar Wilde
312	#-----------------------------------------------------
313
314	=head1 NAME
315
316	SQL::Translator::Producer::Oracle - Oracle SQL producer
317
318	=head1 SYNOPSIS
319
077ebf34	320	use SQL::Translator::Parser::MySQL;
16dc9970	321	use SQL::Translator::Producer::Oracle;
16dc9970	322
077ebf34	323	my $original_create = ""; # get this from somewhere...
	324	my $translator = SQL::Translator->new;
	325
	326	$translator->parser("SQL::Translator::Parser::MySQL");
	327	$translator->producer("SQL::Translator::Producer::Oracle");
	328
	329	my $new_create = $translator->translate($original_create);
	330
16dc9970	331	=head1 DESCRIPTION
16dc9970	332
077ebf34	333	SQL::Translator::Producer::Oracle takes a parsed data structure,
	334	created by a SQL::Translator::Parser subclass, and turns it into a
	335	create string suitable for use with an Oracle database.
16dc9970	336
efd49776	337	=head1 BUGS
	338
	339	Problem with SQL::Translator::Producer::Oracle: it is keeping track
	340	of the last sequence number used, so as not to duplicate them, which
	341	is reasonable. However on runs past the first, it seems to be
	342	creating multiple constraint lines, that look like:
	343
	344	CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
	345	CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)
	346
	347	This is a very preliminary finding, and needs to be investigated more
	348	thoroughly, of course.
	349
	350
16dc9970	351	=head1 AUTHOR
	352
	353	Ken Y. Clark, kclark@logsoft.com
	354
	355	=head1 SEE ALSO
	356
	357	perl(1).
	358
	359	=cut