1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.30 2004-02-09 23:02:15 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.30 $ =~ /(\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( $table_name, 'u' );
380 for my $f ( $c->fields ) {
381 my $field_def = $table->get_field( $f ) or next;
382 my $dtype = $translate{ $field_def->data_type } or next;
383 if ( $WARN && $dtype =~ /clob/i ) {
384 warn "Oracle will not allow UNIQUE constraints on " .
385 "CLOB field '" . $field_def->table->name . '.' .
386 $field_def->name . ".'\n"
389 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
390 '(' . join( ', ', @fields ) . ')';
392 elsif ( $c->type eq CHECK_C ) {
393 $name ||= mk_name( $table_name, 'ck' );
394 my $expression = $c->expression || '';
395 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
397 elsif ( $c->type eq FOREIGN_KEY ) {
398 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
399 my $def = "CONSTRAINT $name FOREIGN KEY ";
402 $def .= '(' . join( ', ', @fields ) . ')';
405 my $ref_table = unreserve($c->reference_table);
407 $def .= " REFERENCES $ref_table";
410 $def .= ' (' . join( ', ', @rfields ) . ')';
413 if ( $c->match_type ) {
415 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
418 if ( $c->on_delete ) {
419 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
422 if ( $c->on_update ) {
423 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
426 push @constraint_defs, $def;
434 for my $index ( $table->get_indices ) {
435 my $index_name = $index->name || '';
436 my $index_type = $index->type || NORMAL;
437 my @fields = map { unreserve( $_, $table_name ) }
441 if ( $index_type eq PRIMARY_KEY ) {
442 $index_name ||= mk_name( $table_name, 'pk' );
443 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
444 '(' . join( ', ', @fields ) . ')';
446 elsif ( $index_type eq NORMAL ) {
447 $index_name ||= mk_name( $table_name, $index_name || 'i' );
449 "CREATE INDEX $index_name on $table_name_ur (".
450 join( ', ', @fields ).
454 warn "Unknown index type ($index_type) on table $table_name.\n"
459 my $create_statement;
460 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
462 if ( my @table_comments = $table->comments ) {
463 for my $comment ( @table_comments ) {
464 next unless $comment;
465 push @field_comments, "COMMENT ON TABLE $table_name is\n '".
466 $comment."';" unless $no_comments
471 my $table_options = @table_options
472 ? "\n".join("\n", @table_options) : '';
473 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
474 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
478 $output .= join( "\n\n",
490 warn "Truncated " . keys( %truncated ) . " names:\n";
491 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
495 warn "Encounted " . keys( %unreserve ) .
496 " unsafe names in schema (reserved or invalid):\n";
497 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
504 # -------------------------------------------------------------------
506 my $basename = shift || '';
507 my $type = shift || '';
508 $type = '' if $type =~ /^\d/;
509 my $scope = shift || '';
510 my $critical = shift || '';
511 my $basename_orig = $basename;
513 ? $max_id_length - (length($type) + 1)
515 $basename = substr( $basename, 0, $max_name )
516 if length( $basename ) > $max_name;
517 my $name = $type ? "${type}_$basename" : $basename;
519 if ( $basename ne $basename_orig and $critical ) {
520 my $show_type = $type ? "+'$type'" : "";
521 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
522 "character limit to make '$name'\n" if $WARN;
523 $truncated{ $basename_orig } = $name;
526 $scope ||= \%global_names;
527 if ( my $prev = $scope->{ $name } ) {
528 my $name_orig = $name;
529 $name .= sprintf( "%02d", ++$prev );
530 substr($name, $max_id_length - 3) = "00"
531 if length( $name ) > $max_id_length;
533 warn "The name '$name_orig' has been changed to ",
534 "'$name' to make it unique.\n" if $WARN;
536 $scope->{ $name_orig }++;
543 # -------------------------------------------------------------------
545 my $name = shift || '';
546 my $schema_obj_name = shift || '';
548 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
550 # also trap fields that don't begin with a letter
551 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
553 if ( $schema_obj_name ) {
554 ++$unreserve{"$schema_obj_name.$name"};
557 ++$unreserve{"$name (table name)"};
560 my $unreserve = sprintf '%s_', $name;
561 return $unreserve.$suffix;
566 # -------------------------------------------------------------------
567 # All bad art is the result of good intentions.
569 # -------------------------------------------------------------------
575 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
580 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
584 SQL::Translator, DDL::Oracle, mysql2ora.