1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.34 2005-08-10 16:33:39 duality72 Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002-4 SQLFairy Authors
8 # This program is free software; you can redistribute it and/or
9 # modify it under the terms of the GNU General Public License as
10 # published by the Free Software Foundation; version 2.
12 # This program is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 # General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with this program; if not, write to the Free Software
19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
21 # -------------------------------------------------------------------
25 SQL::Translator::Producer::Oracle - Oracle SQL producer
31 my $t = SQL::Translator->new( parser => '...', producer => 'Oracle' );
32 print $translator->translate( $file );
36 Creates an SQL DDL suitable for Oracle.
42 =item delay_constraints
44 This option remove the primary key and other key constraints from the
45 CREATE TABLE statement and adds ALTER TABLEs at the end with it.
52 use vars qw[ $VERSION $DEBUG $WARN ];
53 $VERSION = sprintf "%d.%02d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/;
54 $DEBUG = 0 unless defined $DEBUG;
56 use SQL::Translator::Schema::Constants;
57 use SQL::Translator::Utils qw(header_comment);
69 mediumint => 'number',
73 varchar => 'varchar2',
78 tinytext => 'varchar2',
94 'double precision' => 'number',
96 bigserial => 'number',
99 'character varying' => 'varchar2',
101 interval => 'number',
112 macaddr => 'varchar2',
114 'bit varying' => 'number',
120 varchar2 => 'varchar2',
125 # Oracle reserved words from:
126 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
127 # 817_doc/server.817/a85397/ap_keywd.htm
129 my %ora_reserved = map { $_, 1 } qw(
130 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
132 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
133 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
134 ELSE EXCLUSIVE EXISTS
138 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
139 INTEGER INTERSECT INTO IS
141 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
142 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
143 OF OFFLINE ON ONLINE OPTION OR ORDER
144 PCTFREE PRIOR PRIVILEGES PUBLIC
145 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
146 SELECT SESSION SET SHARE SIZE SMALLINT START
147 SUCCESSFUL SYNONYM SYSDATE
148 TABLE THEN TO TRIGGER
149 UID UNION UNIQUE UPDATE USER
150 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
154 my $max_id_length = 30;
155 my %used_identifiers = ();
160 # -------------------------------------------------------------------
162 my $translator = shift;
163 $DEBUG = $translator->debug;
164 $WARN = $translator->show_warnings || 0;
165 my $no_comments = $translator->no_comments;
166 my $add_drop_table = $translator->add_drop_table;
167 my $schema = $translator->schema;
168 my $delay_constraints = $translator->producer_args->{delay_constraints};
169 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
171 $create .= header_comment unless ($no_comments);
173 if ( $translator->parser_type =~ /mysql/i ) {
175 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
176 "-- but we set it here anyway to be self-consistent.\n"
180 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
183 for my $table ( $schema->get_tables ) {
184 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def) = create_table(
187 add_drop_table => $add_drop_table,
188 show_warnings => $WARN,
189 no_comments => $no_comments,
190 delay_constraints => $delay_constraints
193 push @table_defs, @$table_def;
194 push @fk_defs, @$fk_def;
195 push @trigger_defs, @$trigger_def;
196 push @index_defs, @$index_def;
197 push @constraint_defs, @$constraint_def;
201 foreach my $view ( $schema->get_views ) {
202 push @view_defs, create_view($view);
205 return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs) : $create . join ("\n\n", @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs, '');
209 my ($table, $options) = @_;
210 my $table_name = $table->name;
214 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
216 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
217 push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};
219 my $table_name_ur = unreserve($table_name) or next;
221 my ( %field_name_scope, @field_comments );
222 for my $field ( $table->get_fields ) {
223 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
224 create_field($field, $options, \%field_name_scope);
225 push @create, @$field_create if ref $field_create;
226 push @field_defs, @$field_defs if ref $field_defs;
227 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
228 push @field_comments, @$field_comments if ref $field_comments;
235 for my $opt ( $table->options ) {
236 if ( ref $opt eq 'HASH' ) {
237 my ( $key, $value ) = each %$opt;
238 if ( ref $value eq 'ARRAY' ) {
239 push @table_options, "$key\n(\n". join ("\n",
240 map { " $_->[0]\t$_->[1]" }
245 elsif ( !defined $value ) {
246 push @table_options, $key;
249 push @table_options, "$key $value";
257 for my $c ( $table->get_constraints ) {
258 my $name = $c->name || '';
259 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
260 my @rfields = map { unreserve( $_, $table_name ) }
261 $c->reference_fields;
262 next if !@fields && $c->type ne CHECK_C;
264 if ( $c->type eq PRIMARY_KEY ) {
265 # create a name if delay_constraints
266 $name ||= mk_name( $table_name, 'pk' )
267 if $options->{delay_constraints};
268 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
269 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
271 elsif ( $c->type eq UNIQUE ) {
272 # Don't create UNIQUE constraints identical to the primary key
273 if ( my $pk = $table->primary_key ) {
274 my $u_fields = join(":", @fields);
275 my $pk_fields = join(":", $pk->fields);
276 next if $u_fields eq $pk_fields;
279 $name ||= mk_name( $name || $table_name, 'u' );
281 for my $f ( $c->fields ) {
282 my $field_def = $table->get_field( $f ) or next;
283 my $dtype = $translate{ $field_def->data_type } or next;
284 if ( $WARN && $dtype =~ /clob/i ) {
285 warn "Oracle will not allow UNIQUE constraints on " .
286 "CLOB field '" . $field_def->table->name . '.' .
287 $field_def->name . ".'\n"
291 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
292 '(' . join( ', ', @fields ) . ')';
294 elsif ( $c->type eq CHECK_C ) {
295 $name ||= mk_name( $name || $table_name, 'ck' );
296 my $expression = $c->expression || '';
297 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
299 elsif ( $c->type eq FOREIGN_KEY ) {
300 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
301 my $def = "CONSTRAINT $name FOREIGN KEY ";
304 $def .= '(' . join( ', ', @fields ) . ')';
307 my $ref_table = unreserve($c->reference_table);
309 $def .= " REFERENCES $ref_table";
312 $def .= ' (' . join( ', ', @rfields ) . ')';
315 if ( $c->match_type ) {
317 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
320 if ( $c->on_delete ) {
321 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
324 # disabled by plu 2007-12-29 - doesn't exist for oracle
325 #if ( $c->on_update ) {
326 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
329 push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
337 for my $index ( $table->get_indices ) {
338 my $index_name = $index->name || '';
339 my $index_type = $index->type || NORMAL;
340 my @fields = map { unreserve( $_, $table_name ) }
345 for my $opt ( $index->options ) {
346 if ( ref $opt eq 'HASH' ) {
347 my ( $key, $value ) = each %$opt;
348 if ( ref $value eq 'ARRAY' ) {
349 push @table_options, "$key\n(\n". join ("\n",
350 map { " $_->[0]\t$_->[1]" }
355 elsif ( !defined $value ) {
356 push @index_options, $key;
359 push @index_options, "$key $value";
363 my $index_options = @index_options
364 ? "\n".join("\n", @index_options) : '';
366 if ( $index_type eq PRIMARY_KEY ) {
367 $index_name = $index_name ? mk_name( $index_name )
368 : mk_name( $table_name, 'pk' );
369 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
370 '(' . join( ', ', @fields ) . ')';
372 elsif ( $index_type eq NORMAL ) {
373 $index_name = $index_name ? mk_name( $index_name )
374 : mk_name( $table_name, $index_name || 'i' );
376 "CREATE INDEX $index_name on $table_name_ur (".
377 join( ', ', @fields ).
380 elsif ( $index_type eq UNIQUE ) {
381 $index_name = $index_name ? mk_name( $index_name )
382 : mk_name( $table_name, $index_name || 'i' );
384 "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
385 join( ', ', @fields ).
389 warn "Unknown index type ($index_type) on table $table_name.\n"
394 if ( my @table_comments = $table->comments ) {
395 for my $comment ( @table_comments ) {
396 next unless $comment;
397 $comment =~ s/'/''/g;
398 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
399 $comment . "';" unless $options->{no_comments}
404 my $table_options = @table_options
405 ? "\n".join("\n", @table_options) : '';
406 push @create, "CREATE TABLE $table_name_ur (\n" .
407 join( ",\n", map { " $_" } @field_defs,
408 ($options->{delay_constraints} ? () : @constraint_defs) ) .
409 "\n)$table_options;";
411 @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_.';' }
416 warn "Truncated " . keys( %truncated ) . " names:\n";
417 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
421 warn "Encounted " . keys( %unreserve ) .
422 " unsafe names in schema (reserved or invalid):\n";
423 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
427 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
431 my ($from_field, $to_field, $options) = @_;
433 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
434 create_field($to_field, $options, {});
437 if ($to_field->is_nullable && !$from_field->is_nullable) {
438 die 'Cannot remove NOT NULL from table field';
439 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
440 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
443 my $table_name = $to_field->table->name;
444 my $table_name_ur = unreserve( $table_name );
446 return 'ALTER TABLE '.$table_name_ur.' MODIFY ( '.join('', @$field_defs).' )';
450 my ($new_field, $options) = @_;
452 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
453 create_field($new_field, $options, {});
455 my $table_name = $new_field->table->name;
456 my $table_name_ur = unreserve( $table_name );
458 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
460 join('', @$field_defs));
465 my ($field, $options, $field_name_scope) = @_;
467 my (@create, @field_defs, @trigger_defs, @field_comments);
469 my $table_name = $field->table->name;
470 my $table_name_ur = unreserve( $table_name );
475 my $field_name = mk_name(
476 $field->name, '', $field_name_scope, 1
479 my $field_name_ur = unreserve( $field_name, $table_name );
480 my $field_def = $field_name_ur;
481 $field->name( $field_name_ur );
487 my $data_type = lc $field->data_type;
488 my @size = $field->size;
489 my %extra = $field->extra;
490 my $list = $extra{'list'} || [];
491 # \todo deal with embedded quotes
492 my $commalist = join( ', ', map { qq['$_'] } @$list );
494 if ( $data_type eq 'enum' ) {
495 $check = "CHECK ($field_name_ur IN ($commalist))";
496 $data_type = 'varchar2';
498 elsif ( $data_type eq 'set' ) {
499 # XXX add a CHECK constraint maybe
500 # (trickier and slower, than enum :)
501 $data_type = 'varchar2';
504 $data_type = defined $translate{ $data_type } ?
505 $translate{ $data_type } :
507 $data_type ||= 'varchar2';
511 # Fixes ORA-02329: column of datatype LOB cannot be
512 # unique or a primary key
514 if ( $data_type eq 'clob' && $field->is_primary_key ) {
515 $data_type = 'varchar2';
517 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
521 if ( $data_type eq 'clob' && $field->is_unique ) {
522 $data_type = 'varchar2';
524 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
529 # Fixes ORA-00907: missing right parenthesis
531 if ( $data_type =~ /(date|clob)/i ) {
535 $field_def .= " $data_type";
536 if ( defined $size[0] && $size[0] > 0 ) {
537 $field_def .= '(' . join( ', ', @size ) . ')';
543 my $default = $field->default_value;
544 if ( defined $default ) {
546 # Wherein we try to catch a string being used as
547 # a default value for a numerical field. If "true/false,"
548 # then sub "1/0," otherwise just test the truthity of the
549 # argument and use that (naive?).
551 if (ref $default and defined $$default) {
552 $default = $$default;
553 } elsif (ref $default) {
556 $data_type =~ /^number$/i &&
557 $default !~ /^-?\d+$/ &&
560 if ( $default =~ /^true$/i ) {
562 } elsif ( $default =~ /^false$/i ) {
565 $default = $default ? "'1'" : "'0'";
568 $data_type =~ /date/ && (
569 $default eq 'current_timestamp'
574 $default = 'SYSDATE';
576 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
579 $field_def .= " DEFAULT $default",
583 # Not null constraint
585 unless ( $field->is_nullable ) {
586 $field_def .= ' NOT NULL';
589 $field_def .= " $check" if $check;
594 if ( $field->is_auto_increment ) {
595 my $base_name = $table_name_ur . "_". $field_name;
596 my $seq_name = mk_name( $base_name, 'sq' );
597 my $trigger_name = mk_name( $base_name, 'ai' );
599 push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
600 push @create, "CREATE SEQUENCE $seq_name;";
602 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
603 "BEFORE INSERT ON $table_name_ur\n" .
604 "FOR EACH ROW WHEN (\n" .
605 " new.$field_name_ur IS NULL".
606 " OR new.$field_name_ur = 0\n".
609 " SELECT $seq_name.nextval\n" .
610 " INTO :new." . $field->name."\n" .
616 if ( lc $field->data_type eq 'timestamp' ) {
617 my $base_name = $table_name_ur . "_". $field_name_ur;
618 my $trig_name = mk_name( $base_name, 'ts' );
620 "CREATE OR REPLACE TRIGGER $trig_name\n".
621 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
622 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
624 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
628 push @field_defs, $field_def;
630 if ( my $comment = $field->comments ) {
631 $comment =~ s/'/''/g;
632 push @field_comments,
633 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
634 $comment . "';" unless $options->{no_comments};
637 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
645 my $out = sprintf("CREATE VIEW %s AS\n%s;",
652 # -------------------------------------------------------------------
654 my $basename = shift || '';
655 my $type = shift || '';
656 $type = '' if $type =~ /^\d/;
657 my $scope = shift || '';
658 my $critical = shift || '';
659 my $basename_orig = $basename;
661 ? $max_id_length - (length($type) + 1)
663 $basename = substr( $basename, 0, $max_name )
664 if length( $basename ) > $max_name;
665 my $name = $type ? "${type}_$basename" : $basename;
667 if ( $basename ne $basename_orig and $critical ) {
668 my $show_type = $type ? "+'$type'" : "";
669 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
670 "character limit to make '$name'\n" if $WARN;
671 $truncated{ $basename_orig } = $name;
674 $scope ||= \%global_names;
675 if ( my $prev = $scope->{ $name } ) {
676 my $name_orig = $name;
677 substr($name, $max_id_length - 2) = ""
678 if length( $name ) >= $max_id_length - 1;
679 $name .= sprintf( "%02d", $prev++ );
681 warn "The name '$name_orig' has been changed to ",
682 "'$name' to make it unique.\n" if $WARN;
684 $scope->{ $name_orig }++;
691 # -------------------------------------------------------------------
693 my $name = shift || '';
694 my $schema_obj_name = shift || '';
696 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
698 # also trap fields that don't begin with a letter
699 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
701 if ( $schema_obj_name ) {
702 ++$unreserve{"$schema_obj_name.$name"};
705 ++$unreserve{"$name (table name)"};
708 my $unreserve = sprintf '%s_', $name;
709 return $unreserve.$suffix;
714 # -------------------------------------------------------------------
715 # All bad art is the result of good intentions.
717 # -------------------------------------------------------------------
723 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
728 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
732 SQL::Translator, DDL::Oracle, mysql2ora.