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 $on_delete = uc ($c->on_delete || '');
385 my $def = "CONSTRAINT $name FOREIGN KEY ";
388 $def .= '(' . join( ', ', @fields ) . ')';
391 my $ref_table = quote($c->reference_table,$qt);
393 $def .= " REFERENCES $ref_table";
396 $def .= ' (' . join( ', ', @rfields ) . ')';
399 if ( $c->match_type ) {
401 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
404 if ( $on_delete && $on_delete ne "RESTRICT") {
405 $def .= ' ON DELETE '.$c->on_delete;
408 # disabled by plu 2007-12-29 - doesn't exist for oracle
409 #if ( $c->on_update ) {
410 # $def .= ' ON UPDATE '. $c->on_update;
413 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
421 for my $index ( $table->get_indices ) {
422 my $index_name = $index->name || '';
423 my $index_type = $index->type || NORMAL;
424 my @fields = map { quote($_, $qf) } $index->fields;
428 for my $opt ( $index->options ) {
429 if ( ref $opt eq 'HASH' ) {
430 my ( $key, $value ) = each %$opt;
431 if ( ref $value eq 'ARRAY' ) {
432 push @table_options, "$key\n(\n". join ("\n",
433 map { " $_->[0]\t$_->[1]" }
438 elsif ( !defined $value ) {
439 push @index_options, $key;
442 push @index_options, "$key $value";
446 my $index_options = @index_options
447 ? "\n".join("\n", @index_options) : '';
449 if ( $index_type eq PRIMARY_KEY ) {
450 $index_name = $index_name ? mk_name( $index_name )
451 : mk_name( $table_name, 'pk' );
452 $index_name = quote($index_name, $qf);
453 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
454 '(' . join( ', ', @fields ) . ')';
456 elsif ( $index_type eq NORMAL ) {
457 $index_name = $index_name ? mk_name( $index_name )
458 : mk_name( $table_name, $index_name || 'i' );
459 $index_name = quote($index_name, $qf);
461 "CREATE INDEX $index_name on $table_name_q (".
462 join( ', ', @fields ).
465 elsif ( $index_type eq UNIQUE ) {
466 $index_name = $index_name ? mk_name( $index_name )
467 : mk_name( $table_name, $index_name || 'i' );
468 $index_name = quote($index_name, $qf);
470 "CREATE UNIQUE INDEX $index_name on $table_name_q (".
471 join( ', ', @fields ).
475 warn "Unknown index type ($index_type) on table $table_name.\n"
480 if ( my @table_comments = $table->comments ) {
481 for my $comment ( @table_comments ) {
482 next unless $comment;
483 $comment =~ s/'/''/g;
484 push @field_comments, "COMMENT ON TABLE $table_name_q is\n '".
485 $comment . "'" unless $options->{no_comments}
490 my $table_options = @table_options
491 ? "\n".join("\n", @table_options) : '';
492 push @create, "CREATE TABLE $table_name_q (\n" .
493 join( ",\n", map { " $_" } @field_defs,
494 ($options->{delay_constraints} ? () : @constraint_defs) ) .
497 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
502 warn "Truncated " . keys( %truncated ) . " names:\n";
503 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
507 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
511 my ($from_field, $to_field, $options) = @_;
513 my $qt = $options->{quote_table_names};
514 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
515 create_field($to_field, $options, {});
518 if ($to_field->is_nullable && !$from_field->is_nullable) {
519 die 'Cannot remove NOT NULL from table field';
520 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
521 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
524 my $table_name = quote($to_field->table->name,$qt);
526 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
530 my ($new_field, $options) = @_;
532 my $qt = $options->{quote_table_names};
533 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
534 create_field($new_field, $options, {});
536 my $table_name = quote($new_field->table->name,$qt);
538 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
540 join('', @$field_defs));
545 my ($field, $options, $field_name_scope) = @_;
546 my $qf = $options->{quote_field_names};
547 my $qt = $options->{quote_table_names};
549 my (@create, @field_defs, @trigger_defs, @field_comments);
551 my $table_name = $field->table->name;
552 my $table_name_q = quote($table_name, $qt);
557 my $field_name = mk_name(
558 $field->name, '', $field_name_scope, 1
560 my $field_name_q = quote($field_name, $qf);
561 my $field_def = quote($field_name, $qf);
562 $field->name( $field_name );
568 my $data_type = lc $field->data_type;
569 my @size = $field->size;
570 my %extra = $field->extra;
571 my $list = $extra{'list'} || [];
572 # \todo deal with embedded quotes
573 my $commalist = join( ', ', map { qq['$_'] } @$list );
575 if ( $data_type eq 'enum' ) {
576 $check = "CHECK ($field_name_q IN ($commalist))";
577 $data_type = 'varchar2';
579 elsif ( $data_type eq 'set' ) {
580 # XXX add a CHECK constraint maybe
581 # (trickier and slower, than enum :)
582 $data_type = 'varchar2';
585 if (defined $translate{ $data_type }) {
586 if (ref $translate{ $data_type } eq "ARRAY") {
587 ($data_type,$size[0]) = @{$translate{ $data_type }};
589 $data_type = $translate{ $data_type };
592 $data_type ||= 'varchar2';
595 # ensure size is not bigger than max size oracle allows for data type
596 if ( defined $max_size{$data_type} ) {
597 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
599 ref( $max_size{$data_type} ) eq 'ARRAY'
600 ? $max_size{$data_type}->[$i]
601 : $max_size{$data_type};
602 $size[$i] = $max if $size[$i] > $max;
607 # Fixes ORA-02329: column of datatype LOB cannot be
608 # unique or a primary key
610 if ( $data_type eq 'clob' && $field->is_primary_key ) {
611 $data_type = 'varchar2';
613 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
617 if ( $data_type eq 'clob' && $field->is_unique ) {
618 $data_type = 'varchar2';
620 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
625 # Fixes ORA-00907: missing right parenthesis
627 if ( $data_type =~ /(date|clob)/i ) {
632 # Fixes ORA-00906: missing right parenthesis
633 # if size is 0 or undefined
636 if ( $data_type =~ /^($_)$/i ) {
637 $size[0] ||= $max_size{$_};
641 $field_def .= " $data_type";
642 if ( defined $size[0] && $size[0] > 0 ) {
643 $field_def .= '(' . join( ',', @size ) . ')';
649 my $default = $field->default_value;
650 if ( defined $default ) {
652 # Wherein we try to catch a string being used as
653 # a default value for a numerical field. If "true/false,"
654 # then sub "1/0," otherwise just test the truthity of the
655 # argument and use that (naive?).
657 if (ref $default and defined $$default) {
658 $default = $$default;
659 } elsif (ref $default) {
662 $data_type =~ /^number$/i &&
663 $default !~ /^-?\d+$/ &&
666 if ( $default =~ /^true$/i ) {
668 } elsif ( $default =~ /^false$/i ) {
671 $default = $default ? "'1'" : "'0'";
674 $data_type =~ /date/ && (
675 $default eq 'current_timestamp'
680 $default = 'SYSDATE';
682 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
685 $field_def .= " DEFAULT $default",
689 # Not null constraint
691 unless ( $field->is_nullable ) {
692 $field_def .= ' NOT NULL';
695 $field_def .= " $check" if $check;
700 if ( $field->is_auto_increment ) {
701 my $base_name = $table_name . "_". $field_name;
702 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
703 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
705 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
706 push @create, "CREATE SEQUENCE $seq_name";
708 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
709 "BEFORE INSERT ON $table_name_q\n" .
710 "FOR EACH ROW WHEN (\n" .
711 " new.$field_name_q IS NULL".
712 " OR new.$field_name_q = 0\n".
715 " SELECT $seq_name.nextval\n" .
716 " INTO :new." . $field_name_q."\n" .
720 push @trigger_defs, $trigger;
723 if ( lc $field->data_type eq 'timestamp' ) {
724 my $base_name = $table_name . "_". $field_name;
725 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
727 "CREATE OR REPLACE TRIGGER $trig_name\n".
728 "BEFORE INSERT OR UPDATE ON $table_name_q\n".
729 "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
731 " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
734 push @trigger_defs, $trigger;
737 push @field_defs, $field_def;
739 if ( my $comment = $field->comments ) {
740 $comment =~ s/'/''/g;
741 push @field_comments,
742 "COMMENT ON COLUMN $table_name_q.$field_name_q is\n '" .
743 $comment . "';" unless $options->{no_comments};
746 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
752 my ($view, $options) = @_;
753 my $qt = $options->{quote_table_names};
754 my $view_name = quote($view->name,$qt);
757 push @create, qq[DROP VIEW $view_name]
758 if $options->{add_drop_view};
760 push @create, sprintf("CREATE VIEW %s AS\n%s",
767 # -------------------------------------------------------------------
769 my $basename = shift || '';
770 my $type = shift || '';
771 $type = '' if $type =~ /^\d/;
772 my $scope = shift || '';
773 my $critical = shift || '';
774 my $basename_orig = $basename;
776 ? $max_id_length - (length($type) + 1)
778 $basename = substr( $basename, 0, $max_name )
779 if length( $basename ) > $max_name;
780 my $name = $type ? "${type}_$basename" : $basename;
782 if ( $basename ne $basename_orig and $critical ) {
783 my $show_type = $type ? "+'$type'" : "";
784 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
785 "character limit to make '$name'\n" if $WARN;
786 $truncated{ $basename_orig } = $name;
789 $scope ||= \%global_names;
790 if ( my $prev = $scope->{ $name } ) {
791 my $name_orig = $name;
792 substr($name, $max_id_length - 2) = ""
793 if length( $name ) >= $max_id_length - 1;
794 $name .= sprintf( "%02d", $prev++ );
796 warn "The name '$name_orig' has been changed to ",
797 "'$name' to make it unique.\n" if $WARN;
799 $scope->{ $name_orig }++;
808 # -------------------------------------------------------------------
811 $q && $name ? "$quote_char$name$quote_char" : $name;
815 # -------------------------------------------------------------------
816 # All bad art is the result of good intentions.
818 # -------------------------------------------------------------------
824 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
829 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
830 Alexander Hartmaier E<lt>abraxxa@cpan.orgE<gt>,
831 Fabien Wernli E<lt>faxmodem@cpan.orgE<gt>.
835 SQL::Translator, DDL::Oracle, mysql2ora.