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;
154 my $no_comments = $translator->no_comments;
155 my $add_drop_table = $translator->add_drop_table;
156 my $schema = $translator->schema;
159 $output .= 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";
172 # Print create for each table
174 for my $table ( $schema->get_tables ) {
175 my $table_name = $table->name or next;
176 $table_name = mk_name( $table_name, '', undef, 1 );
177 my $table_name_ur = unreserve($table_name) or next;
179 my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
181 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
183 my ( %field_name_scope, @field_comments );
184 for my $field ( $table->get_fields ) {
188 my $field_name = mk_name(
189 $field->name, '', \%field_name_scope, 1
191 my $field_name_ur = unreserve( $field_name, $table_name );
192 my $field_def = $field_name_ur;
193 $field->name( $field_name_ur );
199 my $data_type = lc $field->data_type;
200 my @size = $field->size;
201 my %extra = $field->extra;
202 my $list = $extra{'list'} || [];
203 # \todo deal with embedded quotes
204 my $commalist = join( ', ', map { qq['$_'] } @$list );
206 if ( $data_type eq 'enum' ) {
207 $check = "CHECK ($field_name_ur IN ($commalist))";
208 $data_type = 'varchar2';
210 elsif ( $data_type eq 'set' ) {
211 # XXX add a CHECK constraint maybe
212 # (trickier and slower, than enum :)
213 $data_type = 'varchar2';
216 $data_type = defined $translate{ $data_type } ?
217 $translate{ $data_type } :
219 $data_type ||= 'varchar2';
223 # Fixes ORA-02329: column of datatype LOB cannot be
224 # unique or a primary key
226 if ( $data_type eq 'clob' && $field->is_primary_key ) {
227 $data_type = 'varchar2';
229 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
233 if ( $data_type eq 'clob' && $field->is_unique ) {
234 $data_type = 'varchar2';
236 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
243 # Fixes ORA-00907: missing right parenthesis
245 if ( $data_type =~ /(date|clob)/i ) {
249 $field_def .= " $data_type";
250 if ( defined $size[0] && $size[0] > 0 ) {
251 $field_def .= '(' . join( ', ', @size ) . ')';
257 my $default = $field->default_value;
258 if ( defined $default ) {
260 # Wherein we try to catch a string being used as
261 # a default value for a numerical field. If "true/false,"
262 # then sub "1/0," otherwise just test the truthity of the
263 # argument and use that (naive?).
266 $data_type =~ /^number$/i &&
267 $default !~ /^-?\d+$/ &&
270 if ( $default =~ /^true$/i ) {
273 elsif ( $default =~ /^false$/i ) {
277 $default = $default ? "'1'" : "'0'";
281 $data_type =~ /date/ && (
282 $default eq 'current_timestamp'
287 $default = 'SYSDATE';
290 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
293 $field_def .= " DEFAULT $default",
297 # Not null constraint
299 unless ( $field->is_nullable ) {
300 $field_def .= ' NOT NULL';
303 $field_def .= " $check" if $check;
308 if ( $field->is_auto_increment ) {
309 my $base_name = $table_name_ur . "_". $field_name;
310 my $seq_name = mk_name( $base_name, 'sq' );
311 my $trigger_name = mk_name( $base_name, 'ai' );
314 "CREATE SEQUENCE $seq_name;\n" .
315 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
316 "BEFORE INSERT ON $table_name_ur\n" .
317 "FOR EACH ROW WHEN (\n" .
318 " new.$field_name_ur IS NULL".
319 " OR new.$field_name_ur = 0\n".
322 " SELECT $seq_name.nextval\n" .
323 " INTO :new." . $field->name."\n" .
329 if ( lc $field->data_type eq 'timestamp' ) {
330 my $base_name = $table_name_ur . "_". $field_name_ur;
331 my $trig_name = mk_name( $base_name, 'ts' );
333 "CREATE OR REPLACE TRIGGER $trig_name\n".
334 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
335 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
337 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
341 push @field_defs, $field_def;
343 if ( my $comment = $field->comments ) {
344 $comment =~ s/'/''/g;
345 push @field_comments,
346 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
347 $comment . "';" unless $no_comments;
355 for my $opt ( $table->options ) {
356 if ( ref $opt eq 'HASH' ) {
357 my ( $key, $value ) = each %$opt;
358 if ( ref $value eq 'ARRAY' ) {
359 push @table_options, "$key\n(\n". join ("\n",
360 map { " $_->[0]\t$_->[1]" }
365 elsif ( !defined $value ) {
366 push @table_options, $key;
369 push @table_options, "$key $value";
377 for my $c ( $table->get_constraints ) {
378 my $name = $c->name || '';
379 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
380 my @rfields = map { unreserve( $_, $table_name ) }
381 $c->reference_fields;
382 next if !@fields && $c->type ne CHECK_C;
384 if ( $c->type eq PRIMARY_KEY ) {
385 #$name ||= mk_name( $table_name, 'pk' );
386 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
387 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
389 elsif ( $c->type eq UNIQUE ) {
390 # Don't create UNIQUE constraints identical to the primary key
391 if ( my $pk = $table->primary_key ) {
392 my $u_fields = join(":", @fields);
393 my $pk_fields = join(":", $pk->fields);
394 next if $u_fields eq $pk_fields;
397 $name ||= mk_name( $name || $table_name, 'u' );
399 for my $f ( $c->fields ) {
400 my $field_def = $table->get_field( $f ) or next;
401 my $dtype = $translate{ $field_def->data_type } or next;
402 if ( $WARN && $dtype =~ /clob/i ) {
403 warn "Oracle will not allow UNIQUE constraints on " .
404 "CLOB field '" . $field_def->table->name . '.' .
405 $field_def->name . ".'\n"
409 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
410 '(' . join( ', ', @fields ) . ')';
412 elsif ( $c->type eq CHECK_C ) {
413 $name ||= mk_name( $name || $table_name, 'ck' );
414 my $expression = $c->expression || '';
415 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
417 elsif ( $c->type eq FOREIGN_KEY ) {
418 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
419 my $def = "CONSTRAINT $name FOREIGN KEY ";
422 $def .= '(' . join( ', ', @fields ) . ')';
425 my $ref_table = unreserve($c->reference_table);
427 $def .= " REFERENCES $ref_table";
430 $def .= ' (' . join( ', ', @rfields ) . ')';
433 if ( $c->match_type ) {
435 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
438 if ( $c->on_delete ) {
439 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
442 if ( $c->on_update ) {
443 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
446 push @constraint_defs, $def;
454 for my $index ( $table->get_indices ) {
455 my $index_name = $index->name || '';
456 my $index_type = $index->type || NORMAL;
457 my @fields = map { unreserve( $_, $table_name ) }
461 if ( $index_type eq PRIMARY_KEY ) {
462 $index_name = $index_name ? mk_name( $index_name )
463 : mk_name( $table_name, 'pk' );
464 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
465 '(' . join( ', ', @fields ) . ')';
467 elsif ( $index_type eq NORMAL ) {
468 $index_name = $index_name ? mk_name( $index_name )
469 : mk_name( $table_name, $index_name || 'i' );
471 "CREATE INDEX $index_name on $table_name_ur (".
472 join( ', ', @fields ).
476 warn "Unknown index type ($index_type) on table $table_name.\n"
481 my $create_statement;
482 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
484 if ( my @table_comments = $table->comments ) {
485 for my $comment ( @table_comments ) {
486 next unless $comment;
487 $comment =~ s/'/''/g;
488 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
489 $comment . "';" unless $no_comments
494 my $table_options = @table_options
495 ? "\n".join("\n", @table_options) : '';
496 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
497 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
501 $output .= join( "\n\n",
513 warn "Truncated " . keys( %truncated ) . " names:\n";
514 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
518 warn "Encounted " . keys( %unreserve ) .
519 " unsafe names in schema (reserved or invalid):\n";
520 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
527 # -------------------------------------------------------------------
529 my $basename = shift || '';
530 my $type = shift || '';
531 $type = '' if $type =~ /^\d/;
532 my $scope = shift || '';
533 my $critical = shift || '';
534 my $basename_orig = $basename;
536 ? $max_id_length - (length($type) + 1)
538 $basename = substr( $basename, 0, $max_name )
539 if length( $basename ) > $max_name;
540 my $name = $type ? "${type}_$basename" : $basename;
542 if ( $basename ne $basename_orig and $critical ) {
543 my $show_type = $type ? "+'$type'" : "";
544 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
545 "character limit to make '$name'\n" if $WARN;
546 $truncated{ $basename_orig } = $name;
549 $scope ||= \%global_names;
550 if ( my $prev = $scope->{ $name } ) {
551 my $name_orig = $name;
552 substr($name, $max_id_length - 2) = ""
553 if length( $name ) >= $max_id_length - 1;
554 $name .= sprintf( "%02d", $prev++ );
556 warn "The name '$name_orig' has been changed to ",
557 "'$name' to make it unique.\n" if $WARN;
559 $scope->{ $name_orig }++;
566 # -------------------------------------------------------------------
568 my $name = shift || '';
569 my $schema_obj_name = shift || '';
571 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
573 # also trap fields that don't begin with a letter
574 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
576 if ( $schema_obj_name ) {
577 ++$unreserve{"$schema_obj_name.$name"};
580 ++$unreserve{"$name (table name)"};
583 my $unreserve = sprintf '%s_', $name;
584 return $unreserve.$suffix;
589 # -------------------------------------------------------------------
590 # All bad art is the result of good intentions.
592 # -------------------------------------------------------------------
598 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
603 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
607 SQL::Translator, DDL::Oracle, mysql2ora.