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 ) {
226 my $field_name = mk_name(
227 $field->name, '', \%field_name_scope, 1
229 my $field_name_ur = unreserve( $field_name, $table_name );
230 my $field_def = $field_name_ur;
231 $field->name( $field_name_ur );
237 my $data_type = lc $field->data_type;
238 my @size = $field->size;
239 my %extra = $field->extra;
240 my $list = $extra{'list'} || [];
241 # \todo deal with embedded quotes
242 my $commalist = join( ', ', map { qq['$_'] } @$list );
244 if ( $data_type eq 'enum' ) {
245 $check = "CHECK ($field_name_ur IN ($commalist))";
246 $data_type = 'varchar2';
248 elsif ( $data_type eq 'set' ) {
249 # XXX add a CHECK constraint maybe
250 # (trickier and slower, than enum :)
251 $data_type = 'varchar2';
254 $data_type = defined $translate{ $data_type } ?
255 $translate{ $data_type } :
257 $data_type ||= 'varchar2';
261 # Fixes ORA-02329: column of datatype LOB cannot be
262 # unique or a primary key
264 if ( $data_type eq 'clob' && $field->is_primary_key ) {
265 $data_type = 'varchar2';
267 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
271 if ( $data_type eq 'clob' && $field->is_unique ) {
272 $data_type = 'varchar2';
274 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
279 # Fixes ORA-00907: missing right parenthesis
281 if ( $data_type =~ /(date|clob)/i ) {
285 $field_def .= " $data_type";
286 if ( defined $size[0] && $size[0] > 0 ) {
287 $field_def .= '(' . join( ', ', @size ) . ')';
293 my $default = $field->default_value;
294 if ( defined $default ) {
296 # Wherein we try to catch a string being used as
297 # a default value for a numerical field. If "true/false,"
298 # then sub "1/0," otherwise just test the truthity of the
299 # argument and use that (naive?).
302 $data_type =~ /^number$/i &&
303 $default !~ /^-?\d+$/ &&
306 if ( $default =~ /^true$/i ) {
309 elsif ( $default =~ /^false$/i ) {
313 $default = $default ? "'1'" : "'0'";
317 $data_type =~ /date/ && (
318 $default eq 'current_timestamp'
323 $default = 'SYSDATE';
326 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
329 $field_def .= " DEFAULT $default",
333 # Not null constraint
335 unless ( $field->is_nullable ) {
336 $field_def .= ' NOT NULL';
339 $field_def .= " $check" if $check;
344 if ( $field->is_auto_increment ) {
345 my $base_name = $table_name_ur . "_". $field_name;
346 my $seq_name = mk_name( $base_name, 'sq' );
347 my $trigger_name = mk_name( $base_name, 'ai' );
349 push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
350 push @create, "CREATE SEQUENCE $seq_name;";
352 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
353 "BEFORE INSERT ON $table_name_ur\n" .
354 "FOR EACH ROW WHEN (\n" .
355 " new.$field_name_ur IS NULL".
356 " OR new.$field_name_ur = 0\n".
359 " SELECT $seq_name.nextval\n" .
360 " INTO :new." . $field->name."\n" .
366 if ( lc $field->data_type eq 'timestamp' ) {
367 my $base_name = $table_name_ur . "_". $field_name_ur;
368 my $trig_name = mk_name( $base_name, 'ts' );
370 "CREATE OR REPLACE TRIGGER $trig_name\n".
371 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
372 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
374 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
378 push @field_defs, $field_def;
380 if ( my $comment = $field->comments ) {
381 $comment =~ s/'/''/g;
382 push @field_comments,
383 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
384 $comment . "';" unless $options->{no_comments};
392 for my $opt ( $table->options ) {
393 if ( ref $opt eq 'HASH' ) {
394 my ( $key, $value ) = each %$opt;
395 if ( ref $value eq 'ARRAY' ) {
396 push @table_options, "$key\n(\n". join ("\n",
397 map { " $_->[0]\t$_->[1]" }
402 elsif ( !defined $value ) {
403 push @table_options, $key;
406 push @table_options, "$key $value";
414 for my $c ( $table->get_constraints ) {
415 my $name = $c->name || '';
416 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
417 my @rfields = map { unreserve( $_, $table_name ) }
418 $c->reference_fields;
419 next if !@fields && $c->type ne CHECK_C;
421 if ( $c->type eq PRIMARY_KEY ) {
422 # create a name if delay_constraints
423 $name ||= mk_name( $table_name, 'pk' )
424 if $options->{delay_constraints};
425 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
426 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
428 elsif ( $c->type eq UNIQUE ) {
429 # Don't create UNIQUE constraints identical to the primary key
430 if ( my $pk = $table->primary_key ) {
431 my $u_fields = join(":", @fields);
432 my $pk_fields = join(":", $pk->fields);
433 next if $u_fields eq $pk_fields;
436 $name ||= mk_name( $name || $table_name, 'u' );
438 for my $f ( $c->fields ) {
439 my $field_def = $table->get_field( $f ) or next;
440 my $dtype = $translate{ $field_def->data_type } or next;
441 if ( $WARN && $dtype =~ /clob/i ) {
442 warn "Oracle will not allow UNIQUE constraints on " .
443 "CLOB field '" . $field_def->table->name . '.' .
444 $field_def->name . ".'\n"
448 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
449 '(' . join( ', ', @fields ) . ')';
451 elsif ( $c->type eq CHECK_C ) {
452 $name ||= mk_name( $name || $table_name, 'ck' );
453 my $expression = $c->expression || '';
454 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
456 elsif ( $c->type eq FOREIGN_KEY ) {
457 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
458 my $def = "CONSTRAINT $name FOREIGN KEY ";
461 $def .= '(' . join( ', ', @fields ) . ')';
464 my $ref_table = unreserve($c->reference_table);
466 $def .= " REFERENCES $ref_table";
469 $def .= ' (' . join( ', ', @rfields ) . ')';
472 if ( $c->match_type ) {
474 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
477 if ( $c->on_delete ) {
478 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
481 # disabled by plu 2007-12-29 - doesn't exist for oracle
482 #if ( $c->on_update ) {
483 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
486 push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
494 for my $index ( $table->get_indices ) {
495 my $index_name = $index->name || '';
496 my $index_type = $index->type || NORMAL;
497 my @fields = map { unreserve( $_, $table_name ) }
502 for my $opt ( $index->options ) {
503 if ( ref $opt eq 'HASH' ) {
504 my ( $key, $value ) = each %$opt;
505 if ( ref $value eq 'ARRAY' ) {
506 push @table_options, "$key\n(\n". join ("\n",
507 map { " $_->[0]\t$_->[1]" }
512 elsif ( !defined $value ) {
513 push @index_options, $key;
516 push @index_options, "$key $value";
520 my $index_options = @index_options
521 ? "\n".join("\n", @index_options) : '';
523 if ( $index_type eq PRIMARY_KEY ) {
524 $index_name = $index_name ? mk_name( $index_name )
525 : mk_name( $table_name, 'pk' );
526 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
527 '(' . join( ', ', @fields ) . ')';
529 elsif ( $index_type eq NORMAL ) {
530 $index_name = $index_name ? mk_name( $index_name )
531 : mk_name( $table_name, $index_name || 'i' );
533 "CREATE INDEX $index_name on $table_name_ur (".
534 join( ', ', @fields ).
537 elsif ( $index_type eq UNIQUE ) {
538 $index_name = $index_name ? mk_name( $index_name )
539 : mk_name( $table_name, $index_name || 'i' );
541 "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
542 join( ', ', @fields ).
546 warn "Unknown index type ($index_type) on table $table_name.\n"
551 if ( my @table_comments = $table->comments ) {
552 for my $comment ( @table_comments ) {
553 next unless $comment;
554 $comment =~ s/'/''/g;
555 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
556 $comment . "';" unless $options->{no_comments}
561 my $table_options = @table_options
562 ? "\n".join("\n", @table_options) : '';
563 push @create, "CREATE TABLE $table_name_ur (\n" .
564 join( ",\n", map { " $_" } @field_defs,
565 ($options->{delay_constraints} ? () : @constraint_defs) ) .
566 "\n)$table_options;";
568 @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_ }
573 warn "Truncated " . keys( %truncated ) . " names:\n";
574 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
578 warn "Encounted " . keys( %unreserve ) .
579 " unsafe names in schema (reserved or invalid):\n";
580 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
584 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
590 my $out = sprintf("CREATE VIEW %s AS\n%s;",
597 # -------------------------------------------------------------------
599 my $basename = shift || '';
600 my $type = shift || '';
601 $type = '' if $type =~ /^\d/;
602 my $scope = shift || '';
603 my $critical = shift || '';
604 my $basename_orig = $basename;
606 ? $max_id_length - (length($type) + 1)
608 $basename = substr( $basename, 0, $max_name )
609 if length( $basename ) > $max_name;
610 my $name = $type ? "${type}_$basename" : $basename;
612 if ( $basename ne $basename_orig and $critical ) {
613 my $show_type = $type ? "+'$type'" : "";
614 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
615 "character limit to make '$name'\n" if $WARN;
616 $truncated{ $basename_orig } = $name;
619 $scope ||= \%global_names;
620 if ( my $prev = $scope->{ $name } ) {
621 my $name_orig = $name;
622 substr($name, $max_id_length - 2) = ""
623 if length( $name ) >= $max_id_length - 1;
624 $name .= sprintf( "%02d", $prev++ );
626 warn "The name '$name_orig' has been changed to ",
627 "'$name' to make it unique.\n" if $WARN;
629 $scope->{ $name_orig }++;
636 # -------------------------------------------------------------------
638 my $name = shift || '';
639 my $schema_obj_name = shift || '';
641 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
643 # also trap fields that don't begin with a letter
644 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
646 if ( $schema_obj_name ) {
647 ++$unreserve{"$schema_obj_name.$name"};
650 ++$unreserve{"$name (table name)"};
653 my $unreserve = sprintf '%s_', $name;
654 return $unreserve.$suffix;
659 # -------------------------------------------------------------------
660 # All bad art is the result of good intentions.
662 # -------------------------------------------------------------------
668 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
673 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
677 SQL::Translator, DDL::Oracle, mysql2ora.