1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.4 2002-11-22 03:03:40 kycl4rk Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
7 # darren chamberlain <darren@cpan.org>
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.
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.
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
22 # -------------------------------------------------------------------
26 use vars qw[ $VERSION $DEBUG ];
27 $VERSION = sprintf "%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/;
28 $DEBUG = 0 unless defined $DEBUG;
30 my $max_id_length = 30;
31 my %used_identifiers = ();
42 mediumint => 'number',
46 varchar => 'varchar2',
72 'double precision' => '',
77 'character varying' => '',
96 # Oracle reserved words from:
97 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
98 # 817_doc/server.817/a85397/ap_keywd.htm
100 my @ora_reserved = qw(
101 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
103 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
104 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
105 ELSE EXCLUSIVE EXISTS
109 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
110 INTEGER INTERSECT INTO IS
112 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
113 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
114 OF OFFLINE ON ONLINE OPTION OR ORDER
115 PCTFREE PRIOR PRIVILEGES PUBLIC
116 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
117 SELECT SESSION SET SHARE SIZE SMALLINT START
118 SUCCESSFUL SYNONYM SYSDATE
119 TABLE THEN TO TRIGGER
120 UID UNION UNIQUE UPDATE USER
121 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
125 my %ora_reserved = map { $_ => 1 } @ora_reserved;
131 my ( $translator, $data ) = @_;
132 $DEBUG = $translator->debug;
133 my $no_comments = $translator->no_comments;
135 #print "got ", scalar keys %$data, " tables:\n";
136 #print join(', ', keys %$data), "\n";
137 #print Dumper( $data );
140 unless ( $no_comments ) {
142 "--\n-- Created by %s\n-- Created on %s\n--\n\n",
143 __PACKAGE__, scalar localtime;
146 if ( $translator->parser_type =~ /mysql/i ) {
148 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
149 "-- but we set it here anyway to be self-consistent.\n".
150 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
154 # Print create for each table
156 my ( $index_i, $trigger_i ) = ( 1, 1 );
160 sort { $a->[0] <=> $b->[0] }
161 map { [ $_->{'order'}, $_ ] }
164 my $table_name = $table->{'table_name'};
165 # check_identifier( $table_name );
166 $table_name = mk_name( $table_name, '', undef, 1 );
167 # my $tablename_ur = unreserve($table_name);
169 my ( @comments, @field_decs, @trigger_decs );
171 push @comments, "--\n-- Table: $table_name\n--" unless $no_comments;
175 sort { $a->[0] <=> $b->[0] }
176 map { [ $_->{'order'}, $_ ] }
177 values %{ $table->{'fields'} }
182 my $field_str = check_identifier( $field->{'name'} );
187 my $data_type = $field->{'data_type'};
188 $data_type = defined $translate{ $data_type } ?
189 $translate{ $data_type } :
190 die "Unknown datatype: $data_type\n";
191 $field_str .= ' '.$data_type;
192 $field_str .= '('.join(',', @{ $field->{'size'} }).')'
193 if @{ $field->{'size'} || [] };
198 if ( $field->{'default'} ) {
199 # next if $field->{'default'} eq 'NULL';
200 $field_str .= sprintf(
202 $field->{'default'} =~ m/null/i ? 'NULL' :
203 "'".$field->{'default'}."'"
208 # Not null constraint
210 unless ( $field->{'null'} ) {
211 my $constraint_name = make_identifier($field->{'name'}, '_nn');
212 $field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
218 if ( $field->{'is_auto_inc'} ) {
219 my $trigger_no = $trigger_i++;
220 my $trigger_sequence =
221 join( '_', 'seq' , $field->{'name'}, $trigger_no );
223 join( '_', 'autoinc', $field->{'name'}, $trigger_no );
226 "CREATE SEQUENCE $trigger_sequence;\n" .
227 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
228 "BEFORE INSERT ON $table_name\n" .
229 "FOR EACH ROW WHEN (new.".$field->{'name'}." is null)\n".
231 " SELECT $trigger_sequence.nextval\n" .
232 " INTO :new." . $field->{'name'}."\n" .
234 " END $trigger_name;/"
238 push @field_decs, $field_str;
245 for my $index ( @{ $table->{'indices'} } ) {
246 my $index_name = $index->{'name'} || '';
247 my $index_type = $index->{'type'} || 'normal';
248 my @fields = @{ $index->{'fields'} } or next;
250 if ( $index_type eq 'primary_key' ) {
251 if ( !$index_name ) {
252 $index_name = make_identifier( $table_name, 'i_', '_pk' );
254 elsif ( $index_name !~ m/^i_/ ) {
255 $index_name = make_identifier( $table_name, 'i_' );
257 elsif ( $index_name !~ m/_pk$/ ) {
258 $index_name = make_identifier( $table_name, '_pk' );
261 $index_name = make_identifier( $index_name );
264 push @field_decs, 'CONSTRAINT ' . $index_name . ' PRIMARY KEY ' .
265 '(' . join( ', ', @fields ) . ')';
268 elsif ( $index_type eq 'unique' ) {
269 if ( !$index_name ) {
270 $index_name = make_identifier( join( '_', @fields ), 'u_' );
272 elsif ( $index_name !~ m/^u_/ ) {
273 $index_name = make_identifier( $index_name, 'u_' );
276 $index_name = make_identifier( $index_name );
279 push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
280 '(' . join( ', ', @fields ) . ')';
283 elsif ( $index_type eq 'normal' ) {
284 if ( !$index_name ) {
286 make_identifier($table_name, 'i_', '_'.$index_i++ );
288 elsif ( $index_name !~ m/^i_/ ) {
289 $index_name = make_identifier( $index_name, 'i_' );
292 $index_name = make_identifier( $index_name );
295 push @index_decs, "CREATE INDEX $index_name on $table_name (".
296 join( ', ', @{ $index->{'fields'} } ).
302 warn "On table $table_name, unknown index type: $index_type\n";
306 my $create_statement = "CREATE TABLE $table_name (\n".
307 join( ",\n", map { " $_" } @field_decs ).
311 $output .= join( "\n\n",
324 # Used to make index names
326 sub make_identifier {
327 my ( $identifier, @mutations ) = @_;
328 my $length_of_mutations;
329 for my $mutation ( @mutations ) {
330 $length_of_mutations += length( $mutation );
334 length( $identifier ) + $length_of_mutations >
337 $identifier = substr(
340 $max_id_length - $length_of_mutations
344 for my $mutation ( @mutations ) {
345 if ( $mutation =~ m/.+_$/ ) {
346 $identifier = $mutation.$identifier;
348 elsif ( $mutation =~ m/^_.+/ ) {
349 $identifier = $identifier.$mutation;
353 if ( $used_identifiers{ $identifier } ) {
355 if ( $identifier =~ m/_(\d+)$/ ) {
357 $identifier = substr(
360 length( $identifier ) - ( length( $index ) + 1 )
364 return make_identifier( $identifier, '_'.$index );
367 $used_identifiers{ $identifier } = 1;
373 # Checks to see if an identifier is not too long
375 sub check_identifier {
376 my $identifier = shift;
377 die "Identifier '$identifier' is too long, unrecoverable error.\n"
378 if length( $identifier ) > $max_id_length;
382 # -------------------------------------------------------------------
384 my ($basename, $type, $scope, $critical) = @_;
385 my $basename_orig = $basename;
386 my $max_name = $max_id_length - (length($type) + 1);
387 $basename = substr($basename, 0, $max_name)
388 if length($basename) > $max_name;
389 my $name = $type ? "${type}_$basename" : $basename;
391 if ( $basename ne $basename_orig and $critical ) {
392 my $show_type = $type ? "+'$type'" : "";
393 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
394 "character limit to make '$name'\n" if $DEBUG;
395 $truncated{$basename_orig} = $name;
398 $scope ||= \%global_names;
399 return $name unless $scope->{$name}++;
400 my $name_orig = $name;
402 substr($name, $max_id_length - 3) = "00" if length($name) > $max_id_length;
403 ++$name while $scope->{$name};
404 warn "The name '$name_orig' has been changed to ",
405 "'$name' to make it unique\n" if $DEBUG;
409 # -------------------------------------------------------------------
411 my ($name, $schema_obj_name) = @_;
412 my ($suffix) = ($name =~ s/(\W.*)$//) ? $1 : '';
414 # also trap fields that don't begin with a letter
415 return $_[0] if !$ora_reserved{uc $name}
416 && $name =~ /^[a-z]/i;
418 if ( $schema_obj_name ) {
419 ++$unreserve{"$schema_obj_name.$name"};
422 ++$unreserve{"$name (table name)"};
425 my $unreserve = sprintf '%s_', $name;
426 return $unreserve.$suffix;
431 # -------------------------------------------------------------------
432 # All bad art is the result of good intentions.
434 # -------------------------------------------------------------------
438 SQL::Translator::Producer::Oracle - Oracle SQL producer
442 use SQL::Translator::Parser::MySQL;
443 use SQL::Translator::Producer::Oracle;
445 my $original_create = ""; # get this from somewhere...
446 my $translator = SQL::Translator->new;
448 $translator->parser("SQL::Translator::Parser::MySQL");
449 $translator->producer("SQL::Translator::Producer::Oracle");
451 my $new_create = $translator->translate($original_create);
455 SQL::Translator::Producer::Oracle takes a parsed data structure,
456 created by a SQL::Translator::Parser subclass, and turns it into a
457 create string suitable for use with an Oracle database.
461 Problem with SQL::Translator::Producer::Oracle: it is keeping track
462 of the last sequence number used, so as not to duplicate them, which
463 is reasonable. However on runs past the first, it seems to be
464 creating multiple constraint lines, that look like:
466 CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
467 CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)
469 This is a very preliminary finding, and needs to be investigated more
470 thoroughly, of course.
474 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
475 his "mysql2ora" script.
479 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>