1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.31 2004-06-04 19:39:48 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.31 $ =~ /(\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 push @field_comments,
335 "COMMENT ON COLUMN $table_name.$field_name_ur is\n '".
336 $comment."';" unless $no_comments;
344 for my $opt ( $table->options ) {
345 if ( ref $opt eq 'HASH' ) {
346 my ( $key, $value ) = each %$opt;
347 if ( ref $value eq 'ARRAY' ) {
348 push @table_options, "$key\n(\n". join ("\n",
349 map { " $_->[0]\t$_->[1]" }
354 elsif ( !defined $value ) {
355 push @table_options, $key;
358 push @table_options, "$key $value";
366 for my $c ( $table->get_constraints ) {
367 my $name = $c->name || '';
368 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
369 my @rfields = map { unreserve( $_, $table_name ) }
370 $c->reference_fields;
371 next if !@fields && $c->type ne CHECK_C;
373 if ( $c->type eq PRIMARY_KEY ) {
374 $name ||= mk_name( $table_name, 'pk' );
375 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
376 '(' . join( ', ', @fields ) . ')';
378 elsif ( $c->type eq UNIQUE ) {
379 $name = mk_name( $name || $table_name, 'u' );
381 for my $f ( $c->fields ) {
382 my $field_def = $table->get_field( $f ) or next;
383 my $dtype = $translate{ $field_def->data_type } or next;
384 if ( $WARN && $dtype =~ /clob/i ) {
385 warn "Oracle will not allow UNIQUE constraints on " .
386 "CLOB field '" . $field_def->table->name . '.' .
387 $field_def->name . ".'\n"
391 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
392 '(' . join( ', ', @fields ) . ')';
394 elsif ( $c->type eq CHECK_C ) {
395 $name = mk_name( $name || $table_name, 'ck' );
396 my $expression = $c->expression || '';
397 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
399 elsif ( $c->type eq FOREIGN_KEY ) {
400 $name = mk_name( join('_', $table_name, $c->fields), 'fk' );
401 my $def = "CONSTRAINT $name FOREIGN KEY ";
404 $def .= '(' . join( ', ', @fields ) . ')';
407 my $ref_table = unreserve($c->reference_table);
409 $def .= " REFERENCES $ref_table";
412 $def .= ' (' . join( ', ', @rfields ) . ')';
415 if ( $c->match_type ) {
417 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
420 if ( $c->on_delete ) {
421 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
424 if ( $c->on_update ) {
425 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
428 push @constraint_defs, $def;
436 for my $index ( $table->get_indices ) {
437 my $index_name = $index->name || '';
438 my $index_type = $index->type || NORMAL;
439 my @fields = map { unreserve( $_, $table_name ) }
443 if ( $index_type eq PRIMARY_KEY ) {
444 $index_name = $index_name ? mk_name( $index_name )
445 : mk_name( $table_name, 'pk' );
446 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
447 '(' . join( ', ', @fields ) . ')';
449 elsif ( $index_type eq NORMAL ) {
450 $index_name = $index_name ? mk_name( $index_name )
451 : mk_name( $table_name, $index_name || 'i' );
453 "CREATE INDEX $index_name on $table_name_ur (".
454 join( ', ', @fields ).
458 warn "Unknown index type ($index_type) on table $table_name.\n"
463 my $create_statement;
464 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
466 if ( my @table_comments = $table->comments ) {
467 for my $comment ( @table_comments ) {
468 next unless $comment;
469 push @field_comments, "COMMENT ON TABLE $table_name is\n '".
470 $comment."';" unless $no_comments
475 my $table_options = @table_options
476 ? "\n".join("\n", @table_options) : '';
477 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
478 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
482 $output .= join( "\n\n",
494 warn "Truncated " . keys( %truncated ) . " names:\n";
495 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
499 warn "Encounted " . keys( %unreserve ) .
500 " unsafe names in schema (reserved or invalid):\n";
501 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
508 # -------------------------------------------------------------------
510 my $basename = shift || '';
511 my $type = shift || '';
512 $type = '' if $type =~ /^\d/;
513 my $scope = shift || '';
514 my $critical = shift || '';
515 my $basename_orig = $basename;
517 ? $max_id_length - (length($type) + 1)
519 $basename = substr( $basename, 0, $max_name )
520 if length( $basename ) > $max_name;
521 my $name = $type ? "${type}_$basename" : $basename;
523 if ( $basename ne $basename_orig and $critical ) {
524 my $show_type = $type ? "+'$type'" : "";
525 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
526 "character limit to make '$name'\n" if $WARN;
527 $truncated{ $basename_orig } = $name;
530 $scope ||= \%global_names;
531 if ( my $prev = $scope->{ $name } ) {
532 my $name_orig = $name;
533 $name .= sprintf( "%02d", ++$prev );
534 substr($name, $max_id_length - 3) = "00"
535 if length( $name ) > $max_id_length;
537 warn "The name '$name_orig' has been changed to ",
538 "'$name' to make it unique.\n" if $WARN;
540 $scope->{ $name_orig }++;
547 # -------------------------------------------------------------------
549 my $name = shift || '';
550 my $schema_obj_name = shift || '';
552 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
554 # also trap fields that don't begin with a letter
555 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
557 if ( $schema_obj_name ) {
558 ++$unreserve{"$schema_obj_name.$name"};
561 ++$unreserve{"$name (table name)"};
564 my $unreserve = sprintf '%s_', $name;
565 return $unreserve.$suffix;
570 # -------------------------------------------------------------------
571 # All bad art is the result of good intentions.
573 # -------------------------------------------------------------------
579 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
584 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
588 SQL::Translator, DDL::Oracle, mysql2ora.