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
155 # Oracle 8/9 max size of data types from:
156 # http://www.ss64.com/orasyntax/datatypes.html
162 number => [ 38, 127 ],
164 varchar => 4000, # only synonym for varchar2
168 my $max_id_length = 30;
169 my %used_identifiers = ();
174 # -------------------------------------------------------------------
176 my $translator = shift;
177 $DEBUG = $translator->debug;
178 $WARN = $translator->show_warnings || 0;
179 my $no_comments = $translator->no_comments;
180 my $add_drop_table = $translator->add_drop_table;
181 my $schema = $translator->schema;
182 my $delay_constraints = $translator->producer_args->{delay_constraints};
183 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
185 $create .= header_comment unless ($no_comments);
187 if ( $translator->parser_type =~ /mysql/i ) {
189 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
190 "-- but we set it here anyway to be self-consistent.\n"
194 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
197 for my $table ( $schema->get_tables ) {
198 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def) = create_table(
201 add_drop_table => $add_drop_table,
202 show_warnings => $WARN,
203 no_comments => $no_comments,
204 delay_constraints => $delay_constraints
207 push @table_defs, @$table_def;
208 push @fk_defs, @$fk_def;
209 push @trigger_defs, @$trigger_def;
210 push @index_defs, @$index_def;
211 push @constraint_defs, @$constraint_def;
215 foreach my $view ( $schema->get_views ) {
216 push @view_defs, create_view($view);
219 return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs) : $create . join ('', map { $_ ? "$_;\n\n" : () } @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
223 my ($table, $options) = @_;
224 my $table_name = $table->name;
228 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
230 my $table_name_ur = unreserve($table_name) or next;
232 push @create, "--\n-- Table: $table_name_ur\n--" unless $options->{no_comments};
233 push @create, qq[DROP TABLE $table_name_ur CASCADE CONSTRAINTS] if $options->{add_drop_table};
235 my ( %field_name_scope, @field_comments );
236 for my $field ( $table->get_fields ) {
237 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
238 create_field($field, $options, \%field_name_scope);
239 push @create, @$field_create if ref $field_create;
240 push @field_defs, @$field_defs if ref $field_defs;
241 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
242 push @field_comments, @$field_comments if ref $field_comments;
249 for my $opt ( $table->options ) {
250 if ( ref $opt eq 'HASH' ) {
251 my ( $key, $value ) = each %$opt;
252 if ( ref $value eq 'ARRAY' ) {
253 push @table_options, "$key\n(\n". join ("\n",
254 map { " $_->[0]\t$_->[1]" }
259 elsif ( !defined $value ) {
260 push @table_options, $key;
263 push @table_options, "$key $value";
271 for my $c ( $table->get_constraints ) {
272 my $name = $c->name || '';
273 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
274 my @rfields = map { unreserve( $_, $table_name ) }
275 $c->reference_fields;
276 next if !@fields && $c->type ne CHECK_C;
278 if ( $c->type eq PRIMARY_KEY ) {
279 # create a name if delay_constraints
280 $name ||= mk_name( $table_name, 'pk' )
281 if $options->{delay_constraints};
282 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
283 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
285 elsif ( $c->type eq UNIQUE ) {
286 # Don't create UNIQUE constraints identical to the primary key
287 if ( my $pk = $table->primary_key ) {
288 my $u_fields = join(":", @fields);
289 my $pk_fields = join(":", $pk->fields);
290 next if $u_fields eq $pk_fields;
293 $name ||= mk_name( $name || $table_name, 'u' );
295 for my $f ( $c->fields ) {
296 my $field_def = $table->get_field( $f ) or next;
297 my $dtype = $translate{ $field_def->data_type } or next;
298 if ( $WARN && $dtype =~ /clob/i ) {
299 warn "Oracle will not allow UNIQUE constraints on " .
300 "CLOB field '" . $field_def->table->name . '.' .
301 $field_def->name . ".'\n"
305 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
306 '(' . join( ', ', @fields ) . ')';
308 elsif ( $c->type eq CHECK_C ) {
309 $name ||= mk_name( $name || $table_name, 'ck' );
310 my $expression = $c->expression || '';
311 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
313 elsif ( $c->type eq FOREIGN_KEY ) {
314 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
315 my $def = "CONSTRAINT $name FOREIGN KEY ";
318 $def .= '(' . join( ', ', @fields ) . ')';
321 my $ref_table = unreserve($c->reference_table);
323 $def .= " REFERENCES $ref_table";
326 $def .= ' (' . join( ', ', @rfields ) . ')';
329 if ( $c->match_type ) {
331 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
334 if ( $c->on_delete ) {
335 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
338 # disabled by plu 2007-12-29 - doesn't exist for oracle
339 #if ( $c->on_update ) {
340 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
343 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table, $def);
351 for my $index ( $table->get_indices ) {
352 my $index_name = $index->name || '';
353 my $index_type = $index->type || NORMAL;
354 my @fields = map { unreserve( $_, $table_name ) }
359 for my $opt ( $index->options ) {
360 if ( ref $opt eq 'HASH' ) {
361 my ( $key, $value ) = each %$opt;
362 if ( ref $value eq 'ARRAY' ) {
363 push @table_options, "$key\n(\n". join ("\n",
364 map { " $_->[0]\t$_->[1]" }
369 elsif ( !defined $value ) {
370 push @index_options, $key;
373 push @index_options, "$key $value";
377 my $index_options = @index_options
378 ? "\n".join("\n", @index_options) : '';
380 if ( $index_type eq PRIMARY_KEY ) {
381 $index_name = $index_name ? mk_name( $index_name )
382 : mk_name( $table_name, 'pk' );
383 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
384 '(' . join( ', ', @fields ) . ')';
386 elsif ( $index_type eq NORMAL ) {
387 $index_name = $index_name ? mk_name( $index_name )
388 : mk_name( $table_name, $index_name || 'i' );
390 "CREATE INDEX $index_name on $table_name_ur (".
391 join( ', ', @fields ).
394 elsif ( $index_type eq UNIQUE ) {
395 $index_name = $index_name ? mk_name( $index_name )
396 : mk_name( $table_name, $index_name || 'i' );
398 "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
399 join( ', ', @fields ).
403 warn "Unknown index type ($index_type) on table $table_name.\n"
408 if ( my @table_comments = $table->comments ) {
409 for my $comment ( @table_comments ) {
410 next unless $comment;
411 $comment =~ s/'/''/g;
412 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
413 $comment . "'" unless $options->{no_comments}
418 my $table_options = @table_options
419 ? "\n".join("\n", @table_options) : '';
420 push @create, "CREATE TABLE $table_name_ur (\n" .
421 join( ",\n", map { " $_" } @field_defs,
422 ($options->{delay_constraints} ? () : @constraint_defs) ) .
425 @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_ }
430 warn "Truncated " . keys( %truncated ) . " names:\n";
431 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
435 warn "Encounted " . keys( %unreserve ) .
436 " unsafe names in schema (reserved or invalid):\n";
437 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
441 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
445 my ($from_field, $to_field, $options) = @_;
447 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
448 create_field($to_field, $options, {});
451 if ($to_field->is_nullable && !$from_field->is_nullable) {
452 die 'Cannot remove NOT NULL from table field';
453 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
454 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
457 my $table_name = $to_field->table->name;
458 my $table_name_ur = unreserve( $table_name );
460 return 'ALTER TABLE '.$table_name_ur.' MODIFY ( '.join('', @$field_defs).' )';
464 my ($new_field, $options) = @_;
466 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
467 create_field($new_field, $options, {});
469 my $table_name = $new_field->table->name;
470 my $table_name_ur = unreserve( $table_name );
472 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
474 join('', @$field_defs));
479 my ($field, $options, $field_name_scope) = @_;
481 my (@create, @field_defs, @trigger_defs, @field_comments);
483 my $table_name = $field->table->name;
484 my $table_name_ur = unreserve( $table_name );
489 my $field_name = mk_name(
490 $field->name, '', $field_name_scope, 1
493 my $field_name_ur = unreserve( $field_name, $table_name );
494 my $field_def = $field_name_ur;
495 $field->name( $field_name_ur );
501 my $data_type = lc $field->data_type;
502 my @size = $field->size;
503 my %extra = $field->extra;
504 my $list = $extra{'list'} || [];
505 # \todo deal with embedded quotes
506 my $commalist = join( ', ', map { qq['$_'] } @$list );
508 if ( $data_type eq 'enum' ) {
509 $check = "CHECK ($field_name_ur IN ($commalist))";
510 $data_type = 'varchar2';
512 elsif ( $data_type eq 'set' ) {
513 # XXX add a CHECK constraint maybe
514 # (trickier and slower, than enum :)
515 $data_type = 'varchar2';
518 $data_type = defined $translate{ $data_type } ?
519 $translate{ $data_type } :
521 $data_type ||= 'varchar2';
524 # ensure size is not bigger than max size oracle allows for data type
525 if ( defined $max_size{$data_type} ) {
526 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
528 ref( $max_size{$data_type} ) eq 'ARRAY'
529 ? $max_size{$data_type}->[$i]
530 : $max_size{$data_type};
531 $size[$i] = $max if $size[$i] > $max;
536 # Fixes ORA-02329: column of datatype LOB cannot be
537 # unique or a primary key
539 if ( $data_type eq 'clob' && $field->is_primary_key ) {
540 $data_type = 'varchar2';
542 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
546 if ( $data_type eq 'clob' && $field->is_unique ) {
547 $data_type = 'varchar2';
549 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
554 # Fixes ORA-00907: missing right parenthesis
556 if ( $data_type =~ /(date|clob)/i ) {
560 $field_def .= " $data_type";
561 if ( defined $size[0] && $size[0] > 0 ) {
562 $field_def .= '(' . join( ', ', @size ) . ')';
568 my $default = $field->default_value;
569 if ( defined $default ) {
571 # Wherein we try to catch a string being used as
572 # a default value for a numerical field. If "true/false,"
573 # then sub "1/0," otherwise just test the truthity of the
574 # argument and use that (naive?).
576 if (ref $default and defined $$default) {
577 $default = $$default;
578 } elsif (ref $default) {
581 $data_type =~ /^number$/i &&
582 $default !~ /^-?\d+$/ &&
585 if ( $default =~ /^true$/i ) {
587 } elsif ( $default =~ /^false$/i ) {
590 $default = $default ? "'1'" : "'0'";
593 $data_type =~ /date/ && (
594 $default eq 'current_timestamp'
599 $default = 'SYSDATE';
601 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
604 $field_def .= " DEFAULT $default",
608 # Not null constraint
610 unless ( $field->is_nullable ) {
611 $field_def .= ' NOT NULL';
614 $field_def .= " $check" if $check;
619 if ( $field->is_auto_increment ) {
620 my $base_name = $table_name_ur . "_". $field_name;
621 my $seq_name = mk_name( $base_name, 'sq' );
622 my $trigger_name = mk_name( $base_name, 'ai' );
624 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
625 push @create, "CREATE SEQUENCE $seq_name";
627 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
628 "BEFORE INSERT ON $table_name_ur\n" .
629 "FOR EACH ROW WHEN (\n" .
630 " new.$field_name_ur IS NULL".
631 " OR new.$field_name_ur = 0\n".
634 " SELECT $seq_name.nextval\n" .
635 " INTO :new." . $field->name."\n" .
641 if ( lc $field->data_type eq 'timestamp' ) {
642 my $base_name = $table_name_ur . "_". $field_name_ur;
643 my $trig_name = mk_name( $base_name, 'ts' );
645 "CREATE OR REPLACE TRIGGER $trig_name\n".
646 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
647 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
649 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
653 push @field_defs, $field_def;
655 if ( my $comment = $field->comments ) {
656 $comment =~ s/'/''/g;
657 push @field_comments,
658 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
659 $comment . "';" unless $options->{no_comments};
662 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
670 my $out = sprintf("CREATE VIEW %s AS\n%s;",
677 # -------------------------------------------------------------------
679 my $basename = shift || '';
680 my $type = shift || '';
681 $type = '' if $type =~ /^\d/;
682 my $scope = shift || '';
683 my $critical = shift || '';
684 my $basename_orig = $basename;
686 ? $max_id_length - (length($type) + 1)
688 $basename = substr( $basename, 0, $max_name )
689 if length( $basename ) > $max_name;
690 my $name = $type ? "${type}_$basename" : $basename;
692 if ( $basename ne $basename_orig and $critical ) {
693 my $show_type = $type ? "+'$type'" : "";
694 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
695 "character limit to make '$name'\n" if $WARN;
696 $truncated{ $basename_orig } = $name;
699 $scope ||= \%global_names;
700 if ( my $prev = $scope->{ $name } ) {
701 my $name_orig = $name;
702 substr($name, $max_id_length - 2) = ""
703 if length( $name ) >= $max_id_length - 1;
704 $name .= sprintf( "%02d", $prev++ );
706 warn "The name '$name_orig' has been changed to ",
707 "'$name' to make it unique.\n" if $WARN;
709 $scope->{ $name_orig }++;
716 # -------------------------------------------------------------------
718 my $name = shift || '';
719 my $schema_obj_name = shift || '';
721 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
723 # also trap fields that don't begin with a letter
724 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
726 if ( $schema_obj_name ) {
727 ++$unreserve{"$schema_obj_name.$name"};
730 ++$unreserve{"$name (table name)"};
733 my $unreserve = sprintf '%s_', $name;
734 return $unreserve.$suffix;
739 # -------------------------------------------------------------------
740 # All bad art is the result of good intentions.
742 # -------------------------------------------------------------------
748 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
753 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
757 SQL::Translator, DDL::Oracle, mysql2ora.