1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.23 2003-08-21 18:09:50 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.23 $ =~ /(\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',
92 # Oracle reserved words from:
93 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
94 # 817_doc/server.817/a85397/ap_keywd.htm
96 my %ora_reserved = map { $_, 1 } qw(
97 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
99 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
100 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
101 ELSE EXCLUSIVE EXISTS
105 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
106 INTEGER INTERSECT INTO IS
108 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
109 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
110 OF OFFLINE ON ONLINE OPTION OR ORDER
111 PCTFREE PRIOR PRIVILEGES PUBLIC
112 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
113 SELECT SESSION SET SHARE SIZE SMALLINT START
114 SUCCESSFUL SYNONYM SYSDATE
115 TABLE THEN TO TRIGGER
116 UID UNION UNIQUE UPDATE USER
117 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
121 my $max_id_length = 30;
122 my %used_identifiers = ();
127 # -------------------------------------------------------------------
129 my $translator = shift;
130 $DEBUG = $translator->debug;
131 $WARN = $translator->show_warnings;
132 my $no_comments = $translator->no_comments;
133 my $add_drop_table = $translator->add_drop_table;
134 my $schema = $translator->schema;
137 $output .= header_comment unless ($no_comments);
139 if ( $translator->parser_type =~ /mysql/i ) {
141 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
142 "-- but we set it here anyway to be self-consistent.\n".
143 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
147 # Print create for each table
149 for my $table ( $schema->get_tables ) {
150 my $table_name = $table->name or next;
151 $table_name = mk_name( $table_name, '', undef, 1 );
152 my $table_name_ur = unreserve($table_name) or next;
154 my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
156 push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
158 my ( %field_name_scope, @field_comments );
159 for my $field ( $table->get_fields ) {
163 my $field_name = mk_name(
164 $field->name, '', \%field_name_scope, 1
166 my $field_name_ur = unreserve( $field_name, $table_name );
167 my $field_def = $field_name_ur;
173 my $data_type = lc $field->data_type;
174 my @size = $field->size;
175 my %extra = $field->extra;
176 my $list = $extra{'list'} || [];
177 # \todo deal with embedded quotes
178 my $commalist = join( ', ', map { qq['$_'] } @$list );
180 if ( $data_type eq 'enum' ) {
181 $check = "CHECK ($field_name_ur IN ($commalist))";
182 $data_type = 'varchar2';
184 elsif ( $data_type eq 'set' ) {
185 # XXX add a CHECK constraint maybe
186 # (trickier and slower, than enum :)
187 $data_type = 'varchar2';
190 $data_type = defined $translate{ $data_type } ?
191 $translate{ $data_type } :
192 die "Unknown datatype: $data_type\n";
196 # Fixes ORA-02329: column of datatype LOB cannot be
197 # unique or a primary key
199 if ( $data_type eq 'clob' && $field->is_primary_key ) {
200 $data_type = 'varchar2';
202 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
207 # Fixes ORA-00907: missing right parenthesis
209 if ( $data_type =~ /(date|clob)/i ) {
213 $field_def .= " $data_type";
214 if ( defined $size[0] && $size[0] > 0 ) {
215 $field_def .= '(' . join( ', ', @size ) . ')';
221 my $default = $field->default_value;
222 if ( defined $default ) {
224 # Wherein we try to catch a string being used as
225 # a default value for a numerical field. If "true/false,"
226 # then sub "1/0," otherwise just test the truthity of the
227 # argument and use that (naive?).
229 if ( $data_type =~ /^number$/i && $default !~ /^\d+$/ ) {
230 if ( $default =~ /^true$/i ) {
233 elsif ( $default =~ /^false$/i ) {
237 $default = $default ? "'1'" : "'0'";
241 $data_type =~ /date/ && $default eq 'current_timestamp'
243 $default = 'SYSDATE';
246 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
249 $field_def .= " DEFAULT $default",
253 # Not null constraint
255 unless ( $field->is_nullable ) {
256 my $constraint_name = mk_name(
257 join('_', $table_name_ur, $field_name_ur ), 'nn'
259 $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
262 $field_def .= " $check" if $check;
267 if ( $field->is_auto_increment ) {
268 my $base_name = $table_name . "_". $field_name;
269 my $seq_name = mk_name( $base_name, 'sq' );
270 my $trigger_name = mk_name( $base_name, 'ai' );
273 "CREATE SEQUENCE $seq_name;\n" .
274 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
275 "BEFORE INSERT ON $table_name\n" .
276 "FOR EACH ROW WHEN (\n" .
277 " new.$field_name_ur IS NULL".
278 " OR new.$field_name_ur = 0\n".
281 " SELECT $seq_name.nextval\n" .
282 " INTO :new." . $field->name."\n" .
288 if ( lc $field->data_type eq 'timestamp' ) {
289 my $base_name = $table_name . "_". $field_name_ur;
290 my $trig_name = mk_name( $base_name, 'ts' );
292 "CREATE OR REPLACE TRIGGER $trig_name\n".
293 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
294 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
296 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
300 push @field_defs, $field_def;
302 if ( my $comment = $field->comments ) {
303 push @field_comments,
304 "COMMENT ON COLUMN $table_name.$field_name_ur is\n '".
312 for my $c ( $table->get_constraints ) {
313 my $name = $c->name || '';
314 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
315 my @rfields = map { unreserve( $_, $table_name ) }
316 $c->reference_fields;
317 next if !@fields && $c->type ne CHECK_C;
319 if ( $c->type eq PRIMARY_KEY ) {
320 $name ||= mk_name( $table_name, 'pk' );
321 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
322 '(' . join( ', ', @fields ) . ')';
324 elsif ( $c->type eq UNIQUE ) {
325 $name ||= mk_name( $table_name, 'u' );
326 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
327 '(' . join( ', ', @fields ) . ')';
329 elsif ( $c->type eq CHECK_C ) {
330 $name ||= mk_name( $table_name, 'ck' );
331 my $expression = $c->expression || '';
332 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
334 elsif ( $c->type eq FOREIGN_KEY ) {
335 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
336 my $def = "CONSTRAINT $name FOREIGN KEY ";
339 $def .= '(' . join( ', ', @fields ) . ')';
342 my $ref_table = unreserve($c->reference_table);
344 $def .= " REFERENCES $ref_table";
347 $def .= ' (' . join( ', ', @rfields ) . ')';
350 if ( $c->match_type ) {
352 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
355 if ( $c->on_delete ) {
356 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
359 if ( $c->on_update ) {
360 $def .= ' ON UPDATE '.join( ' ', $c->on_update );
363 push @constraint_defs, $def;
371 for my $index ( $table->get_indices ) {
372 my $index_name = $index->name || '';
373 my $index_type = $index->type || NORMAL;
374 my @fields = map { unreserve( $_, $table_name ) }
378 if ( $index_type eq PRIMARY_KEY ) {
379 $index_name = mk_name( $table_name, 'pk' );
380 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
381 '(' . join( ', ', @fields ) . ')';
383 elsif ( $index_type eq NORMAL ) {
384 $index_name = mk_name( $table_name, $index_name || 'i' );
386 "CREATE INDEX $index_name on $table_name_ur (".
387 join( ', ', @fields ).
391 warn "Unknown index type ($index_type) on table $table_name.\n"
396 my $create_statement;
397 $create_statement = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
399 if ( my @table_comments = $table->comments ) {
400 for my $comment ( @table_comments ) {
401 next unless $comment;
402 push @field_comments, "COMMENT ON TABLE $table_name is\n '".
408 $create_statement .= "CREATE TABLE $table_name_ur (\n" .
409 join( ",\n", map { " $_" } @field_defs, @constraint_defs ) .
413 $output .= join( "\n\n",
425 warn "Truncated " . keys( %truncated ) . " names:\n";
426 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
430 warn "Encounted " . keys( %unreserve ) .
431 " unsafe names in schema (reserved or invalid):\n";
432 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
439 # -------------------------------------------------------------------
441 my $basename = shift || '';
442 my $type = shift || '';
443 $type = '' if $type =~ /^\d/;
444 my $scope = shift || '';
445 my $critical = shift || '';
446 my $basename_orig = $basename;
448 ? $max_id_length - (length($type) + 1)
450 $basename = substr( $basename, 0, $max_name )
451 if length( $basename ) > $max_name;
452 my $name = $type ? "${type}_$basename" : $basename;
454 if ( $basename ne $basename_orig and $critical ) {
455 my $show_type = $type ? "+'$type'" : "";
456 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
457 "character limit to make '$name'\n" if $WARN;
458 $truncated{ $basename_orig } = $name;
461 $scope ||= \%global_names;
462 if ( my $prev = $scope->{ $name } ) {
463 my $name_orig = $name;
464 $name .= sprintf( "%02d", ++$prev );
465 substr($name, $max_id_length - 3) = "00"
466 if length( $name ) > $max_id_length;
468 warn "The name '$name_orig' has been changed to ",
469 "'$name' to make it unique.\n" if $WARN;
471 $scope->{ $name_orig }++;
478 # -------------------------------------------------------------------
480 my $name = shift || '';
481 my $schema_obj_name = shift || '';
483 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
485 # also trap fields that don't begin with a letter
486 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
488 if ( $schema_obj_name ) {
489 ++$unreserve{"$schema_obj_name.$name"};
492 ++$unreserve{"$name (table name)"};
495 my $unreserve = sprintf '%s_', $name;
496 return $unreserve.$suffix;
501 # -------------------------------------------------------------------
502 # All bad art is the result of good intentions.
504 # -------------------------------------------------------------------
508 SQL::Translator::Producer::Oracle - Oracle SQL producer
512 use SQL::Translator::Parser::MySQL;
513 use SQL::Translator::Producer::Oracle;
515 my $original_create = ""; # get this from somewhere...
516 my $translator = SQL::Translator->new;
518 $translator->parser("SQL::Translator::Parser::MySQL");
519 $translator->producer("SQL::Translator::Producer::Oracle");
521 my $new_create = $translator->translate($original_create);
525 SQL::Translator::Producer::Oracle takes a parsed data structure,
526 created by a SQL::Translator::Parser subclass, and turns it into a
527 create string suitable for use with an Oracle database.
531 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
532 his "mysql2ora" script.
536 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>