1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.26 2003-10-15 19:00:35 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.26 $ =~ /(\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".
167 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
171 # Print create for each table
173 for my $table ( $schema->get_tables ) {
174 my $table_name = $table->name or next;
175 $table_name = mk_name( $table_name, '', undef, 1 );
176 my $table_name_ur = unreserve($table_name) or next;
178 my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
180 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
182 my ( %field_name_scope, @field_comments );
183 for my $field ( $table->get_fields ) {
187 my $field_name = mk_name(
188 $field->name, '', \%field_name_scope, 1
190 my $field_name_ur = unreserve( $field_name, $table_name );
191 my $field_def = $field_name_ur;
197 my $data_type = lc $field->data_type;
198 my @size = $field->size;
199 my %extra = $field->extra;
200 my $list = $extra{'list'} || [];
201 # \todo deal with embedded quotes
202 my $commalist = join( ', ', map { qq['$_'] } @$list );
204 if ( $data_type eq 'enum' ) {
205 $check = "CHECK ($field_name_ur IN ($commalist))";
206 $data_type = 'varchar2';
208 elsif ( $data_type eq 'set' ) {
209 # XXX add a CHECK constraint maybe
210 # (trickier and slower, than enum :)
211 $data_type = 'varchar2';
214 $data_type = defined $translate{ $data_type } ?
215 $translate{ $data_type } :
216 die "Unknown datatype: $data_type\n";
220 # Fixes ORA-02329: column of datatype LOB cannot be
221 # unique or a primary key
223 if ( $data_type eq 'clob' && $field->is_primary_key ) {
224 $data_type = 'varchar2';
226 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
231 # Fixes ORA-00907: missing right parenthesis
233 if ( $data_type =~ /(date|clob)/i ) {
237 $field_def .= " $data_type";
238 if ( defined $size[0] && $size[0] > 0 ) {
239 $field_def .= '(' . join( ', ', @size ) . ')';
245 my $default = $field->default_value;
246 if ( defined $default ) {
248 # Wherein we try to catch a string being used as
249 # a default value for a numerical field. If "true/false,"
250 # then sub "1/0," otherwise just test the truthity of the
251 # argument and use that (naive?).
254 $data_type =~ /^number$/i &&
255 $default !~ /^\d+$/ &&
258 if ( $default =~ /^true$/i ) {
261 elsif ( $default =~ /^false$/i ) {
265 $default = $default ? "'1'" : "'0'";
269 $data_type =~ /date/ && $default eq 'current_timestamp'
271 $default = 'SYSDATE';
274 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
277 $field_def .= " DEFAULT $default",
281 # Not null constraint
283 unless ( $field->is_nullable ) {
284 # my $constraint_name = mk_name(
285 # join('_', $table_name_ur, $field_name_ur ), 'nn'
287 # $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
288 $field_def .= ' NOT NULL';
291 $field_def .= " $check" if $check;
296 if ( $field->is_auto_increment ) {
297 my $base_name = $table_name . "_". $field_name;
298 my $seq_name = mk_name( $base_name, 'sq' );
299 my $trigger_name = mk_name( $base_name, 'ai' );
302 "CREATE SEQUENCE $seq_name;\n" .
303 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
304 "BEFORE INSERT ON $table_name\n" .
305 "FOR EACH ROW WHEN (\n" .
306 " new.$field_name_ur IS NULL".
307 " OR new.$field_name_ur = 0\n".
310 " SELECT $seq_name.nextval\n" .
311 " INTO :new." . $field->name."\n" .
317 if ( lc $field->data_type eq 'timestamp' ) {
318 my $base_name = $table_name . "_". $field_name_ur;
319 my $trig_name = mk_name( $base_name, 'ts' );
321 "CREATE OR REPLACE TRIGGER $trig_name\n".
322 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
323 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
325 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
329 push @field_defs, $field_def;
331 if ( my $comment = $field->comments ) {
332 push @field_comments,
333 "COMMENT ON COLUMN $table_name.$field_name_ur is\n '".
342 for my $opt ( $table->options ) {
343 if ( ref $opt eq 'HASH' ) {
344 my ( $key, $value ) = each %$opt;
345 if ( ref $value eq 'ARRAY' ) {
346 push @table_options, "$key\n(\n". join ("\n",
347 map { " $_->[0]\t$_->[1]" }
352 elsif ( !defined $value ) {
353 push @table_options, $key;
356 push @table_options, "$key $value";
364 for my $c ( $table->get_constraints ) {
365 my $name = $c->name || '';
366 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
367 my @rfields = map { unreserve( $_, $table_name ) }
368 $c->reference_fields;
369 next if !@fields && $c->type ne CHECK_C;
371 if ( $c->type eq PRIMARY_KEY ) {
372 $name ||= mk_name( $table_name, 'pk' );
373 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
374 '(' . join( ', ', @fields ) . ')';
376 elsif ( $c->type eq UNIQUE ) {
377 $name ||= mk_name( $table_name, 'u' );
378 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
379 '(' . join( ', ', @fields ) . ')';
381 elsif ( $c->type eq CHECK_C ) {
382 $name ||= mk_name( $table_name, 'ck' );
383 my $expression = $c->expression || '';
384 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
386 elsif ( $c->type eq FOREIGN_KEY ) {
387 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
388 my $def = "CONSTRAINT $name FOREIGN KEY ";
391 $def .= '(' . join( ', ', @fields ) . ')';
394 my $ref_table = unreserve($c->reference_table);
396 $def .= " REFERENCES $ref_table";
399 $def .= ' (' . join( ', ', @rfields ) . ')';
402 if ( $c->match_type ) {
404 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
407 if ( $c->on_delete ) {
408 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
411 if ( $c->on_update ) {
412 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
415 push @constraint_defs, $def;
423 for my $index ( $table->get_indices ) {
424 my $index_name = $index->name || '';
425 my $index_type = $index->type || NORMAL;
426 my @fields = map { unreserve( $_, $table_name ) }
430 if ( $index_type eq PRIMARY_KEY ) {
431 $index_name ||= mk_name( $table_name, 'pk' );
432 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
433 '(' . join( ', ', @fields ) . ')';
435 elsif ( $index_type eq NORMAL ) {
436 $index_name ||= mk_name( $table_name, $index_name || 'i' );
438 "CREATE INDEX $index_name on $table_name_ur (".
439 join( ', ', @fields ).
443 warn "Unknown index type ($index_type) on table $table_name.\n"
448 my $create_statement;
449 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
451 if ( my @table_comments = $table->comments ) {
452 for my $comment ( @table_comments ) {
453 next unless $comment;
454 push @field_comments, "COMMENT ON TABLE $table_name is\n '".
460 my $table_options = @table_options
461 ? "\n".join("\n", @table_options) : '';
462 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
463 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
467 $output .= join( "\n\n",
479 warn "Truncated " . keys( %truncated ) . " names:\n";
480 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
484 warn "Encounted " . keys( %unreserve ) .
485 " unsafe names in schema (reserved or invalid):\n";
486 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
493 # -------------------------------------------------------------------
495 my $basename = shift || '';
496 my $type = shift || '';
497 $type = '' if $type =~ /^\d/;
498 my $scope = shift || '';
499 my $critical = shift || '';
500 my $basename_orig = $basename;
502 ? $max_id_length - (length($type) + 1)
504 $basename = substr( $basename, 0, $max_name )
505 if length( $basename ) > $max_name;
506 my $name = $type ? "${type}_$basename" : $basename;
508 if ( $basename ne $basename_orig and $critical ) {
509 my $show_type = $type ? "+'$type'" : "";
510 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
511 "character limit to make '$name'\n" if $WARN;
512 $truncated{ $basename_orig } = $name;
515 $scope ||= \%global_names;
516 if ( my $prev = $scope->{ $name } ) {
517 my $name_orig = $name;
518 $name .= sprintf( "%02d", ++$prev );
519 substr($name, $max_id_length - 3) = "00"
520 if length( $name ) > $max_id_length;
522 warn "The name '$name_orig' has been changed to ",
523 "'$name' to make it unique.\n" if $WARN;
525 $scope->{ $name_orig }++;
532 # -------------------------------------------------------------------
534 my $name = shift || '';
535 my $schema_obj_name = shift || '';
537 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
539 # also trap fields that don't begin with a letter
540 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
542 if ( $schema_obj_name ) {
543 ++$unreserve{"$schema_obj_name.$name"};
546 ++$unreserve{"$name (table name)"};
549 my $unreserve = sprintf '%s_', $name;
550 return $unreserve.$suffix;
555 # -------------------------------------------------------------------
556 # All bad art is the result of good intentions.
558 # -------------------------------------------------------------------
564 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
569 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
573 SQL::Translator, DDL::Oracle, mysql2ora.