1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.25 2003-10-04 01:21:10 kycl4rk Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>,
7 # darren chamberlain <darren@cpan.org>,
8 # Chris Mungall <cjm@fruitfly.org>
10 # This program is free software; you can redistribute it and/or
11 # modify it under the terms of the GNU General Public License as
12 # published by the Free Software Foundation; version 2.
14 # This program is distributed in the hope that it will be useful, but
15 # WITHOUT ANY WARRANTY; without even the implied warranty of
16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 # General Public License for more details.
19 # You should have received a copy of the GNU General Public License
20 # along with this program; if not, write to the Free Software
21 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
23 # -------------------------------------------------------------------
26 use vars qw[ $VERSION $DEBUG $WARN ];
27 $VERSION = sprintf "%d.%02d", q$Revision: 1.25 $ =~ /(\d+)\.(\d+)/;
28 $DEBUG = 0 unless defined $DEBUG;
30 use SQL::Translator::Schema::Constants;
31 use SQL::Translator::Utils qw(header_comment);
43 mediumint => 'number',
47 varchar => 'varchar2',
52 tinytext => 'varchar2',
68 'double precision' => 'number',
70 bigserial => 'number',
73 'character varying' => 'varchar2',
86 macaddr => 'varchar2',
88 'bit varying' => 'number',
94 varchar2 => 'varchar2',
99 # Oracle reserved words from:
100 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
101 # 817_doc/server.817/a85397/ap_keywd.htm
103 my %ora_reserved = map { $_, 1 } qw(
104 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
106 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
107 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
108 ELSE EXCLUSIVE EXISTS
112 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
113 INTEGER INTERSECT INTO IS
115 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
116 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
117 OF OFFLINE ON ONLINE OPTION OR ORDER
118 PCTFREE PRIOR PRIVILEGES PUBLIC
119 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
120 SELECT SESSION SET SHARE SIZE SMALLINT START
121 SUCCESSFUL SYNONYM SYSDATE
122 TABLE THEN TO TRIGGER
123 UID UNION UNIQUE UPDATE USER
124 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
128 my $max_id_length = 30;
129 my %used_identifiers = ();
134 # -------------------------------------------------------------------
136 my $translator = shift;
137 $DEBUG = $translator->debug;
138 $WARN = $translator->show_warnings;
139 my $no_comments = $translator->no_comments;
140 my $add_drop_table = $translator->add_drop_table;
141 my $schema = $translator->schema;
144 $output .= header_comment unless ($no_comments);
146 if ( $translator->parser_type =~ /mysql/i ) {
148 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
149 "-- but we set it here anyway to be self-consistent.\n".
150 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
154 # Print create for each table
156 for my $table ( $schema->get_tables ) {
157 my $table_name = $table->name or next;
158 $table_name = mk_name( $table_name, '', undef, 1 );
159 my $table_name_ur = unreserve($table_name) or next;
161 my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
163 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
165 my ( %field_name_scope, @field_comments );
166 for my $field ( $table->get_fields ) {
170 my $field_name = mk_name(
171 $field->name, '', \%field_name_scope, 1
173 my $field_name_ur = unreserve( $field_name, $table_name );
174 my $field_def = $field_name_ur;
180 my $data_type = lc $field->data_type;
181 my @size = $field->size;
182 my %extra = $field->extra;
183 my $list = $extra{'list'} || [];
184 # \todo deal with embedded quotes
185 my $commalist = join( ', ', map { qq['$_'] } @$list );
187 if ( $data_type eq 'enum' ) {
188 $check = "CHECK ($field_name_ur IN ($commalist))";
189 $data_type = 'varchar2';
191 elsif ( $data_type eq 'set' ) {
192 # XXX add a CHECK constraint maybe
193 # (trickier and slower, than enum :)
194 $data_type = 'varchar2';
197 $data_type = defined $translate{ $data_type } ?
198 $translate{ $data_type } :
199 die "Unknown datatype: $data_type\n";
203 # Fixes ORA-02329: column of datatype LOB cannot be
204 # unique or a primary key
206 if ( $data_type eq 'clob' && $field->is_primary_key ) {
207 $data_type = 'varchar2';
209 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
214 # Fixes ORA-00907: missing right parenthesis
216 if ( $data_type =~ /(date|clob)/i ) {
220 $field_def .= " $data_type";
221 if ( defined $size[0] && $size[0] > 0 ) {
222 $field_def .= '(' . join( ', ', @size ) . ')';
228 my $default = $field->default_value;
229 if ( defined $default ) {
231 # Wherein we try to catch a string being used as
232 # a default value for a numerical field. If "true/false,"
233 # then sub "1/0," otherwise just test the truthity of the
234 # argument and use that (naive?).
237 $data_type =~ /^number$/i &&
238 $default !~ /^\d+$/ &&
241 if ( $default =~ /^true$/i ) {
244 elsif ( $default =~ /^false$/i ) {
248 $default = $default ? "'1'" : "'0'";
252 $data_type =~ /date/ && $default eq 'current_timestamp'
254 $default = 'SYSDATE';
257 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
260 $field_def .= " DEFAULT $default",
264 # Not null constraint
266 unless ( $field->is_nullable ) {
267 # my $constraint_name = mk_name(
268 # join('_', $table_name_ur, $field_name_ur ), 'nn'
270 # $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
271 $field_def .= ' NOT NULL';
274 $field_def .= " $check" if $check;
279 if ( $field->is_auto_increment ) {
280 my $base_name = $table_name . "_". $field_name;
281 my $seq_name = mk_name( $base_name, 'sq' );
282 my $trigger_name = mk_name( $base_name, 'ai' );
285 "CREATE SEQUENCE $seq_name;\n" .
286 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
287 "BEFORE INSERT ON $table_name\n" .
288 "FOR EACH ROW WHEN (\n" .
289 " new.$field_name_ur IS NULL".
290 " OR new.$field_name_ur = 0\n".
293 " SELECT $seq_name.nextval\n" .
294 " INTO :new." . $field->name."\n" .
300 if ( lc $field->data_type eq 'timestamp' ) {
301 my $base_name = $table_name . "_". $field_name_ur;
302 my $trig_name = mk_name( $base_name, 'ts' );
304 "CREATE OR REPLACE TRIGGER $trig_name\n".
305 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
306 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
308 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
312 push @field_defs, $field_def;
314 if ( my $comment = $field->comments ) {
315 push @field_comments,
316 "COMMENT ON COLUMN $table_name.$field_name_ur is\n '".
325 for my $opt ( $table->options ) {
326 if ( ref $opt eq 'HASH' ) {
327 my ( $key, $value ) = each %$opt;
328 if ( ref $value eq 'ARRAY' ) {
329 push @table_options, "$key\n(\n". join ("\n",
330 map { " $_->[0]\t$_->[1]" }
335 elsif ( !defined $value ) {
336 push @table_options, $key;
339 push @table_options, "$key $value";
347 for my $c ( $table->get_constraints ) {
348 my $name = $c->name || '';
349 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
350 my @rfields = map { unreserve( $_, $table_name ) }
351 $c->reference_fields;
352 next if !@fields && $c->type ne CHECK_C;
354 if ( $c->type eq PRIMARY_KEY ) {
355 $name ||= mk_name( $table_name, 'pk' );
356 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
357 '(' . join( ', ', @fields ) . ')';
359 elsif ( $c->type eq UNIQUE ) {
360 $name ||= mk_name( $table_name, 'u' );
361 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
362 '(' . join( ', ', @fields ) . ')';
364 elsif ( $c->type eq CHECK_C ) {
365 $name ||= mk_name( $table_name, 'ck' );
366 my $expression = $c->expression || '';
367 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
369 elsif ( $c->type eq FOREIGN_KEY ) {
370 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
371 my $def = "CONSTRAINT $name FOREIGN KEY ";
374 $def .= '(' . join( ', ', @fields ) . ')';
377 my $ref_table = unreserve($c->reference_table);
379 $def .= " REFERENCES $ref_table";
382 $def .= ' (' . join( ', ', @rfields ) . ')';
385 if ( $c->match_type ) {
387 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
390 if ( $c->on_delete ) {
391 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
394 if ( $c->on_update ) {
395 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
398 push @constraint_defs, $def;
406 for my $index ( $table->get_indices ) {
407 my $index_name = $index->name || '';
408 my $index_type = $index->type || NORMAL;
409 my @fields = map { unreserve( $_, $table_name ) }
413 if ( $index_type eq PRIMARY_KEY ) {
414 $index_name ||= mk_name( $table_name, 'pk' );
415 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
416 '(' . join( ', ', @fields ) . ')';
418 elsif ( $index_type eq NORMAL ) {
419 $index_name ||= mk_name( $table_name, $index_name || 'i' );
421 "CREATE INDEX $index_name on $table_name_ur (".
422 join( ', ', @fields ).
426 warn "Unknown index type ($index_type) on table $table_name.\n"
431 my $create_statement;
432 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
434 if ( my @table_comments = $table->comments ) {
435 for my $comment ( @table_comments ) {
436 next unless $comment;
437 push @field_comments, "COMMENT ON TABLE $table_name is\n '".
443 my $table_options = @table_options
444 ? "\n".join("\n", @table_options) : '';
445 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
446 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
450 $output .= join( "\n\n",
462 warn "Truncated " . keys( %truncated ) . " names:\n";
463 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
467 warn "Encounted " . keys( %unreserve ) .
468 " unsafe names in schema (reserved or invalid):\n";
469 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
476 # -------------------------------------------------------------------
478 my $basename = shift || '';
479 my $type = shift || '';
480 $type = '' if $type =~ /^\d/;
481 my $scope = shift || '';
482 my $critical = shift || '';
483 my $basename_orig = $basename;
485 ? $max_id_length - (length($type) + 1)
487 $basename = substr( $basename, 0, $max_name )
488 if length( $basename ) > $max_name;
489 my $name = $type ? "${type}_$basename" : $basename;
491 if ( $basename ne $basename_orig and $critical ) {
492 my $show_type = $type ? "+'$type'" : "";
493 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
494 "character limit to make '$name'\n" if $WARN;
495 $truncated{ $basename_orig } = $name;
498 $scope ||= \%global_names;
499 if ( my $prev = $scope->{ $name } ) {
500 my $name_orig = $name;
501 $name .= sprintf( "%02d", ++$prev );
502 substr($name, $max_id_length - 3) = "00"
503 if length( $name ) > $max_id_length;
505 warn "The name '$name_orig' has been changed to ",
506 "'$name' to make it unique.\n" if $WARN;
508 $scope->{ $name_orig }++;
515 # -------------------------------------------------------------------
517 my $name = shift || '';
518 my $schema_obj_name = shift || '';
520 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
522 # also trap fields that don't begin with a letter
523 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
525 if ( $schema_obj_name ) {
526 ++$unreserve{"$schema_obj_name.$name"};
529 ++$unreserve{"$name (table name)"};
532 my $unreserve = sprintf '%s_', $name;
533 return $unreserve.$suffix;
538 # -------------------------------------------------------------------
539 # All bad art is the result of good intentions.
541 # -------------------------------------------------------------------
545 SQL::Translator::Producer::Oracle - Oracle SQL producer
549 use SQL::Translator::Parser::MySQL;
550 use SQL::Translator::Producer::Oracle;
552 my $original_create = ""; # get this from somewhere...
553 my $translator = SQL::Translator->new;
555 $translator->parser("SQL::Translator::Parser::MySQL");
556 $translator->producer("SQL::Translator::Producer::Oracle");
558 my $new_create = $translator->translate($original_create);
562 SQL::Translator::Producer::Oracle takes a parsed data structure,
563 created by a SQL::Translator::Parser subclass, and turns it into a
564 create string suitable for use with an Oracle database.
568 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
569 his "mysql2ora" script.
573 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>