1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.5 2002-11-23 01:26:56 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 # -------------------------------------------------------------------
25 use vars qw[ $VERSION $DEBUG ];
26 $VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
27 $DEBUG = 0 unless defined $DEBUG;
29 my $max_id_length = 30;
30 my %used_identifiers = ();
41 mediumint => 'number',
45 varchar => 'varchar2',
71 'double precision' => '',
76 'character varying' => '',
95 # Oracle reserved words from:
96 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
97 # 817_doc/server.817/a85397/ap_keywd.htm
99 my @ora_reserved = qw(
100 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
102 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
103 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
104 ELSE EXCLUSIVE EXISTS
108 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
109 INTEGER INTERSECT INTO IS
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
124 my %ora_reserved = map { $_ => 1 } @ora_reserved;
130 my ( $translator, $data ) = @_;
131 $DEBUG = $translator->debug;
132 my $no_comments = $translator->no_comments;
135 unless ( $no_comments ) {
137 "--\n-- Created by %s\n-- Created on %s\n--\n\n",
138 __PACKAGE__, scalar localtime;
141 if ( $translator->parser_type =~ /mysql/i ) {
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";
149 # Print create for each table
153 sort { $a->[0] <=> $b->[0] }
154 map { [ $_->{'order'}, $_ ] }
157 my $table_name = $table->{'table_name'};
158 $table_name = mk_name( $table_name, '', undef, 1 );
159 my $table_name_ur = unreserve($table_name);
161 my ( @comments, @field_decs, @trigger_decs );
163 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
165 my %field_name_scope;
168 sort { $a->[0] <=> $b->[0] }
169 map { [ $_->{'order'}, $_ ] }
170 values %{ $table->{'fields'} }
175 my $field_name = mk_name(
176 $field->{'name'}, '', \%field_name_scope, 1
178 my $field_name_ur = unreserve( $field_name, $table_name );
179 my $field_str = $field_name_ur;
185 my $data_type = lc $field->{'data_type'};
186 my $list = $field->{'list'} || [];
187 my $commalist = join ",", @$list;
189 if ( $data_type eq 'enum' ) {
191 $len = ($len < length($_)) ? length($_) : $len for (@$list);
192 $check = "CHECK ($field_name IN ($commalist))";
193 $field_str .= " varchar2($len)";
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 */ ";
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'} || [] };
213 if ( $field->{'default'} ) {
214 $field_str .= sprintf(
216 $field->{'default'} =~ m/null/i ? 'NULL' :
217 "'".$field->{'default'}."'"
222 # Not null constraint
224 unless ( $field->{'null'} ) {
225 my $constraint_name = mk_name($field_name_ur, 'nn');
226 $field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
229 $field_str .= " $check" if $check;
234 if ( $field->{'is_auto_inc'} ) {
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' );
240 "CREATE SEQUENCE $seq_name;\n" .
241 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
242 "BEFORE INSERT ON $table_name\n" .
243 "FOR EACH ROW WHEN (\n" .
244 " new.$field_name_ur IS NULL".
245 " OR new.$field_name_ur = 0\n".
248 " SELECT $seq_name.nextval\n" .
249 " INTO :new." . $field->{'name'}."\n" .
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');
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".
263 " SELECT sysdate INTO :new.$field_name_ur} FROM dual;\n".
267 push @field_decs, $field_str;
274 my $idx_name_default;
275 for my $index ( @{ $table->{'indices'} } ) {
276 my $index_name = $index->{'name'} || '';
277 my $index_type = $index->{'type'} || 'normal';
278 my @fields = map { unreserve( $_, $table_name ) }
279 @{ $index->{'fields'} };
282 if ( $index_type eq 'primary_key' ) {
283 $index_name = mk_name( $table_name, 'pk' );
284 push @field_decs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
285 '(' . join( ', ', @fields ) . ')';
287 elsif ( $index_type eq 'unique' ) {
288 $index_name = mk_name(
289 $table_name, $index_name || ++$idx_name_default
291 push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
292 '(' . join( ', ', @fields ) . ')';
295 elsif ( $index_type eq 'normal' ) {
296 $index_name = mk_name(
297 $table_name, $index_name || ++$idx_name_default
299 push @index_decs, "CREATE INDEX $index_name on $table_name (".
300 join( ', ', @fields ). ");";
303 warn "Unknown index type ($index_type) on table $table_name.\n";
307 my $create_statement = "CREATE TABLE $table_name_ur (\n".
308 join( ",\n", map { " $_" } @field_decs ).
312 $output .= join( "\n\n",
324 # -------------------------------------------------------------------
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;
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;
340 $scope ||= \%global_names;
341 return $name unless $scope->{$name}++;
342 my $name_orig = $name;
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;
351 # -------------------------------------------------------------------
353 my ($name, $schema_obj_name) = @_;
354 my ($suffix) = ($name =~ s/(\W.*)$//) ? $1 : '';
356 # also trap fields that don't begin with a letter
357 return $_[0] if !$ora_reserved{uc $name}
358 && $name =~ /^[a-z]/i;
360 if ( $schema_obj_name ) {
361 ++$unreserve{"$schema_obj_name.$name"};
364 ++$unreserve{"$name (table name)"};
367 my $unreserve = sprintf '%s_', $name;
368 return $unreserve.$suffix;
373 # -------------------------------------------------------------------
374 # All bad art is the result of good intentions.
376 # -------------------------------------------------------------------
380 SQL::Translator::Producer::Oracle - Oracle SQL producer
384 use SQL::Translator::Parser::MySQL;
385 use SQL::Translator::Producer::Oracle;
387 my $original_create = ""; # get this from somewhere...
388 my $translator = SQL::Translator->new;
390 $translator->parser("SQL::Translator::Parser::MySQL");
391 $translator->producer("SQL::Translator::Producer::Oracle");
393 my $new_create = $translator->translate($original_create);
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.
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:
408 CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
409 CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)
411 This is a very preliminary finding, and needs to be investigated more
412 thoroughly, of course.
416 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
417 his "mysql2ora" script.
421 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
430 !!!!!Code Graveyard!!!!!
432 # Used to make index names
434 sub make_identifier {
435 my ( $identifier, @mutations ) = @_;
436 my $length_of_mutations;
437 for my $mutation ( @mutations ) {
438 $length_of_mutations += length( $mutation );
442 length( $identifier ) + $length_of_mutations >
445 $identifier = substr(
448 $max_id_length - $length_of_mutations
452 for my $mutation ( @mutations ) {
453 if ( $mutation =~ m/.+_$/ ) {
454 $identifier = $mutation.$identifier;
456 elsif ( $mutation =~ m/^_.+/ ) {
457 $identifier = $identifier.$mutation;
461 if ( $used_identifiers{ $identifier } ) {
463 if ( $identifier =~ m/_(\d+)$/ ) {
465 $identifier = substr(
468 length( $identifier ) - ( length( $index ) + 1 )
472 return make_identifier( $identifier, '_'.$index );
475 $used_identifiers{ $identifier } = 1;
481 # Checks to see if an identifier is not too long
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;