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);
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 ) = 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;
186 foreach my $view ( $schema->get_views ) {
187 push @view_defs, create_view($view);
190 return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs) : $create . join ("\n\n", @table_defs, @view_defs, @fk_defs, @trigger_defs);
194 my ($table, $options) = @_;
195 my $table_name = $table->name;
199 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
201 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
202 push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};
204 my $table_name_ur = unreserve($table_name) or next;
206 my ( %field_name_scope, @field_comments );
207 for my $field ( $table->get_fields ) {
211 my $field_name = mk_name(
212 $field->name, '', \%field_name_scope, 1
214 my $field_name_ur = unreserve( $field_name, $table_name );
215 my $field_def = $field_name_ur;
216 $field->name( $field_name_ur );
222 my $data_type = lc $field->data_type;
223 my @size = $field->size;
224 my %extra = $field->extra;
225 my $list = $extra{'list'} || [];
226 # \todo deal with embedded quotes
227 my $commalist = join( ', ', map { qq['$_'] } @$list );
229 if ( $data_type eq 'enum' ) {
230 $check = "CHECK ($field_name_ur IN ($commalist))";
231 $data_type = 'varchar2';
233 elsif ( $data_type eq 'set' ) {
234 # XXX add a CHECK constraint maybe
235 # (trickier and slower, than enum :)
236 $data_type = 'varchar2';
239 $data_type = defined $translate{ $data_type } ?
240 $translate{ $data_type } :
242 $data_type ||= 'varchar2';
246 # Fixes ORA-02329: column of datatype LOB cannot be
247 # unique or a primary key
249 if ( $data_type eq 'clob' && $field->is_primary_key ) {
250 $data_type = 'varchar2';
252 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
256 if ( $data_type eq 'clob' && $field->is_unique ) {
257 $data_type = 'varchar2';
259 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
264 # Fixes ORA-00907: missing right parenthesis
266 if ( $data_type =~ /(date|clob)/i ) {
270 $field_def .= " $data_type";
271 if ( defined $size[0] && $size[0] > 0 ) {
272 $field_def .= '(' . join( ', ', @size ) . ')';
278 my $default = $field->default_value;
279 if ( defined $default ) {
281 # Wherein we try to catch a string being used as
282 # a default value for a numerical field. If "true/false,"
283 # then sub "1/0," otherwise just test the truthity of the
284 # argument and use that (naive?).
287 $data_type =~ /^number$/i &&
288 $default !~ /^-?\d+$/ &&
291 if ( $default =~ /^true$/i ) {
294 elsif ( $default =~ /^false$/i ) {
298 $default = $default ? "'1'" : "'0'";
302 $data_type =~ /date/ && (
303 $default eq 'current_timestamp'
308 $default = 'SYSDATE';
311 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
314 $field_def .= " DEFAULT $default",
318 # Not null constraint
320 unless ( $field->is_nullable ) {
321 $field_def .= ' NOT NULL';
324 $field_def .= " $check" if $check;
329 if ( $field->is_auto_increment ) {
330 my $base_name = $table_name_ur . "_". $field_name;
331 my $seq_name = mk_name( $base_name, 'sq' );
332 my $trigger_name = mk_name( $base_name, 'ai' );
334 push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
335 push @create, "CREATE SEQUENCE $seq_name;";
337 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
338 "BEFORE INSERT ON $table_name_ur\n" .
339 "FOR EACH ROW WHEN (\n" .
340 " new.$field_name_ur IS NULL".
341 " OR new.$field_name_ur = 0\n".
344 " SELECT $seq_name.nextval\n" .
345 " INTO :new." . $field->name."\n" .
351 if ( lc $field->data_type eq 'timestamp' ) {
352 my $base_name = $table_name_ur . "_". $field_name_ur;
353 my $trig_name = mk_name( $base_name, 'ts' );
355 "CREATE OR REPLACE TRIGGER $trig_name\n".
356 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
357 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
359 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
363 push @field_defs, $field_def;
365 if ( my $comment = $field->comments ) {
366 $comment =~ s/'/''/g;
367 push @field_comments,
368 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
369 $comment . "';" unless $options->{no_comments};
377 for my $opt ( $table->options ) {
378 if ( ref $opt eq 'HASH' ) {
379 my ( $key, $value ) = each %$opt;
380 if ( ref $value eq 'ARRAY' ) {
381 push @table_options, "$key\n(\n". join ("\n",
382 map { " $_->[0]\t$_->[1]" }
387 elsif ( !defined $value ) {
388 push @table_options, $key;
391 push @table_options, "$key $value";
399 for my $c ( $table->get_constraints ) {
400 my $name = $c->name || '';
401 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
402 my @rfields = map { unreserve( $_, $table_name ) }
403 $c->reference_fields;
404 next if !@fields && $c->type ne CHECK_C;
406 if ( $c->type eq PRIMARY_KEY ) {
407 #$name ||= mk_name( $table_name, 'pk' );
408 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
409 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
411 elsif ( $c->type eq UNIQUE ) {
412 # Don't create UNIQUE constraints identical to the primary key
413 if ( my $pk = $table->primary_key ) {
414 my $u_fields = join(":", @fields);
415 my $pk_fields = join(":", $pk->fields);
416 next if $u_fields eq $pk_fields;
419 $name ||= mk_name( $name || $table_name, 'u' );
421 for my $f ( $c->fields ) {
422 my $field_def = $table->get_field( $f ) or next;
423 my $dtype = $translate{ $field_def->data_type } or next;
424 if ( $WARN && $dtype =~ /clob/i ) {
425 warn "Oracle will not allow UNIQUE constraints on " .
426 "CLOB field '" . $field_def->table->name . '.' .
427 $field_def->name . ".'\n"
431 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
432 '(' . join( ', ', @fields ) . ')';
434 elsif ( $c->type eq CHECK_C ) {
435 $name ||= mk_name( $name || $table_name, 'ck' );
436 my $expression = $c->expression || '';
437 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
439 elsif ( $c->type eq FOREIGN_KEY ) {
440 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
441 my $def = "CONSTRAINT $name FOREIGN KEY ";
444 $def .= '(' . join( ', ', @fields ) . ')';
447 my $ref_table = unreserve($c->reference_table);
449 $def .= " REFERENCES $ref_table";
452 $def .= ' (' . join( ', ', @rfields ) . ')';
455 if ( $c->match_type ) {
457 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
460 if ( $c->on_delete ) {
461 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
464 # disabled by plu 2007-12-29 - doesn't exist for oracle
465 #if ( $c->on_update ) {
466 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
469 push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
477 for my $index ( $table->get_indices ) {
478 my $index_name = $index->name || '';
479 my $index_type = $index->type || NORMAL;
480 my @fields = map { unreserve( $_, $table_name ) }
484 if ( $index_type eq PRIMARY_KEY ) {
485 $index_name = $index_name ? mk_name( $index_name )
486 : mk_name( $table_name, 'pk' );
487 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
488 '(' . join( ', ', @fields ) . ')';
490 elsif ( $index_type eq NORMAL ) {
491 $index_name = $index_name ? mk_name( $index_name )
492 : mk_name( $table_name, $index_name || 'i' );
494 "CREATE INDEX $index_name on $table_name_ur (".
495 join( ', ', @fields ).
499 warn "Unknown index type ($index_type) on table $table_name.\n"
504 if ( my @table_comments = $table->comments ) {
505 for my $comment ( @table_comments ) {
506 next unless $comment;
507 $comment =~ s/'/''/g;
508 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
509 $comment . "';" unless $options->{no_comments}
514 my $table_options = @table_options
515 ? "\n".join("\n", @table_options) : '';
516 push @create, "CREATE TABLE $table_name_ur (\n" .
517 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
518 "\n)$table_options;";
522 warn "Truncated " . keys( %truncated ) . " names:\n";
523 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
527 warn "Encounted " . keys( %unreserve ) .
528 " unsafe names in schema (reserved or invalid):\n";
529 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
533 return \@create, \@fk_defs, \@trigger_defs;
539 my $out = sprintf("CREATE VIEW %s AS\n%s;",
546 # -------------------------------------------------------------------
548 my $basename = shift || '';
549 my $type = shift || '';
550 $type = '' if $type =~ /^\d/;
551 my $scope = shift || '';
552 my $critical = shift || '';
553 my $basename_orig = $basename;
555 ? $max_id_length - (length($type) + 1)
557 $basename = substr( $basename, 0, $max_name )
558 if length( $basename ) > $max_name;
559 my $name = $type ? "${type}_$basename" : $basename;
561 if ( $basename ne $basename_orig and $critical ) {
562 my $show_type = $type ? "+'$type'" : "";
563 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
564 "character limit to make '$name'\n" if $WARN;
565 $truncated{ $basename_orig } = $name;
568 $scope ||= \%global_names;
569 if ( my $prev = $scope->{ $name } ) {
570 my $name_orig = $name;
571 substr($name, $max_id_length - 2) = ""
572 if length( $name ) >= $max_id_length - 1;
573 $name .= sprintf( "%02d", $prev++ );
575 warn "The name '$name_orig' has been changed to ",
576 "'$name' to make it unique.\n" if $WARN;
578 $scope->{ $name_orig }++;
585 # -------------------------------------------------------------------
587 my $name = shift || '';
588 my $schema_obj_name = shift || '';
590 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
592 # also trap fields that don't begin with a letter
593 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
595 if ( $schema_obj_name ) {
596 ++$unreserve{"$schema_obj_name.$name"};
599 ++$unreserve{"$name (table name)"};
602 my $unreserve = sprintf '%s_', $name;
603 return $unreserve.$suffix;
608 # -------------------------------------------------------------------
609 # All bad art is the result of good intentions.
611 # -------------------------------------------------------------------
617 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
622 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
626 SQL::Translator, DDL::Oracle, mysql2ora.