1 package SQL::Translator::Producer::Oracle;
3 # -------------------------------------------------------------------
4 # Copyright (C) 2002-2009 SQLFairy Authors
6 # This program is free software; you can redistribute it and/or
7 # modify it under the terms of the GNU General Public License as
8 # published by the Free Software Foundation; version 2.
10 # This program is distributed in the hope that it will be useful, but
11 # WITHOUT ANY WARRANTY; without even the implied warranty of
12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 # General Public License for more details.
15 # You should have received a copy of the GNU General Public License
16 # along with this program; if not, write to the Free Software
17 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
19 # -------------------------------------------------------------------
23 SQL::Translator::Producer::Oracle - Oracle SQL producer
29 my $t = SQL::Translator->new( parser => '...', producer => 'Oracle' );
30 print $translator->translate( $file );
34 Creates an SQL DDL suitable for Oracle.
40 =item delay_constraints
42 This option remove the primary key and other key constraints from the
43 CREATE TABLE statement and adds ALTER TABLEs at the end with it.
49 =head2 Autoincremental primary keys
51 This producer uses sequences and triggers to autoincrement primary key
52 columns, if necessary. SQLPlus and DBI expect a slightly different syntax
53 of CREATE TRIGGER statement. You might have noticed that this
54 producer returns a scalar containing all statements concatenated by
55 newlines or an array of single statements depending on the context
56 (scalar, array) it has been called in.
58 SQLPlus expects following trigger syntax:
60 CREATE OR REPLACE TRIGGER ai_person_id
61 BEFORE INSERT ON person
63 new.id IS NULL OR new.id = 0
66 SELECT sq_person_id.nextval
72 Whereas if you want to create the same trigger using L<DBI/do>, you need
73 to omit the last slash:
75 my $dbh = DBI->connect('dbi:Oracle:mysid', 'scott', 'tiger');
77 CREATE OR REPLACE TRIGGER ai_person_id
78 BEFORE INSERT ON person
80 new.id IS NULL OR new.id = 0
83 SELECT sq_person_id.nextval
89 If you call this producer in array context, we expect you want to process
90 the returned array of statements using L<DBI> like
91 L<DBIx::Class::Schema/deploy> does.
93 To get this working we removed the slash in those statements in version
94 0.09002 of L<SQL::Translator> when called in array context. In scalar
95 context the slash will be still there to ensure compatibility with SQLPlus.
100 use vars qw[ $VERSION $DEBUG $WARN ];
102 $DEBUG = 0 unless defined $DEBUG;
104 use SQL::Translator::Schema::Constants;
105 use SQL::Translator::Utils qw(header_comment);
117 mediumint => 'number',
118 smallint => 'number',
121 varchar => 'varchar2',
124 mediumblob => 'blob',
126 tinytext => 'varchar2',
129 mediumtext => 'clob',
142 'double precision' => 'number',
144 bigserial => 'number',
147 'character varying' => 'varchar2',
149 interval => 'number',
160 macaddr => 'varchar2',
162 'bit varying' => 'number',
168 varchar2 => 'varchar2',
173 # Oracle reserved words from:
174 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
175 # 817_doc/server.817/a85397/ap_keywd.htm
177 my %ora_reserved = map { $_, 1 } qw(
178 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
180 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
181 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
182 ELSE EXCLUSIVE EXISTS
186 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
187 INTEGER INTERSECT INTO IS
189 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
190 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
191 OF OFFLINE ON ONLINE OPTION OR ORDER
192 PCTFREE PRIOR PRIVILEGES PUBLIC
193 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
194 SELECT SESSION SET SHARE SIZE SMALLINT START
195 SUCCESSFUL SYNONYM SYSDATE
196 TABLE THEN TO TRIGGER
197 UID UNION UNIQUE UPDATE USER
198 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
203 # Oracle 8/9 max size of data types from:
204 # http://www.ss64.com/orasyntax/datatypes.html
210 number => [ 38, 127 ],
212 varchar => 4000, # only synonym for varchar2
216 my $max_id_length = 30;
217 my %used_identifiers = ();
222 # -------------------------------------------------------------------
224 my $translator = shift;
225 $DEBUG = $translator->debug;
226 $WARN = $translator->show_warnings || 0;
227 my $no_comments = $translator->no_comments;
228 my $add_drop_table = $translator->add_drop_table;
229 my $schema = $translator->schema;
230 my $delay_constraints = $translator->producer_args->{delay_constraints};
231 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
233 $create .= header_comment unless ($no_comments);
235 if ( $translator->parser_type =~ /mysql/i ) {
237 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
238 "-- but we set it here anyway to be self-consistent.\n"
242 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
245 for my $table ( $schema->get_tables ) {
246 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
249 add_drop_table => $add_drop_table,
250 show_warnings => $WARN,
251 no_comments => $no_comments,
252 delay_constraints => $delay_constraints,
253 wantarray => wantarray ? 1 : 0,
256 push @table_defs, @$table_def;
257 push @fk_defs, @$fk_def;
258 push @trigger_defs, @$trigger_def;
259 push @index_defs, @$index_def;
260 push @constraint_defs, @$constraint_def;
264 foreach my $view ( $schema->get_views ) {
265 push @view_defs, create_view($view);
269 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
272 $create .= join ('', map { $_ ? "$_;\n\n" : () } @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
273 # triggers may NOT end with a semicolon
274 $create .= join "\n\n", @trigger_defs;
280 my ($table, $options) = @_;
281 my $table_name = $table->name;
285 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
287 my $table_name_ur = unreserve($table_name) or next;
289 push @create, "--\n-- Table: $table_name_ur\n--" unless $options->{no_comments};
290 push @create, qq[DROP TABLE $table_name_ur CASCADE CONSTRAINTS] if $options->{add_drop_table};
292 my ( %field_name_scope, @field_comments );
293 for my $field ( $table->get_fields ) {
294 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
295 create_field($field, $options, \%field_name_scope);
296 push @create, @$field_create if ref $field_create;
297 push @field_defs, @$field_defs if ref $field_defs;
298 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
299 push @field_comments, @$field_comments if ref $field_comments;
306 for my $opt ( $table->options ) {
307 if ( ref $opt eq 'HASH' ) {
308 my ( $key, $value ) = each %$opt;
309 if ( ref $value eq 'ARRAY' ) {
310 push @table_options, "$key\n(\n". join ("\n",
311 map { " $_->[0]\t$_->[1]" }
316 elsif ( !defined $value ) {
317 push @table_options, $key;
320 push @table_options, "$key $value";
328 for my $c ( $table->get_constraints ) {
329 my $name = $c->name || '';
330 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
331 my @rfields = map { unreserve( $_, $table_name ) }
332 $c->reference_fields;
333 next if !@fields && $c->type ne CHECK_C;
335 if ( $c->type eq PRIMARY_KEY ) {
336 # create a name if delay_constraints
337 $name ||= mk_name( $table_name, 'pk' )
338 if $options->{delay_constraints};
339 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
340 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
342 elsif ( $c->type eq UNIQUE ) {
343 # Don't create UNIQUE constraints identical to the primary key
344 if ( my $pk = $table->primary_key ) {
345 my $u_fields = join(":", @fields);
346 my $pk_fields = join(":", $pk->fields);
347 next if $u_fields eq $pk_fields;
350 $name ||= mk_name( $name || $table_name, 'u' );
352 for my $f ( $c->fields ) {
353 my $field_def = $table->get_field( $f ) or next;
354 my $dtype = $translate{ $field_def->data_type } or next;
355 if ( $WARN && $dtype =~ /clob/i ) {
356 warn "Oracle will not allow UNIQUE constraints on " .
357 "CLOB field '" . $field_def->table->name . '.' .
358 $field_def->name . ".'\n"
362 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
363 '(' . join( ', ', @fields ) . ')';
365 elsif ( $c->type eq CHECK_C ) {
366 $name ||= mk_name( $name || $table_name, 'ck' );
367 my $expression = $c->expression || '';
368 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
370 elsif ( $c->type eq FOREIGN_KEY ) {
371 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
372 my $def = "CONSTRAINT $name FOREIGN KEY ";
375 $def .= '(' . join( ', ', @fields ) . ')';
378 my $ref_table = unreserve($c->reference_table);
380 $def .= " REFERENCES $ref_table";
383 $def .= ' (' . join( ', ', @rfields ) . ')';
386 if ( $c->match_type ) {
388 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
391 if ( $c->on_delete ) {
392 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
395 # disabled by plu 2007-12-29 - doesn't exist for oracle
396 #if ( $c->on_update ) {
397 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
400 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_ur, $def);
408 for my $index ( $table->get_indices ) {
409 my $index_name = $index->name || '';
410 my $index_type = $index->type || NORMAL;
411 my @fields = map { unreserve( $_, $table_name ) }
416 for my $opt ( $index->options ) {
417 if ( ref $opt eq 'HASH' ) {
418 my ( $key, $value ) = each %$opt;
419 if ( ref $value eq 'ARRAY' ) {
420 push @table_options, "$key\n(\n". join ("\n",
421 map { " $_->[0]\t$_->[1]" }
426 elsif ( !defined $value ) {
427 push @index_options, $key;
430 push @index_options, "$key $value";
434 my $index_options = @index_options
435 ? "\n".join("\n", @index_options) : '';
437 if ( $index_type eq PRIMARY_KEY ) {
438 $index_name = $index_name ? mk_name( $index_name )
439 : mk_name( $table_name, 'pk' );
440 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
441 '(' . join( ', ', @fields ) . ')';
443 elsif ( $index_type eq NORMAL ) {
444 $index_name = $index_name ? mk_name( $index_name )
445 : mk_name( $table_name, $index_name || 'i' );
447 "CREATE INDEX $index_name on $table_name_ur (".
448 join( ', ', @fields ).
451 elsif ( $index_type eq UNIQUE ) {
452 $index_name = $index_name ? mk_name( $index_name )
453 : mk_name( $table_name, $index_name || 'i' );
455 "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
456 join( ', ', @fields ).
460 warn "Unknown index type ($index_type) on table $table_name.\n"
465 if ( my @table_comments = $table->comments ) {
466 for my $comment ( @table_comments ) {
467 next unless $comment;
468 $comment =~ s/'/''/g;
469 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
470 $comment . "'" unless $options->{no_comments}
475 my $table_options = @table_options
476 ? "\n".join("\n", @table_options) : '';
477 push @create, "CREATE TABLE $table_name_ur (\n" .
478 join( ",\n", map { " $_" } @field_defs,
479 ($options->{delay_constraints} ? () : @constraint_defs) ) .
482 @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_ }
487 warn "Truncated " . keys( %truncated ) . " names:\n";
488 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
492 warn "Encounted " . keys( %unreserve ) .
493 " unsafe names in schema (reserved or invalid):\n";
494 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
498 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
502 my ($from_field, $to_field, $options) = @_;
504 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
505 create_field($to_field, $options, {});
508 if ($to_field->is_nullable && !$from_field->is_nullable) {
509 die 'Cannot remove NOT NULL from table field';
510 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
511 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
514 my $table_name = $to_field->table->name;
515 my $table_name_ur = unreserve( $table_name );
517 return 'ALTER TABLE '.$table_name_ur.' MODIFY ( '.join('', @$field_defs).' )';
521 my ($new_field, $options) = @_;
523 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
524 create_field($new_field, $options, {});
526 my $table_name = $new_field->table->name;
527 my $table_name_ur = unreserve( $table_name );
529 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
531 join('', @$field_defs));
536 my ($field, $options, $field_name_scope) = @_;
538 my (@create, @field_defs, @trigger_defs, @field_comments);
540 my $table_name = $field->table->name;
541 my $table_name_ur = unreserve( $table_name );
546 my $field_name = mk_name(
547 $field->name, '', $field_name_scope, 1
550 my $field_name_ur = unreserve( $field_name, $table_name );
551 my $field_def = $field_name_ur;
552 $field->name( $field_name_ur );
558 my $data_type = lc $field->data_type;
559 my @size = $field->size;
560 my %extra = $field->extra;
561 my $list = $extra{'list'} || [];
562 # \todo deal with embedded quotes
563 my $commalist = join( ', ', map { qq['$_'] } @$list );
565 if ( $data_type eq 'enum' ) {
566 $check = "CHECK ($field_name_ur IN ($commalist))";
567 $data_type = 'varchar2';
569 elsif ( $data_type eq 'set' ) {
570 # XXX add a CHECK constraint maybe
571 # (trickier and slower, than enum :)
572 $data_type = 'varchar2';
575 $data_type = defined $translate{ $data_type } ?
576 $translate{ $data_type } :
578 $data_type ||= 'varchar2';
581 # ensure size is not bigger than max size oracle allows for data type
582 if ( defined $max_size{$data_type} ) {
583 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
585 ref( $max_size{$data_type} ) eq 'ARRAY'
586 ? $max_size{$data_type}->[$i]
587 : $max_size{$data_type};
588 $size[$i] = $max if $size[$i] > $max;
593 # Fixes ORA-02329: column of datatype LOB cannot be
594 # unique or a primary key
596 if ( $data_type eq 'clob' && $field->is_primary_key ) {
597 $data_type = 'varchar2';
599 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
603 if ( $data_type eq 'clob' && $field->is_unique ) {
604 $data_type = 'varchar2';
606 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
611 # Fixes ORA-00907: missing right parenthesis
613 if ( $data_type =~ /(date|clob)/i ) {
617 $field_def .= " $data_type";
618 if ( defined $size[0] && $size[0] > 0 ) {
619 $field_def .= '(' . join( ',', @size ) . ')';
625 my $default = $field->default_value;
626 if ( defined $default ) {
628 # Wherein we try to catch a string being used as
629 # a default value for a numerical field. If "true/false,"
630 # then sub "1/0," otherwise just test the truthity of the
631 # argument and use that (naive?).
633 if (ref $default and defined $$default) {
634 $default = $$default;
635 } elsif (ref $default) {
638 $data_type =~ /^number$/i &&
639 $default !~ /^-?\d+$/ &&
642 if ( $default =~ /^true$/i ) {
644 } elsif ( $default =~ /^false$/i ) {
647 $default = $default ? "'1'" : "'0'";
650 $data_type =~ /date/ && (
651 $default eq 'current_timestamp'
656 $default = 'SYSDATE';
658 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
661 $field_def .= " DEFAULT $default",
665 # Not null constraint
667 unless ( $field->is_nullable ) {
668 $field_def .= ' NOT NULL';
671 $field_def .= " $check" if $check;
676 if ( $field->is_auto_increment ) {
677 my $base_name = $table_name_ur . "_". $field_name;
678 my $seq_name = mk_name( $base_name, 'sq' );
679 my $trigger_name = mk_name( $base_name, 'ai' );
681 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
682 push @create, "CREATE SEQUENCE $seq_name";
684 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
685 "BEFORE INSERT ON $table_name_ur\n" .
686 "FOR EACH ROW WHEN (\n" .
687 " new.$field_name_ur IS NULL".
688 " OR new.$field_name_ur = 0\n".
691 " SELECT $seq_name.nextval\n" .
692 " INTO :new." . $field->name."\n" .
697 # If wantarray is set we have to omit the last "/" in this statement so it
698 # can be executed by DBI->do() directly.
700 $trigger .= "/" unless $options->{wantarray};
702 push @trigger_defs, $trigger;
705 if ( lc $field->data_type eq 'timestamp' ) {
706 my $base_name = $table_name_ur . "_". $field_name_ur;
707 my $trig_name = mk_name( $base_name, 'ts' );
709 "CREATE OR REPLACE TRIGGER $trig_name\n".
710 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
711 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
713 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
717 # If wantarray is set we have to omit the last "/" in this statement so it
718 # can be executed by DBI->do() directly.
720 $trigger .= "/" unless $options->{wantarray};
722 push @trigger_defs, $trigger;
725 push @field_defs, $field_def;
727 if ( my $comment = $field->comments ) {
728 $comment =~ s/'/''/g;
729 push @field_comments,
730 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
731 $comment . "';" unless $options->{no_comments};
734 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
742 my $out = sprintf("CREATE VIEW %s AS\n%s",
749 # -------------------------------------------------------------------
751 my $basename = shift || '';
752 my $type = shift || '';
753 $type = '' if $type =~ /^\d/;
754 my $scope = shift || '';
755 my $critical = shift || '';
756 my $basename_orig = $basename;
758 ? $max_id_length - (length($type) + 1)
760 $basename = substr( $basename, 0, $max_name )
761 if length( $basename ) > $max_name;
762 my $name = $type ? "${type}_$basename" : $basename;
764 if ( $basename ne $basename_orig and $critical ) {
765 my $show_type = $type ? "+'$type'" : "";
766 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
767 "character limit to make '$name'\n" if $WARN;
768 $truncated{ $basename_orig } = $name;
771 $scope ||= \%global_names;
772 if ( my $prev = $scope->{ $name } ) {
773 my $name_orig = $name;
774 substr($name, $max_id_length - 2) = ""
775 if length( $name ) >= $max_id_length - 1;
776 $name .= sprintf( "%02d", $prev++ );
778 warn "The name '$name_orig' has been changed to ",
779 "'$name' to make it unique.\n" if $WARN;
781 $scope->{ $name_orig }++;
788 # -------------------------------------------------------------------
790 my $name = shift || '';
791 my $schema_obj_name = shift || '';
793 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
795 # also trap fields that don't begin with a letter
796 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
798 if ( $schema_obj_name ) {
799 ++$unreserve{"$schema_obj_name.$name"};
802 ++$unreserve{"$name (table name)"};
805 my $unreserve = sprintf '%s_', $name;
806 return $unreserve.$suffix;
811 # -------------------------------------------------------------------
812 # All bad art is the result of good intentions.
814 # -------------------------------------------------------------------
820 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
825 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
829 SQL::Translator, DDL::Oracle, mysql2ora.