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.
41 use vars qw[ $VERSION $DEBUG $WARN ];
42 $VERSION = sprintf "%d.%02d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/;
43 $DEBUG = 0 unless defined $DEBUG;
45 use SQL::Translator::Schema::Constants;
46 use SQL::Translator::Utils qw(header_comment);
58 mediumint => 'number',
62 varchar => 'varchar2',
67 tinytext => 'varchar2',
83 'double precision' => 'number',
85 bigserial => 'number',
88 'character varying' => 'varchar2',
101 macaddr => 'varchar2',
103 'bit varying' => 'number',
109 varchar2 => 'varchar2',
114 # Oracle reserved words from:
115 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
116 # 817_doc/server.817/a85397/ap_keywd.htm
118 my %ora_reserved = map { $_, 1 } qw(
119 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
121 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
122 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
123 ELSE EXCLUSIVE EXISTS
127 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
128 INTEGER INTERSECT INTO IS
130 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
131 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
132 OF OFFLINE ON ONLINE OPTION OR ORDER
133 PCTFREE PRIOR PRIVILEGES PUBLIC
134 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
135 SELECT SESSION SET SHARE SIZE SMALLINT START
136 SUCCESSFUL SYNONYM SYSDATE
137 TABLE THEN TO TRIGGER
138 UID UNION UNIQUE UPDATE USER
139 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
143 my $max_id_length = 30;
144 my %used_identifiers = ();
149 # -------------------------------------------------------------------
151 my $translator = shift;
152 $DEBUG = $translator->debug;
153 $WARN = $translator->show_warnings || 0;
154 my $no_comments = $translator->no_comments;
155 my $add_drop_table = $translator->add_drop_table;
156 my $schema = $translator->schema;
157 my $delay_constraints = $translator->producer_args->{delay_constraints};
158 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
160 $create .= header_comment unless ($no_comments);
162 if ( $translator->parser_type =~ /mysql/i ) {
164 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
165 "-- but we set it here anyway to be self-consistent.\n"
169 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
172 for my $table ( $schema->get_tables ) {
173 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def) = create_table(
176 add_drop_table => $add_drop_table,
177 show_warnings => $WARN,
178 no_comments => $no_comments,
179 delay_constraints => $delay_constraints
182 push @table_defs, @$table_def;
183 push @fk_defs, @$fk_def;
184 push @trigger_defs, @$trigger_def;
185 push @index_defs, @$index_def;
186 push @constraint_defs, @$constraint_def;
190 foreach my $view ( $schema->get_views ) {
191 push @view_defs, create_view($view);
194 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, '');
198 my ($table, $options) = @_;
199 my $table_name = $table->name;
203 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
205 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
206 push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};
208 my $table_name_ur = unreserve($table_name) or next;
210 my ( %field_name_scope, @field_comments );
211 for my $field ( $table->get_fields ) {
215 my $field_name = mk_name(
216 $field->name, '', \%field_name_scope, 1
218 my $field_name_ur = unreserve( $field_name, $table_name );
219 my $field_def = $field_name_ur;
220 $field->name( $field_name_ur );
226 my $data_type = lc $field->data_type;
227 my @size = $field->size;
228 my %extra = $field->extra;
229 my $list = $extra{'list'} || [];
230 # \todo deal with embedded quotes
231 my $commalist = join( ', ', map { qq['$_'] } @$list );
233 if ( $data_type eq 'enum' ) {
234 $check = "CHECK ($field_name_ur IN ($commalist))";
235 $data_type = 'varchar2';
237 elsif ( $data_type eq 'set' ) {
238 # XXX add a CHECK constraint maybe
239 # (trickier and slower, than enum :)
240 $data_type = 'varchar2';
243 $data_type = defined $translate{ $data_type } ?
244 $translate{ $data_type } :
246 $data_type ||= 'varchar2';
250 # Fixes ORA-02329: column of datatype LOB cannot be
251 # unique or a primary key
253 if ( $data_type eq 'clob' && $field->is_primary_key ) {
254 $data_type = 'varchar2';
256 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
260 if ( $data_type eq 'clob' && $field->is_unique ) {
261 $data_type = 'varchar2';
263 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
268 # Fixes ORA-00907: missing right parenthesis
270 if ( $data_type =~ /(date|clob)/i ) {
274 $field_def .= " $data_type";
275 if ( defined $size[0] && $size[0] > 0 ) {
276 $field_def .= '(' . join( ', ', @size ) . ')';
282 my $default = $field->default_value;
283 if ( defined $default ) {
285 # Wherein we try to catch a string being used as
286 # a default value for a numerical field. If "true/false,"
287 # then sub "1/0," otherwise just test the truthity of the
288 # argument and use that (naive?).
291 $data_type =~ /^number$/i &&
292 $default !~ /^-?\d+$/ &&
295 if ( $default =~ /^true$/i ) {
298 elsif ( $default =~ /^false$/i ) {
302 $default = $default ? "'1'" : "'0'";
306 $data_type =~ /date/ && (
307 $default eq 'current_timestamp'
312 $default = 'SYSDATE';
315 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
318 $field_def .= " DEFAULT $default",
322 # Not null constraint
324 unless ( $field->is_nullable ) {
325 $field_def .= ' NOT NULL';
328 $field_def .= " $check" if $check;
333 if ( $field->is_auto_increment ) {
334 my $base_name = $table_name_ur . "_". $field_name;
335 my $seq_name = mk_name( $base_name, 'sq' );
336 my $trigger_name = mk_name( $base_name, 'ai' );
338 push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
339 push @create, "CREATE SEQUENCE $seq_name;";
341 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
342 "BEFORE INSERT ON $table_name_ur\n" .
343 "FOR EACH ROW WHEN (\n" .
344 " new.$field_name_ur IS NULL".
345 " OR new.$field_name_ur = 0\n".
348 " SELECT $seq_name.nextval\n" .
349 " INTO :new." . $field->name."\n" .
355 if ( lc $field->data_type eq 'timestamp' ) {
356 my $base_name = $table_name_ur . "_". $field_name_ur;
357 my $trig_name = mk_name( $base_name, 'ts' );
359 "CREATE OR REPLACE TRIGGER $trig_name\n".
360 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
361 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
363 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
367 push @field_defs, $field_def;
369 if ( my $comment = $field->comments ) {
370 $comment =~ s/'/''/g;
371 push @field_comments,
372 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
373 $comment . "';" unless $options->{no_comments};
381 for my $opt ( $table->options ) {
382 if ( ref $opt eq 'HASH' ) {
383 my ( $key, $value ) = each %$opt;
384 if ( ref $value eq 'ARRAY' ) {
385 push @table_options, "$key\n(\n". join ("\n",
386 map { " $_->[0]\t$_->[1]" }
391 elsif ( !defined $value ) {
392 push @table_options, $key;
395 push @table_options, "$key $value";
403 for my $c ( $table->get_constraints ) {
404 my $name = $c->name || '';
405 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
406 my @rfields = map { unreserve( $_, $table_name ) }
407 $c->reference_fields;
408 next if !@fields && $c->type ne CHECK_C;
410 if ( $c->type eq PRIMARY_KEY ) {
411 #$name ||= mk_name( $table_name, 'pk' );
412 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
413 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
415 elsif ( $c->type eq UNIQUE ) {
416 # Don't create UNIQUE constraints identical to the primary key
417 if ( my $pk = $table->primary_key ) {
418 my $u_fields = join(":", @fields);
419 my $pk_fields = join(":", $pk->fields);
420 next if $u_fields eq $pk_fields;
423 $name ||= mk_name( $name || $table_name, 'u' );
425 for my $f ( $c->fields ) {
426 my $field_def = $table->get_field( $f ) or next;
427 my $dtype = $translate{ $field_def->data_type } or next;
428 if ( $WARN && $dtype =~ /clob/i ) {
429 warn "Oracle will not allow UNIQUE constraints on " .
430 "CLOB field '" . $field_def->table->name . '.' .
431 $field_def->name . ".'\n"
435 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
436 '(' . join( ', ', @fields ) . ')';
438 elsif ( $c->type eq CHECK_C ) {
439 $name ||= mk_name( $name || $table_name, 'ck' );
440 my $expression = $c->expression || '';
441 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
443 elsif ( $c->type eq FOREIGN_KEY ) {
444 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
445 my $def = "CONSTRAINT $name FOREIGN KEY ";
448 $def .= '(' . join( ', ', @fields ) . ')';
451 my $ref_table = unreserve($c->reference_table);
453 $def .= " REFERENCES $ref_table";
456 $def .= ' (' . join( ', ', @rfields ) . ')';
459 if ( $c->match_type ) {
461 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
464 if ( $c->on_delete ) {
465 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
468 # disabled by plu 2007-12-29 - doesn't exist for oracle
469 #if ( $c->on_update ) {
470 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
473 push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
481 for my $index ( $table->get_indices ) {
482 my $index_name = $index->name || '';
483 my $index_type = $index->type || NORMAL;
484 my @fields = map { unreserve( $_, $table_name ) }
489 for my $opt ( $index->options ) {
490 if ( ref $opt eq 'HASH' ) {
491 my ( $key, $value ) = each %$opt;
492 if ( ref $value eq 'ARRAY' ) {
493 push @table_options, "$key\n(\n". join ("\n",
494 map { " $_->[0]\t$_->[1]" }
499 elsif ( !defined $value ) {
500 push @index_options, $key;
503 push @index_options, "$key $value";
507 my $index_options = @index_options
508 ? "\n".join("\n", @index_options) : '';
510 if ( $index_type eq PRIMARY_KEY ) {
511 $index_name = $index_name ? mk_name( $index_name )
512 : mk_name( $table_name, 'pk' );
513 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
514 '(' . join( ', ', @fields ) . ')';
516 elsif ( $index_type eq NORMAL ) {
517 $index_name = $index_name ? mk_name( $index_name )
518 : mk_name( $table_name, $index_name || 'i' );
520 "CREATE INDEX $index_name on $table_name_ur (".
521 join( ', ', @fields ).
524 elsif ( $index_type eq UNIQUE ) {
525 $index_name = $index_name ? mk_name( $index_name )
526 : mk_name( $table_name, $index_name || 'i' );
528 "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
529 join( ', ', @fields ).
533 warn "Unknown index type ($index_type) on table $table_name.\n"
538 if ( my @table_comments = $table->comments ) {
539 for my $comment ( @table_comments ) {
540 next unless $comment;
541 $comment =~ s/'/''/g;
542 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
543 $comment . "';" unless $options->{no_comments}
548 my $table_options = @table_options
549 ? "\n".join("\n", @table_options) : '';
550 push @create, "CREATE TABLE $table_name_ur (\n" .
551 join( ",\n", map { " $_" } @field_defs,
552 ($options->{delay_constraints} ? () : @constraint_defs) ) .
553 "\n)$table_options;";
555 @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_ }
560 warn "Truncated " . keys( %truncated ) . " names:\n";
561 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
565 warn "Encounted " . keys( %unreserve ) .
566 " unsafe names in schema (reserved or invalid):\n";
567 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
571 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
577 my $out = sprintf("CREATE VIEW %s AS\n%s;",
584 # -------------------------------------------------------------------
586 my $basename = shift || '';
587 my $type = shift || '';
588 $type = '' if $type =~ /^\d/;
589 my $scope = shift || '';
590 my $critical = shift || '';
591 my $basename_orig = $basename;
593 ? $max_id_length - (length($type) + 1)
595 $basename = substr( $basename, 0, $max_name )
596 if length( $basename ) > $max_name;
597 my $name = $type ? "${type}_$basename" : $basename;
599 if ( $basename ne $basename_orig and $critical ) {
600 my $show_type = $type ? "+'$type'" : "";
601 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
602 "character limit to make '$name'\n" if $WARN;
603 $truncated{ $basename_orig } = $name;
606 $scope ||= \%global_names;
607 if ( my $prev = $scope->{ $name } ) {
608 my $name_orig = $name;
609 substr($name, $max_id_length - 2) = ""
610 if length( $name ) >= $max_id_length - 1;
611 $name .= sprintf( "%02d", $prev++ );
613 warn "The name '$name_orig' has been changed to ",
614 "'$name' to make it unique.\n" if $WARN;
616 $scope->{ $name_orig }++;
623 # -------------------------------------------------------------------
625 my $name = shift || '';
626 my $schema_obj_name = shift || '';
628 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
630 # also trap fields that don't begin with a letter
631 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
633 if ( $schema_obj_name ) {
634 ++$unreserve{"$schema_obj_name.$name"};
637 ++$unreserve{"$name (table name)"};
640 my $unreserve = sprintf '%s_', $name;
641 return $unreserve.$suffix;
646 # -------------------------------------------------------------------
647 # All bad art is the result of good intentions.
649 # -------------------------------------------------------------------
655 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
660 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
664 SQL::Translator, DDL::Oracle, mysql2ora.