1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.28 2003-11-05 22:27:55 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 # -------------------------------------------------------------------
27 SQL::Translator::Producer::Oracle - Oracle SQL producer
33 my $t = SQL::Translator->new( parser => '...', producer => 'Oracle' );
34 print $translator->translate( $file );
38 Creates an SQL DDL suitable for Oracle.
43 use vars qw[ $VERSION $DEBUG $WARN ];
44 $VERSION = sprintf "%d.%02d", q$Revision: 1.28 $ =~ /(\d+)\.(\d+)/;
45 $DEBUG = 0 unless defined $DEBUG;
47 use SQL::Translator::Schema::Constants;
48 use SQL::Translator::Utils qw(header_comment);
60 mediumint => 'number',
64 varchar => 'varchar2',
69 tinytext => 'varchar2',
85 'double precision' => 'number',
87 bigserial => 'number',
90 'character varying' => 'varchar2',
103 macaddr => 'varchar2',
105 'bit varying' => 'number',
111 varchar2 => 'varchar2',
116 # Oracle reserved words from:
117 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
118 # 817_doc/server.817/a85397/ap_keywd.htm
120 my %ora_reserved = map { $_, 1 } qw(
121 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
123 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
124 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
125 ELSE EXCLUSIVE EXISTS
129 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
130 INTEGER INTERSECT INTO IS
132 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
133 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
134 OF OFFLINE ON ONLINE OPTION OR ORDER
135 PCTFREE PRIOR PRIVILEGES PUBLIC
136 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
137 SELECT SESSION SET SHARE SIZE SMALLINT START
138 SUCCESSFUL SYNONYM SYSDATE
139 TABLE THEN TO TRIGGER
140 UID UNION UNIQUE UPDATE USER
141 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
145 my $max_id_length = 30;
146 my %used_identifiers = ();
151 # -------------------------------------------------------------------
153 my $translator = shift;
154 $DEBUG = $translator->debug;
155 $WARN = $translator->show_warnings;
156 my $no_comments = $translator->no_comments;
157 my $add_drop_table = $translator->add_drop_table;
158 my $schema = $translator->schema;
161 $output .= header_comment unless ($no_comments);
163 if ( $translator->parser_type =~ /mysql/i ) {
165 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
166 "-- but we set it here anyway to be self-consistent.\n"
170 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
174 # Print create for each table
176 for my $table ( $schema->get_tables ) {
177 my $table_name = $table->name or next;
178 $table_name = mk_name( $table_name, '', undef, 1 );
179 my $table_name_ur = unreserve($table_name) or next;
181 my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
183 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
185 my ( %field_name_scope, @field_comments );
186 for my $field ( $table->get_fields ) {
190 my $field_name = mk_name(
191 $field->name, '', \%field_name_scope, 1
193 my $field_name_ur = unreserve( $field_name, $table_name );
194 my $field_def = $field_name_ur;
200 my $data_type = lc $field->data_type;
201 my @size = $field->size;
202 my %extra = $field->extra;
203 my $list = $extra{'list'} || [];
204 # \todo deal with embedded quotes
205 my $commalist = join( ', ', map { qq['$_'] } @$list );
207 if ( $data_type eq 'enum' ) {
208 $check = "CHECK ($field_name_ur IN ($commalist))";
209 $data_type = 'varchar2';
211 elsif ( $data_type eq 'set' ) {
212 # XXX add a CHECK constraint maybe
213 # (trickier and slower, than enum :)
214 $data_type = 'varchar2';
217 $data_type = defined $translate{ $data_type } ?
218 $translate{ $data_type } :
220 $data_type ||= 'varchar2';
224 # Fixes ORA-02329: column of datatype LOB cannot be
225 # unique or a primary key
227 if ( $data_type eq 'clob' && $field->is_primary_key ) {
228 $data_type = 'varchar2';
230 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
235 # Fixes ORA-00907: missing right parenthesis
237 if ( $data_type =~ /(date|clob)/i ) {
241 $field_def .= " $data_type";
242 if ( defined $size[0] && $size[0] > 0 ) {
243 $field_def .= '(' . join( ', ', @size ) . ')';
249 my $default = $field->default_value;
250 if ( defined $default ) {
252 # Wherein we try to catch a string being used as
253 # a default value for a numerical field. If "true/false,"
254 # then sub "1/0," otherwise just test the truthity of the
255 # argument and use that (naive?).
258 $data_type =~ /^number$/i &&
259 $default !~ /^\d+$/ &&
262 if ( $default =~ /^true$/i ) {
265 elsif ( $default =~ /^false$/i ) {
269 $default = $default ? "'1'" : "'0'";
273 $data_type =~ /date/ && $default eq 'current_timestamp'
275 $default = 'SYSDATE';
278 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
281 $field_def .= " DEFAULT $default",
285 # Not null constraint
287 unless ( $field->is_nullable ) {
288 # my $constraint_name = mk_name(
289 # join('_', $table_name_ur, $field_name_ur ), 'nn'
291 # $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
292 $field_def .= ' NOT NULL';
295 $field_def .= " $check" if $check;
300 if ( $field->is_auto_increment ) {
301 my $base_name = $table_name . "_". $field_name;
302 my $seq_name = mk_name( $base_name, 'sq' );
303 my $trigger_name = mk_name( $base_name, 'ai' );
306 "CREATE SEQUENCE $seq_name;\n" .
307 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
308 "BEFORE INSERT ON $table_name\n" .
309 "FOR EACH ROW WHEN (\n" .
310 " new.$field_name_ur IS NULL".
311 " OR new.$field_name_ur = 0\n".
314 " SELECT $seq_name.nextval\n" .
315 " INTO :new." . $field->name."\n" .
321 if ( lc $field->data_type eq 'timestamp' ) {
322 my $base_name = $table_name . "_". $field_name_ur;
323 my $trig_name = mk_name( $base_name, 'ts' );
325 "CREATE OR REPLACE TRIGGER $trig_name\n".
326 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
327 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
329 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
333 push @field_defs, $field_def;
335 if ( my $comment = $field->comments ) {
336 push @field_comments,
337 "COMMENT ON COLUMN $table_name.$field_name_ur is\n '".
338 $comment."';" unless $no_comments;
346 for my $opt ( $table->options ) {
347 if ( ref $opt eq 'HASH' ) {
348 my ( $key, $value ) = each %$opt;
349 if ( ref $value eq 'ARRAY' ) {
350 push @table_options, "$key\n(\n". join ("\n",
351 map { " $_->[0]\t$_->[1]" }
356 elsif ( !defined $value ) {
357 push @table_options, $key;
360 push @table_options, "$key $value";
368 for my $c ( $table->get_constraints ) {
369 my $name = $c->name || '';
370 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
371 my @rfields = map { unreserve( $_, $table_name ) }
372 $c->reference_fields;
373 next if !@fields && $c->type ne CHECK_C;
375 if ( $c->type eq PRIMARY_KEY ) {
376 $name ||= mk_name( $table_name, 'pk' );
377 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
378 '(' . join( ', ', @fields ) . ')';
380 elsif ( $c->type eq UNIQUE ) {
381 $name ||= mk_name( $table_name, 'u' );
382 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
383 '(' . join( ', ', @fields ) . ')';
385 elsif ( $c->type eq CHECK_C ) {
386 $name ||= mk_name( $table_name, 'ck' );
387 my $expression = $c->expression || '';
388 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
390 elsif ( $c->type eq FOREIGN_KEY ) {
391 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
392 my $def = "CONSTRAINT $name FOREIGN KEY ";
395 $def .= '(' . join( ', ', @fields ) . ')';
398 my $ref_table = unreserve($c->reference_table);
400 $def .= " REFERENCES $ref_table";
403 $def .= ' (' . join( ', ', @rfields ) . ')';
406 if ( $c->match_type ) {
408 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
411 if ( $c->on_delete ) {
412 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
415 if ( $c->on_update ) {
416 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
419 push @constraint_defs, $def;
427 for my $index ( $table->get_indices ) {
428 my $index_name = $index->name || '';
429 my $index_type = $index->type || NORMAL;
430 my @fields = map { unreserve( $_, $table_name ) }
434 if ( $index_type eq PRIMARY_KEY ) {
435 $index_name ||= mk_name( $table_name, 'pk' );
436 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
437 '(' . join( ', ', @fields ) . ')';
439 elsif ( $index_type eq NORMAL ) {
440 $index_name ||= mk_name( $table_name, $index_name || 'i' );
442 "CREATE INDEX $index_name on $table_name_ur (".
443 join( ', ', @fields ).
447 warn "Unknown index type ($index_type) on table $table_name.\n"
452 my $create_statement;
453 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
455 if ( my @table_comments = $table->comments ) {
456 for my $comment ( @table_comments ) {
457 next unless $comment;
458 push @field_comments, "COMMENT ON TABLE $table_name is\n '".
459 $comment."';" unless $no_comments
464 my $table_options = @table_options
465 ? "\n".join("\n", @table_options) : '';
466 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
467 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
471 $output .= join( "\n\n",
483 warn "Truncated " . keys( %truncated ) . " names:\n";
484 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
488 warn "Encounted " . keys( %unreserve ) .
489 " unsafe names in schema (reserved or invalid):\n";
490 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
497 # -------------------------------------------------------------------
499 my $basename = shift || '';
500 my $type = shift || '';
501 $type = '' if $type =~ /^\d/;
502 my $scope = shift || '';
503 my $critical = shift || '';
504 my $basename_orig = $basename;
506 ? $max_id_length - (length($type) + 1)
508 $basename = substr( $basename, 0, $max_name )
509 if length( $basename ) > $max_name;
510 my $name = $type ? "${type}_$basename" : $basename;
512 if ( $basename ne $basename_orig and $critical ) {
513 my $show_type = $type ? "+'$type'" : "";
514 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
515 "character limit to make '$name'\n" if $WARN;
516 $truncated{ $basename_orig } = $name;
519 $scope ||= \%global_names;
520 if ( my $prev = $scope->{ $name } ) {
521 my $name_orig = $name;
522 $name .= sprintf( "%02d", ++$prev );
523 substr($name, $max_id_length - 3) = "00"
524 if length( $name ) > $max_id_length;
526 warn "The name '$name_orig' has been changed to ",
527 "'$name' to make it unique.\n" if $WARN;
529 $scope->{ $name_orig }++;
536 # -------------------------------------------------------------------
538 my $name = shift || '';
539 my $schema_obj_name = shift || '';
541 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
543 # also trap fields that don't begin with a letter
544 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
546 if ( $schema_obj_name ) {
547 ++$unreserve{"$schema_obj_name.$name"};
550 ++$unreserve{"$name (table name)"};
553 my $unreserve = sprintf '%s_', $name;
554 return $unreserve.$suffix;
559 # -------------------------------------------------------------------
560 # All bad art is the result of good intentions.
562 # -------------------------------------------------------------------
568 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
573 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
577 SQL::Translator, DDL::Oracle, mysql2ora.