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 ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs);
159 $create .= header_comment unless ($no_comments);
161 if ( $translator->parser_type =~ /mysql/i ) {
163 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
164 "-- but we set it here anyway to be self-consistent.\n"
168 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
171 for my $table ( $schema->get_tables ) {
172 my ( $table_def, $fk_def, $trigger_def, $index_def) = create_table(
175 add_drop_table => $add_drop_table,
176 show_warnings => $WARN,
177 no_comments => $no_comments,
180 push @table_defs, @$table_def;
181 push @fk_defs, @$fk_def;
182 push @trigger_defs, @$trigger_def;
183 push @index_defs, @$index_def;
187 foreach my $view ( $schema->get_views ) {
188 push @view_defs, create_view($view);
191 return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs) : $create . join ("\n\n", @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, '');
195 my ($table, $options) = @_;
196 my $table_name = $table->name;
200 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
202 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
203 push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};
205 my $table_name_ur = unreserve($table_name) or next;
207 my ( %field_name_scope, @field_comments );
208 for my $field ( $table->get_fields ) {
212 my $field_name = mk_name(
213 $field->name, '', \%field_name_scope, 1
215 my $field_name_ur = unreserve( $field_name, $table_name );
216 my $field_def = $field_name_ur;
217 $field->name( $field_name_ur );
223 my $data_type = lc $field->data_type;
224 my @size = $field->size;
225 my %extra = $field->extra;
226 my $list = $extra{'list'} || [];
227 # \todo deal with embedded quotes
228 my $commalist = join( ', ', map { qq['$_'] } @$list );
230 if ( $data_type eq 'enum' ) {
231 $check = "CHECK ($field_name_ur IN ($commalist))";
232 $data_type = 'varchar2';
234 elsif ( $data_type eq 'set' ) {
235 # XXX add a CHECK constraint maybe
236 # (trickier and slower, than enum :)
237 $data_type = 'varchar2';
240 $data_type = defined $translate{ $data_type } ?
241 $translate{ $data_type } :
243 $data_type ||= 'varchar2';
247 # Fixes ORA-02329: column of datatype LOB cannot be
248 # unique or a primary key
250 if ( $data_type eq 'clob' && $field->is_primary_key ) {
251 $data_type = 'varchar2';
253 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
257 if ( $data_type eq 'clob' && $field->is_unique ) {
258 $data_type = 'varchar2';
260 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
265 # Fixes ORA-00907: missing right parenthesis
267 if ( $data_type =~ /(date|clob)/i ) {
271 $field_def .= " $data_type";
272 if ( defined $size[0] && $size[0] > 0 ) {
273 $field_def .= '(' . join( ', ', @size ) . ')';
279 my $default = $field->default_value;
280 if ( defined $default ) {
282 # Wherein we try to catch a string being used as
283 # a default value for a numerical field. If "true/false,"
284 # then sub "1/0," otherwise just test the truthity of the
285 # argument and use that (naive?).
288 $data_type =~ /^number$/i &&
289 $default !~ /^-?\d+$/ &&
292 if ( $default =~ /^true$/i ) {
295 elsif ( $default =~ /^false$/i ) {
299 $default = $default ? "'1'" : "'0'";
303 $data_type =~ /date/ && (
304 $default eq 'current_timestamp'
309 $default = 'SYSDATE';
312 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
315 $field_def .= " DEFAULT $default",
319 # Not null constraint
321 unless ( $field->is_nullable ) {
322 $field_def .= ' NOT NULL';
325 $field_def .= " $check" if $check;
330 if ( $field->is_auto_increment ) {
331 my $base_name = $table_name_ur . "_". $field_name;
332 my $seq_name = mk_name( $base_name, 'sq' );
333 my $trigger_name = mk_name( $base_name, 'ai' );
335 push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
336 push @create, "CREATE SEQUENCE $seq_name;";
338 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
339 "BEFORE INSERT ON $table_name_ur\n" .
340 "FOR EACH ROW WHEN (\n" .
341 " new.$field_name_ur IS NULL".
342 " OR new.$field_name_ur = 0\n".
345 " SELECT $seq_name.nextval\n" .
346 " INTO :new." . $field->name."\n" .
352 if ( lc $field->data_type eq 'timestamp' ) {
353 my $base_name = $table_name_ur . "_". $field_name_ur;
354 my $trig_name = mk_name( $base_name, 'ts' );
356 "CREATE OR REPLACE TRIGGER $trig_name\n".
357 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
358 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
360 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
364 push @field_defs, $field_def;
366 if ( my $comment = $field->comments ) {
367 $comment =~ s/'/''/g;
368 push @field_comments,
369 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
370 $comment . "';" unless $options->{no_comments};
378 for my $opt ( $table->options ) {
379 if ( ref $opt eq 'HASH' ) {
380 my ( $key, $value ) = each %$opt;
381 if ( ref $value eq 'ARRAY' ) {
382 push @table_options, "$key\n(\n". join ("\n",
383 map { " $_->[0]\t$_->[1]" }
388 elsif ( !defined $value ) {
389 push @table_options, $key;
392 push @table_options, "$key $value";
400 for my $c ( $table->get_constraints ) {
401 my $name = $c->name || '';
402 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
403 my @rfields = map { unreserve( $_, $table_name ) }
404 $c->reference_fields;
405 next if !@fields && $c->type ne CHECK_C;
407 if ( $c->type eq PRIMARY_KEY ) {
408 #$name ||= mk_name( $table_name, 'pk' );
409 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
410 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
412 elsif ( $c->type eq UNIQUE ) {
413 # Don't create UNIQUE constraints identical to the primary key
414 if ( my $pk = $table->primary_key ) {
415 my $u_fields = join(":", @fields);
416 my $pk_fields = join(":", $pk->fields);
417 next if $u_fields eq $pk_fields;
420 $name ||= mk_name( $name || $table_name, 'u' );
422 for my $f ( $c->fields ) {
423 my $field_def = $table->get_field( $f ) or next;
424 my $dtype = $translate{ $field_def->data_type } or next;
425 if ( $WARN && $dtype =~ /clob/i ) {
426 warn "Oracle will not allow UNIQUE constraints on " .
427 "CLOB field '" . $field_def->table->name . '.' .
428 $field_def->name . ".'\n"
432 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
433 '(' . join( ', ', @fields ) . ')';
435 elsif ( $c->type eq CHECK_C ) {
436 $name ||= mk_name( $name || $table_name, 'ck' );
437 my $expression = $c->expression || '';
438 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
440 elsif ( $c->type eq FOREIGN_KEY ) {
441 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
442 my $def = "CONSTRAINT $name FOREIGN KEY ";
445 $def .= '(' . join( ', ', @fields ) . ')';
448 my $ref_table = unreserve($c->reference_table);
450 $def .= " REFERENCES $ref_table";
453 $def .= ' (' . join( ', ', @rfields ) . ')';
456 if ( $c->match_type ) {
458 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
461 if ( $c->on_delete ) {
462 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
465 # disabled by plu 2007-12-29 - doesn't exist for oracle
466 #if ( $c->on_update ) {
467 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
470 push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
478 for my $index ( $table->get_indices ) {
479 my $index_name = $index->name || '';
480 my $index_type = $index->type || NORMAL;
481 my @fields = map { unreserve( $_, $table_name ) }
486 for my $opt ( $index->options ) {
487 if ( ref $opt eq 'HASH' ) {
488 my ( $key, $value ) = each %$opt;
489 if ( ref $value eq 'ARRAY' ) {
490 push @table_options, "$key\n(\n". join ("\n",
491 map { " $_->[0]\t$_->[1]" }
496 elsif ( !defined $value ) {
497 push @index_options, $key;
500 push @index_options, "$key $value";
504 my $index_options = @index_options
505 ? "\n".join("\n", @index_options) : '';
507 if ( $index_type eq PRIMARY_KEY ) {
508 $index_name = $index_name ? mk_name( $index_name )
509 : mk_name( $table_name, 'pk' );
510 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
511 '(' . join( ', ', @fields ) . ')';
513 elsif ( $index_type eq NORMAL ) {
514 $index_name = $index_name ? mk_name( $index_name )
515 : mk_name( $table_name, $index_name || 'i' );
517 "CREATE INDEX $index_name on $table_name_ur (".
518 join( ', ', @fields ).
521 elsif ( $index_type eq UNIQUE ) {
522 $index_name = $index_name ? mk_name( $index_name )
523 : mk_name( $table_name, $index_name || 'i' );
525 "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
526 join( ', ', @fields ).
530 warn "Unknown index type ($index_type) on table $table_name.\n"
535 if ( my @table_comments = $table->comments ) {
536 for my $comment ( @table_comments ) {
537 next unless $comment;
538 $comment =~ s/'/''/g;
539 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
540 $comment . "';" unless $options->{no_comments}
545 my $table_options = @table_options
546 ? "\n".join("\n", @table_options) : '';
547 push @create, "CREATE TABLE $table_name_ur (\n" .
548 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
549 "\n)$table_options;";
553 warn "Truncated " . keys( %truncated ) . " names:\n";
554 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
558 warn "Encounted " . keys( %unreserve ) .
559 " unsafe names in schema (reserved or invalid):\n";
560 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
564 return \@create, \@fk_defs, \@trigger_defs, \@index_defs;
570 my $out = sprintf("CREATE VIEW %s AS\n%s;",
577 # -------------------------------------------------------------------
579 my $basename = shift || '';
580 my $type = shift || '';
581 $type = '' if $type =~ /^\d/;
582 my $scope = shift || '';
583 my $critical = shift || '';
584 my $basename_orig = $basename;
586 ? $max_id_length - (length($type) + 1)
588 $basename = substr( $basename, 0, $max_name )
589 if length( $basename ) > $max_name;
590 my $name = $type ? "${type}_$basename" : $basename;
592 if ( $basename ne $basename_orig and $critical ) {
593 my $show_type = $type ? "+'$type'" : "";
594 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
595 "character limit to make '$name'\n" if $WARN;
596 $truncated{ $basename_orig } = $name;
599 $scope ||= \%global_names;
600 if ( my $prev = $scope->{ $name } ) {
601 my $name_orig = $name;
602 substr($name, $max_id_length - 2) = ""
603 if length( $name ) >= $max_id_length - 1;
604 $name .= sprintf( "%02d", $prev++ );
606 warn "The name '$name_orig' has been changed to ",
607 "'$name' to make it unique.\n" if $WARN;
609 $scope->{ $name_orig }++;
616 # -------------------------------------------------------------------
618 my $name = shift || '';
619 my $schema_obj_name = shift || '';
621 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
623 # also trap fields that don't begin with a letter
624 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
626 if ( $schema_obj_name ) {
627 ++$unreserve{"$schema_obj_name.$name"};
630 ++$unreserve{"$name (table name)"};
633 my $unreserve = sprintf '%s_', $name;
634 return $unreserve.$suffix;
639 # -------------------------------------------------------------------
640 # All bad art is the result of good intentions.
642 # -------------------------------------------------------------------
648 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
653 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
657 SQL::Translator, DDL::Oracle, mysql2ora.