1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.27 2003-10-15 20:39:15 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.27 $ =~ /(\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 } :
219 die "Unknown datatype: $data_type\n";
223 # Fixes ORA-02329: column of datatype LOB cannot be
224 # unique or a primary key
226 if ( $data_type eq 'clob' && $field->is_primary_key ) {
227 $data_type = 'varchar2';
229 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
234 # Fixes ORA-00907: missing right parenthesis
236 if ( $data_type =~ /(date|clob)/i ) {
240 $field_def .= " $data_type";
241 if ( defined $size[0] && $size[0] > 0 ) {
242 $field_def .= '(' . join( ', ', @size ) . ')';
248 my $default = $field->default_value;
249 if ( defined $default ) {
251 # Wherein we try to catch a string being used as
252 # a default value for a numerical field. If "true/false,"
253 # then sub "1/0," otherwise just test the truthity of the
254 # argument and use that (naive?).
257 $data_type =~ /^number$/i &&
258 $default !~ /^\d+$/ &&
261 if ( $default =~ /^true$/i ) {
264 elsif ( $default =~ /^false$/i ) {
268 $default = $default ? "'1'" : "'0'";
272 $data_type =~ /date/ && $default eq 'current_timestamp'
274 $default = 'SYSDATE';
277 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
280 $field_def .= " DEFAULT $default",
284 # Not null constraint
286 unless ( $field->is_nullable ) {
287 # my $constraint_name = mk_name(
288 # join('_', $table_name_ur, $field_name_ur ), 'nn'
290 # $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
291 $field_def .= ' NOT NULL';
294 $field_def .= " $check" if $check;
299 if ( $field->is_auto_increment ) {
300 my $base_name = $table_name . "_". $field_name;
301 my $seq_name = mk_name( $base_name, 'sq' );
302 my $trigger_name = mk_name( $base_name, 'ai' );
305 "CREATE SEQUENCE $seq_name;\n" .
306 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
307 "BEFORE INSERT ON $table_name\n" .
308 "FOR EACH ROW WHEN (\n" .
309 " new.$field_name_ur IS NULL".
310 " OR new.$field_name_ur = 0\n".
313 " SELECT $seq_name.nextval\n" .
314 " INTO :new." . $field->name."\n" .
320 if ( lc $field->data_type eq 'timestamp' ) {
321 my $base_name = $table_name . "_". $field_name_ur;
322 my $trig_name = mk_name( $base_name, 'ts' );
324 "CREATE OR REPLACE TRIGGER $trig_name\n".
325 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
326 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
328 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
332 push @field_defs, $field_def;
334 if ( my $comment = $field->comments ) {
335 push @field_comments,
336 "COMMENT ON COLUMN $table_name.$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( $table_name, 'u' );
381 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
382 '(' . join( ', ', @fields ) . ')';
384 elsif ( $c->type eq CHECK_C ) {
385 $name ||= mk_name( $table_name, 'ck' );
386 my $expression = $c->expression || '';
387 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
389 elsif ( $c->type eq FOREIGN_KEY ) {
390 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
391 my $def = "CONSTRAINT $name FOREIGN KEY ";
394 $def .= '(' . join( ', ', @fields ) . ')';
397 my $ref_table = unreserve($c->reference_table);
399 $def .= " REFERENCES $ref_table";
402 $def .= ' (' . join( ', ', @rfields ) . ')';
405 if ( $c->match_type ) {
407 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
410 if ( $c->on_delete ) {
411 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
414 if ( $c->on_update ) {
415 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
418 push @constraint_defs, $def;
426 for my $index ( $table->get_indices ) {
427 my $index_name = $index->name || '';
428 my $index_type = $index->type || NORMAL;
429 my @fields = map { unreserve( $_, $table_name ) }
433 if ( $index_type eq PRIMARY_KEY ) {
434 $index_name ||= mk_name( $table_name, 'pk' );
435 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
436 '(' . join( ', ', @fields ) . ')';
438 elsif ( $index_type eq NORMAL ) {
439 $index_name ||= mk_name( $table_name, $index_name || 'i' );
441 "CREATE INDEX $index_name on $table_name_ur (".
442 join( ', ', @fields ).
446 warn "Unknown index type ($index_type) on table $table_name.\n"
451 my $create_statement;
452 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
454 if ( my @table_comments = $table->comments ) {
455 for my $comment ( @table_comments ) {
456 next unless $comment;
457 push @field_comments, "COMMENT ON TABLE $table_name is\n '".
458 $comment."';" unless $no_comments
463 my $table_options = @table_options
464 ? "\n".join("\n", @table_options) : '';
465 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
466 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
470 $output .= join( "\n\n",
482 warn "Truncated " . keys( %truncated ) . " names:\n";
483 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
487 warn "Encounted " . keys( %unreserve ) .
488 " unsafe names in schema (reserved or invalid):\n";
489 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
496 # -------------------------------------------------------------------
498 my $basename = shift || '';
499 my $type = shift || '';
500 $type = '' if $type =~ /^\d/;
501 my $scope = shift || '';
502 my $critical = shift || '';
503 my $basename_orig = $basename;
505 ? $max_id_length - (length($type) + 1)
507 $basename = substr( $basename, 0, $max_name )
508 if length( $basename ) > $max_name;
509 my $name = $type ? "${type}_$basename" : $basename;
511 if ( $basename ne $basename_orig and $critical ) {
512 my $show_type = $type ? "+'$type'" : "";
513 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
514 "character limit to make '$name'\n" if $WARN;
515 $truncated{ $basename_orig } = $name;
518 $scope ||= \%global_names;
519 if ( my $prev = $scope->{ $name } ) {
520 my $name_orig = $name;
521 $name .= sprintf( "%02d", ++$prev );
522 substr($name, $max_id_length - 3) = "00"
523 if length( $name ) > $max_id_length;
525 warn "The name '$name_orig' has been changed to ",
526 "'$name' to make it unique.\n" if $WARN;
528 $scope->{ $name_orig }++;
535 # -------------------------------------------------------------------
537 my $name = shift || '';
538 my $schema_obj_name = shift || '';
540 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
542 # also trap fields that don't begin with a letter
543 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
545 if ( $schema_obj_name ) {
546 ++$unreserve{"$schema_obj_name.$name"};
549 ++$unreserve{"$name (table name)"};
552 my $unreserve = sprintf '%s_', $name;
553 return $unreserve.$suffix;
558 # -------------------------------------------------------------------
559 # All bad art is the result of good intentions.
561 # -------------------------------------------------------------------
567 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
572 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
576 SQL::Translator, DDL::Oracle, mysql2ora.