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.
45 =item quote_field_names
47 Controls whether quotes are being used around column names in generated DDL.
49 =item quote_table_names
51 Controls whether quotes are being used around table, sequence and trigger names in
58 =head2 Autoincremental primary keys
60 This producer uses sequences and triggers to autoincrement primary key
61 columns, if necessary. SQLPlus and DBI expect a slightly different syntax
62 of CREATE TRIGGER statement. You might have noticed that this
63 producer returns a scalar containing all statements concatenated by
64 newlines or an array of single statements depending on the context
65 (scalar, array) it has been called in.
67 SQLPlus expects following trigger syntax:
69 CREATE OR REPLACE TRIGGER ai_person_id
70 BEFORE INSERT ON person
72 new.id IS NULL OR new.id = 0
75 SELECT sq_person_id.nextval
81 Whereas if you want to create the same trigger using L<DBI/do>, you need
82 to omit the last slash:
84 my $dbh = DBI->connect('dbi:Oracle:mysid', 'scott', 'tiger');
86 CREATE OR REPLACE TRIGGER ai_person_id
87 BEFORE INSERT ON person
89 new.id IS NULL OR new.id = 0
92 SELECT sq_person_id.nextval
98 If you call this producer in array context, we expect you want to process
99 the returned array of statements using L<DBI> like
100 L<DBIx::Class::Schema/deploy> does.
102 To get this working we removed the slash in those statements in version
103 0.09002 of L<SQL::Translator> when called in array context. In scalar
104 context the slash will be still there to ensure compatibility with SQLPlus.
109 use vars qw[ $VERSION $DEBUG $WARN ];
111 $DEBUG = 0 unless defined $DEBUG;
113 use SQL::Translator::Schema::Constants;
114 use SQL::Translator::Utils qw(header_comment);
126 mediumint => 'number',
127 smallint => 'number',
130 varchar => 'varchar2',
133 mediumblob => 'blob',
135 tinytext => 'varchar2',
138 mediumtext => 'clob',
151 'double precision' => 'number',
153 bigserial => 'number',
156 'character varying' => 'varchar2',
158 interval => 'number',
169 macaddr => 'varchar2',
171 'bit varying' => 'number',
177 varchar2 => 'varchar2',
182 # Oracle 8/9 max size of data types from:
183 # http://www.ss64.com/orasyntax/datatypes.html
190 number => [ 38, 127 ],
192 varchar => 4000, # only synonym for varchar2
196 my $max_id_length = 30;
197 my %used_identifiers = ();
201 # Quote used to escape table, field, sequence and trigger names
202 my $quote_char = '"';
204 # -------------------------------------------------------------------
206 my $translator = shift;
207 $DEBUG = $translator->debug;
208 $WARN = $translator->show_warnings || 0;
209 my $no_comments = $translator->no_comments;
210 my $add_drop_table = $translator->add_drop_table;
211 my $schema = $translator->schema;
212 my $oracle_version = $translator->producer_args->{oracle_version} || 0;
213 my $delay_constraints = $translator->producer_args->{delay_constraints};
214 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
216 $create .= header_comment unless ($no_comments);
217 my $qt = 1 if $translator->quote_table_names;
218 my $qf = 1 if $translator->quote_field_names;
220 if ( $translator->parser_type =~ /mysql/i ) {
222 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
223 "-- but we set it here anyway to be self-consistent.\n"
227 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
230 for my $table ( $schema->get_tables ) {
231 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
234 add_drop_table => $add_drop_table,
235 show_warnings => $WARN,
236 no_comments => $no_comments,
237 delay_constraints => $delay_constraints,
238 quote_table_names => $qt,
239 quote_field_names => $qf,
242 push @table_defs, @$table_def;
243 push @fk_defs, @$fk_def;
244 push @trigger_defs, @$trigger_def;
245 push @index_defs, @$index_def;
246 push @constraint_defs, @$constraint_def;
250 foreach my $view ( $schema->get_views ) {
251 my ( $view_def ) = create_view(
254 add_drop_view => $add_drop_table,
255 quote_table_names => $qt,
258 push @view_defs, @$view_def;
262 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
265 $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
267 # If wantarray is not set we have to add "/" in this statement
268 # DBI->do() needs them omitted
269 # triggers may NOT end with a semicolon
270 $create .= join "/\n\n", @trigger_defs;
278 my ($table, $options) = @_;
279 my $qt = $options->{quote_table_names};
280 my $qf = $options->{quote_field_names};
281 my $table_name = $table->name;
282 my $table_name_q = quote($table_name,$qt);
286 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
288 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
289 push @create, qq[DROP TABLE $table_name_q CASCADE CONSTRAINTS] if $options->{add_drop_table};
291 my ( %field_name_scope, @field_comments );
292 for my $field ( $table->get_fields ) {
293 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
294 create_field($field, $options, \%field_name_scope);
295 push @create, @$field_create if ref $field_create;
296 push @field_defs, @$field_defs if ref $field_defs;
297 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
298 push @field_comments, @$field_comments if ref $field_comments;
305 for my $opt ( $table->options ) {
306 if ( ref $opt eq 'HASH' ) {
307 my ( $key, $value ) = each %$opt;
308 if ( ref $value eq 'ARRAY' ) {
309 push @table_options, "$key\n(\n". join ("\n",
310 map { " $_->[0]\t$_->[1]" }
315 elsif ( !defined $value ) {
316 push @table_options, $key;
319 push @table_options, "$key $value";
327 for my $c ( $table->get_constraints ) {
328 my $name = $c->name || '';
329 my @fields = map { quote($_,$qf) } $c->fields;
330 my @rfields = map { quote($_,$qf) } $c->reference_fields;
332 next if !@fields && $c->type ne CHECK_C;
334 if ( $c->type eq PRIMARY_KEY ) {
335 # create a name if delay_constraints
336 $name ||= mk_name( $table_name, 'pk' )
337 if $options->{delay_constraints};
338 $name = quote($name,$qf);
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;
351 # Force prepend of table_name as ORACLE doesn't allow duplicate
352 # CONSTRAINT names even for different tables (ORA-02264)
353 $name = mk_name( "${table_name}_$name", 'u' ) unless $name =~ /^$table_name/;
356 $name = mk_name( $table_name, 'u' );
359 $name = quote($name, $qf);
361 for my $f ( $c->fields ) {
362 my $field_def = $table->get_field( $f ) or next;
363 my $dtype = $translate{ ref $field_def->data_type eq "ARRAY" ? $field_def->data_type->[0] : $field_def->data_type} or next;
364 if ( $WARN && $dtype =~ /clob/i ) {
365 warn "Oracle will not allow UNIQUE constraints on " .
366 "CLOB field '" . $field_def->table->name . '.' .
367 $field_def->name . ".'\n"
371 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
372 '(' . join( ', ', @fields ) . ')';
374 elsif ( $c->type eq CHECK_C ) {
375 $name ||= mk_name( $name || $table_name, 'ck' );
376 $name = quote($name, $qf);
377 my $expression = $c->expression || '';
378 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
380 elsif ( $c->type eq FOREIGN_KEY ) {
381 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
382 $name = quote($name, $qf);
383 my $def = "CONSTRAINT $name FOREIGN KEY ";
386 $def .= '(' . join( ', ', @fields ) . ')';
389 my $ref_table = quote($c->reference_table,$qt);
391 $def .= " REFERENCES $ref_table";
394 $def .= ' (' . join( ', ', @rfields ) . ')';
397 if ( $c->match_type ) {
399 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
402 if ( $c->on_delete ) {
403 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
406 # disabled by plu 2007-12-29 - doesn't exist for oracle
407 #if ( $c->on_update ) {
408 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
411 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
419 for my $index ( $table->get_indices ) {
420 my $index_name = $index->name || '';
421 my $index_type = $index->type || NORMAL;
422 my @fields = map { quote($_, $qf) } $index->fields;
426 for my $opt ( $index->options ) {
427 if ( ref $opt eq 'HASH' ) {
428 my ( $key, $value ) = each %$opt;
429 if ( ref $value eq 'ARRAY' ) {
430 push @table_options, "$key\n(\n". join ("\n",
431 map { " $_->[0]\t$_->[1]" }
436 elsif ( !defined $value ) {
437 push @index_options, $key;
440 push @index_options, "$key $value";
444 my $index_options = @index_options
445 ? "\n".join("\n", @index_options) : '';
447 if ( $index_type eq PRIMARY_KEY ) {
448 $index_name = $index_name ? mk_name( $index_name )
449 : mk_name( $table_name, 'pk' );
450 $index_name = quote($index_name, $qf);
451 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
452 '(' . join( ', ', @fields ) . ')';
454 elsif ( $index_type eq NORMAL ) {
455 $index_name = $index_name ? mk_name( $index_name )
456 : mk_name( $table_name, $index_name || 'i' );
457 $index_name = quote($index_name, $qf);
459 "CREATE INDEX $index_name on $table_name_q (".
460 join( ', ', @fields ).
463 elsif ( $index_type eq UNIQUE ) {
464 $index_name = $index_name ? mk_name( $index_name )
465 : mk_name( $table_name, $index_name || 'i' );
466 $index_name = quote($index_name, $qf);
468 "CREATE UNIQUE INDEX $index_name on $table_name_q (".
469 join( ', ', @fields ).
473 warn "Unknown index type ($index_type) on table $table_name.\n"
478 if ( my @table_comments = $table->comments ) {
479 for my $comment ( @table_comments ) {
480 next unless $comment;
481 $comment =~ s/'/''/g;
482 push @field_comments, "COMMENT ON TABLE $table_name_q is\n '".
483 $comment . "'" unless $options->{no_comments}
488 my $table_options = @table_options
489 ? "\n".join("\n", @table_options) : '';
490 push @create, "CREATE TABLE $table_name_q (\n" .
491 join( ",\n", map { " $_" } @field_defs,
492 ($options->{delay_constraints} ? () : @constraint_defs) ) .
495 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
500 warn "Truncated " . keys( %truncated ) . " names:\n";
501 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
505 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
509 my ($from_field, $to_field, $options) = @_;
511 my $qt = $options->{quote_table_names};
512 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
513 create_field($to_field, $options, {});
516 if ($to_field->is_nullable && !$from_field->is_nullable) {
517 die 'Cannot remove NOT NULL from table field';
518 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
519 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
522 my $table_name = quote($to_field->table->name,$qt);
524 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
528 my ($new_field, $options) = @_;
530 my $qt = $options->{quote_table_names};
531 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
532 create_field($new_field, $options, {});
534 my $table_name = quote($new_field->table->name,$qt);
536 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
538 join('', @$field_defs));
543 my ($field, $options, $field_name_scope) = @_;
544 my $qf = $options->{quote_field_names};
545 my $qt = $options->{quote_table_names};
547 my (@create, @field_defs, @trigger_defs, @field_comments);
549 my $table_name = $field->table->name;
550 my $table_name_q = quote($table_name, $qt);
555 my $field_name = mk_name(
556 $field->name, '', $field_name_scope, 1
558 my $field_name_q = quote($field_name, $qf);
559 my $field_def = quote($field_name, $qf);
560 $field->name( $field_name );
566 my $data_type = lc $field->data_type;
567 my @size = $field->size;
568 my %extra = $field->extra;
569 my $list = $extra{'list'} || [];
570 # \todo deal with embedded quotes
571 my $commalist = join( ', ', map { qq['$_'] } @$list );
573 if ( $data_type eq 'enum' ) {
574 $check = "CHECK ($field_name_q IN ($commalist))";
575 $data_type = 'varchar2';
577 elsif ( $data_type eq 'set' ) {
578 # XXX add a CHECK constraint maybe
579 # (trickier and slower, than enum :)
580 $data_type = 'varchar2';
583 if (defined $translate{ $data_type }) {
584 if (ref $translate{ $data_type } eq "ARRAY") {
585 ($data_type,$size[0]) = @{$translate{ $data_type }};
587 $data_type = $translate{ $data_type };
590 $data_type ||= 'varchar2';
593 # ensure size is not bigger than max size oracle allows for data type
594 if ( defined $max_size{$data_type} ) {
595 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
597 ref( $max_size{$data_type} ) eq 'ARRAY'
598 ? $max_size{$data_type}->[$i]
599 : $max_size{$data_type};
600 $size[$i] = $max if $size[$i] > $max;
605 # Fixes ORA-02329: column of datatype LOB cannot be
606 # unique or a primary key
608 if ( $data_type eq 'clob' && $field->is_primary_key ) {
609 $data_type = 'varchar2';
611 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
615 if ( $data_type eq 'clob' && $field->is_unique ) {
616 $data_type = 'varchar2';
618 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
623 # Fixes ORA-00907: missing right parenthesis
625 if ( $data_type =~ /(date|clob)/i ) {
630 # Fixes ORA-00906: missing right parenthesis
631 # if size is 0 or undefined
634 if ( $data_type =~ /^($_)$/i ) {
635 $size[0] ||= $max_size{$_};
639 $field_def .= " $data_type";
640 if ( defined $size[0] && $size[0] > 0 ) {
641 $field_def .= '(' . join( ',', @size ) . ')';
647 my $default = $field->default_value;
648 if ( defined $default ) {
650 # Wherein we try to catch a string being used as
651 # a default value for a numerical field. If "true/false,"
652 # then sub "1/0," otherwise just test the truthity of the
653 # argument and use that (naive?).
655 if (ref $default and defined $$default) {
656 $default = $$default;
657 } elsif (ref $default) {
660 $data_type =~ /^number$/i &&
661 $default !~ /^-?\d+$/ &&
664 if ( $default =~ /^true$/i ) {
666 } elsif ( $default =~ /^false$/i ) {
669 $default = $default ? "'1'" : "'0'";
672 $data_type =~ /date/ && (
673 $default eq 'current_timestamp'
678 $default = 'SYSDATE';
680 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
683 $field_def .= " DEFAULT $default",
687 # Not null constraint
689 unless ( $field->is_nullable ) {
690 $field_def .= ' NOT NULL';
693 $field_def .= " $check" if $check;
698 if ( $field->is_auto_increment ) {
699 my $base_name = $table_name . "_". $field_name;
700 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
701 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
703 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
704 push @create, "CREATE SEQUENCE $seq_name";
706 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
707 "BEFORE INSERT ON $table_name_q\n" .
708 "FOR EACH ROW WHEN (\n" .
709 " new.$field_name_q IS NULL".
710 " OR new.$field_name_q = 0\n".
713 " SELECT $seq_name.nextval\n" .
714 " INTO :new." . $field_name_q."\n" .
718 push @trigger_defs, $trigger;
721 if ( lc $field->data_type eq 'timestamp' ) {
722 my $base_name = $table_name . "_". $field_name;
723 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
725 "CREATE OR REPLACE TRIGGER $trig_name\n".
726 "BEFORE INSERT OR UPDATE ON $table_name_q\n".
727 "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
729 " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
732 push @trigger_defs, $trigger;
735 push @field_defs, $field_def;
737 if ( my $comment = $field->comments ) {
738 $comment =~ s/'/''/g;
739 push @field_comments,
740 "COMMENT ON COLUMN $table_name_q.$field_name_q is\n '" .
741 $comment . "';" unless $options->{no_comments};
744 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
750 my ($view, $options) = @_;
751 my $qt = $options->{quote_table_names};
752 my $view_name = quote($view->name,$qt);
755 push @create, qq[DROP VIEW $view_name]
756 if $options->{add_drop_view};
758 push @create, sprintf("CREATE VIEW %s AS\n%s",
765 # -------------------------------------------------------------------
767 my $basename = shift || '';
768 my $type = shift || '';
769 $type = '' if $type =~ /^\d/;
770 my $scope = shift || '';
771 my $critical = shift || '';
772 my $basename_orig = $basename;
774 ? $max_id_length - (length($type) + 1)
776 $basename = substr( $basename, 0, $max_name )
777 if length( $basename ) > $max_name;
778 my $name = $type ? "${type}_$basename" : $basename;
780 if ( $basename ne $basename_orig and $critical ) {
781 my $show_type = $type ? "+'$type'" : "";
782 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
783 "character limit to make '$name'\n" if $WARN;
784 $truncated{ $basename_orig } = $name;
787 $scope ||= \%global_names;
788 if ( my $prev = $scope->{ $name } ) {
789 my $name_orig = $name;
790 substr($name, $max_id_length - 2) = ""
791 if length( $name ) >= $max_id_length - 1;
792 $name .= sprintf( "%02d", $prev++ );
794 warn "The name '$name_orig' has been changed to ",
795 "'$name' to make it unique.\n" if $WARN;
797 $scope->{ $name_orig }++;
806 # -------------------------------------------------------------------
809 $q && $name ? "$quote_char$name$quote_char" : $name;
813 # -------------------------------------------------------------------
814 # All bad art is the result of good intentions.
816 # -------------------------------------------------------------------
822 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
827 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
828 Alexander Hartmaier E<lt>abraxxa@cpan.orgE<gt>,
829 Fabien Wernli E<lt>faxmodem@cpan.orgE<gt>.
833 SQL::Translator, DDL::Oracle, mysql2ora.