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

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

# -------------------------------------------------------------------
# $Id: Oracle.pm,v 1.1.1.1.2.1 2002-03-15 20:13:46 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.1 $ =~ /(\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 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	# -------------------------------------------------------------------
	4	# $Id: Oracle.pm,v 1.1.1.1.2.1 2002-03-15 20:13:46 dlc Exp $
	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 );
077ebf34	27	$VERSION = sprintf "%d.%02d", q$Revision: 1.1.1.1.2.1 $ =~ /(\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
	337	=head1 AUTHOR
	338
	339	Ken Y. Clark, kclark@logsoft.com
	340
	341	=head1 SEE ALSO
	342
	343	perl(1).
	344
	345	=cut