1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.32 2004-12-20 17:18:42 kycl4rk 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.32 $ =~ /(\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;
198 my $data_type = lc $field->data_type;
199 my @size = $field->size;
200 my %extra = $field->extra;
201 my $list = $extra{'list'} || [];
202 # \todo deal with embedded quotes
203 my $commalist = join( ', ', map { qq['$_'] } @$list );
205 if ( $data_type eq 'enum' ) {
206 $check = "CHECK ($field_name_ur IN ($commalist))";
207 $data_type = 'varchar2';
209 elsif ( $data_type eq 'set' ) {
210 # XXX add a CHECK constraint maybe
211 # (trickier and slower, than enum :)
212 $data_type = 'varchar2';
215 $data_type = defined $translate{ $data_type } ?
216 $translate{ $data_type } :
218 $data_type ||= 'varchar2';
222 # Fixes ORA-02329: column of datatype LOB cannot be
223 # unique or a primary key
225 if ( $data_type eq 'clob' && $field->is_primary_key ) {
226 $data_type = 'varchar2';
228 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
233 # Fixes ORA-00907: missing right parenthesis
235 if ( $data_type =~ /(date|clob)/i ) {
239 $field_def .= " $data_type";
240 if ( defined $size[0] && $size[0] > 0 ) {
241 $field_def .= '(' . join( ', ', @size ) . ')';
247 my $default = $field->default_value;
248 if ( defined $default ) {
250 # Wherein we try to catch a string being used as
251 # a default value for a numerical field. If "true/false,"
252 # then sub "1/0," otherwise just test the truthity of the
253 # argument and use that (naive?).
256 $data_type =~ /^number$/i &&
257 $default !~ /^\d+$/ &&
260 if ( $default =~ /^true$/i ) {
263 elsif ( $default =~ /^false$/i ) {
267 $default = $default ? "'1'" : "'0'";
271 $data_type =~ /date/ && (
272 $default eq 'current_timestamp'
277 $default = 'SYSDATE';
280 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
283 $field_def .= " DEFAULT $default",
287 # Not null constraint
289 unless ( $field->is_nullable ) {
290 $field_def .= ' NOT NULL';
293 $field_def .= " $check" if $check;
298 if ( $field->is_auto_increment ) {
299 my $base_name = $table_name . "_". $field_name;
300 my $seq_name = mk_name( $base_name, 'sq' );
301 my $trigger_name = mk_name( $base_name, 'ai' );
304 "CREATE SEQUENCE $seq_name;\n" .
305 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
306 "BEFORE INSERT ON $table_name_ur\n" .
307 "FOR EACH ROW WHEN (\n" .
308 " new.$field_name_ur IS NULL".
309 " OR new.$field_name_ur = 0\n".
312 " SELECT $seq_name.nextval\n" .
313 " INTO :new." . $field->name."\n" .
319 if ( lc $field->data_type eq 'timestamp' ) {
320 my $base_name = $table_name . "_". $field_name_ur;
321 my $trig_name = mk_name( $base_name, 'ts' );
323 "CREATE OR REPLACE TRIGGER $trig_name\n".
324 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
325 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
327 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
331 push @field_defs, $field_def;
333 if ( my $comment = $field->comments ) {
334 $comment =~ s/'/''/g;
335 push @field_comments,
336 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
337 $comment . "';" unless $no_comments;
345 for my $opt ( $table->options ) {
346 if ( ref $opt eq 'HASH' ) {
347 my ( $key, $value ) = each %$opt;
348 if ( ref $value eq 'ARRAY' ) {
349 push @table_options, "$key\n(\n". join ("\n",
350 map { " $_->[0]\t$_->[1]" }
355 elsif ( !defined $value ) {
356 push @table_options, $key;
359 push @table_options, "$key $value";
367 for my $c ( $table->get_constraints ) {
368 my $name = $c->name || '';
369 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
370 my @rfields = map { unreserve( $_, $table_name ) }
371 $c->reference_fields;
372 next if !@fields && $c->type ne CHECK_C;
374 if ( $c->type eq PRIMARY_KEY ) {
375 $name ||= mk_name( $table_name, 'pk' );
376 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
377 '(' . join( ', ', @fields ) . ')';
379 elsif ( $c->type eq UNIQUE ) {
380 $name = mk_name( $name || $table_name, 'u' );
382 for my $f ( $c->fields ) {
383 my $field_def = $table->get_field( $f ) or next;
384 my $dtype = $translate{ $field_def->data_type } or next;
385 if ( $WARN && $dtype =~ /clob/i ) {
386 warn "Oracle will not allow UNIQUE constraints on " .
387 "CLOB field '" . $field_def->table->name . '.' .
388 $field_def->name . ".'\n"
392 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
393 '(' . join( ', ', @fields ) . ')';
395 elsif ( $c->type eq CHECK_C ) {
396 $name = mk_name( $name || $table_name, 'ck' );
397 my $expression = $c->expression || '';
398 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
400 elsif ( $c->type eq FOREIGN_KEY ) {
401 $name = mk_name( join('_', $table_name, $c->fields), 'fk' );
402 my $def = "CONSTRAINT $name FOREIGN KEY ";
405 $def .= '(' . join( ', ', @fields ) . ')';
408 my $ref_table = unreserve($c->reference_table);
410 $def .= " REFERENCES $ref_table";
413 $def .= ' (' . join( ', ', @rfields ) . ')';
416 if ( $c->match_type ) {
418 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
421 if ( $c->on_delete ) {
422 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
425 if ( $c->on_update ) {
426 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
429 push @constraint_defs, $def;
437 for my $index ( $table->get_indices ) {
438 my $index_name = $index->name || '';
439 my $index_type = $index->type || NORMAL;
440 my @fields = map { unreserve( $_, $table_name ) }
444 if ( $index_type eq PRIMARY_KEY ) {
445 $index_name = $index_name ? mk_name( $index_name )
446 : mk_name( $table_name, 'pk' );
447 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
448 '(' . join( ', ', @fields ) . ')';
450 elsif ( $index_type eq NORMAL ) {
451 $index_name = $index_name ? mk_name( $index_name )
452 : mk_name( $table_name, $index_name || 'i' );
454 "CREATE INDEX $index_name on $table_name_ur (".
455 join( ', ', @fields ).
459 warn "Unknown index type ($index_type) on table $table_name.\n"
464 my $create_statement;
465 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
467 if ( my @table_comments = $table->comments ) {
468 for my $comment ( @table_comments ) {
469 next unless $comment;
470 $comment =~ s/'/''/g;
471 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
472 $comment . "';" unless $no_comments
477 my $table_options = @table_options
478 ? "\n".join("\n", @table_options) : '';
479 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
480 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
484 $output .= join( "\n\n",
496 warn "Truncated " . keys( %truncated ) . " names:\n";
497 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
501 warn "Encounted " . keys( %unreserve ) .
502 " unsafe names in schema (reserved or invalid):\n";
503 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
510 # -------------------------------------------------------------------
512 my $basename = shift || '';
513 my $type = shift || '';
514 $type = '' if $type =~ /^\d/;
515 my $scope = shift || '';
516 my $critical = shift || '';
517 my $basename_orig = $basename;
519 ? $max_id_length - (length($type) + 1)
521 $basename = substr( $basename, 0, $max_name )
522 if length( $basename ) > $max_name;
523 my $name = $type ? "${type}_$basename" : $basename;
525 if ( $basename ne $basename_orig and $critical ) {
526 my $show_type = $type ? "+'$type'" : "";
527 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
528 "character limit to make '$name'\n" if $WARN;
529 $truncated{ $basename_orig } = $name;
532 $scope ||= \%global_names;
533 if ( my $prev = $scope->{ $name } ) {
534 my $name_orig = $name;
535 $name .= sprintf( "%02d", ++$prev );
536 substr($name, $max_id_length - 2) = ""
537 if length( $name ) >= $max_id_length - 1;
538 $name .= sprintf( "%02d", $prev++ );
540 warn "The name '$name_orig' has been changed to ",
541 "'$name' to make it unique.\n" if $WARN;
543 $scope->{ $name_orig }++;
550 # -------------------------------------------------------------------
552 my $name = shift || '';
553 my $schema_obj_name = shift || '';
555 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
557 # also trap fields that don't begin with a letter
558 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
560 if ( $schema_obj_name ) {
561 ++$unreserve{"$schema_obj_name.$name"};
564 ++$unreserve{"$name (table name)"};
567 my $unreserve = sprintf '%s_', $name;
568 return $unreserve.$suffix;
573 # -------------------------------------------------------------------
574 # All bad art is the result of good intentions.
576 # -------------------------------------------------------------------
582 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
587 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
591 SQL::Translator, DDL::Oracle, mysql2ora.