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);
121 double => [ 'float', 126 ],
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 = quote($c->reference_fields,$qf);
331 next if !@fields && $c->type ne CHECK_C;
333 if ( $c->type eq PRIMARY_KEY ) {
334 # create a name if delay_constraints
335 $name ||= mk_name( $table_name, 'pk' )
336 if $options->{delay_constraints};
337 $name = quote($name,$qf);
338 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
339 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
341 elsif ( $c->type eq UNIQUE ) {
342 # Don't create UNIQUE constraints identical to the primary key
343 if ( my $pk = $table->primary_key ) {
344 my $u_fields = join(":", @fields);
345 my $pk_fields = join(":", $pk->fields);
346 next if $u_fields eq $pk_fields;
350 # Force prepend of table_name as ORACLE doesn't allow duplicate
351 # CONSTRAINT names even for different tables (ORA-02264)
352 $name = "${table_name}_$name" unless $name =~ /^$table_name/;
355 $name = mk_name( $table_name, 'u' );
358 $name = quote($name, $qf);
360 for my $f ( $c->fields ) {
361 my $field_def = $table->get_field( $f ) or next;
362 my $dtype = $translate{ ref $field_def->data_type eq "ARRAY" ? $field_def->data_type->[0] : $field_def->data_type} or next;
363 if ( $WARN && $dtype =~ /clob/i ) {
364 warn "Oracle will not allow UNIQUE constraints on " .
365 "CLOB field '" . $field_def->table->name . '.' .
366 $field_def->name . ".'\n"
370 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
371 '(' . join( ', ', @fields ) . ')';
373 elsif ( $c->type eq CHECK_C ) {
374 $name ||= mk_name( $name || $table_name, 'ck' );
375 $name = quote($name, $qf);
376 my $expression = $c->expression || '';
377 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
379 elsif ( $c->type eq FOREIGN_KEY ) {
380 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
381 $name = quote($name, $qf);
382 my $def = "CONSTRAINT $name FOREIGN KEY ";
385 $def .= '(' . join( ', ', @fields ) . ')';
388 my $ref_table = quote($c->reference_table,$qt);
390 $def .= " REFERENCES $ref_table";
393 $def .= ' (' . join( ', ', @rfields ) . ')';
396 if ( $c->match_type ) {
398 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
401 if ( $c->on_delete ) {
402 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
405 # disabled by plu 2007-12-29 - doesn't exist for oracle
406 #if ( $c->on_update ) {
407 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
410 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
418 for my $index ( $table->get_indices ) {
419 my $index_name = $index->name || '';
420 my $index_type = $index->type || NORMAL;
421 my @fields = map { quote($_, $qf) } $index->fields;
425 for my $opt ( $index->options ) {
426 if ( ref $opt eq 'HASH' ) {
427 my ( $key, $value ) = each %$opt;
428 if ( ref $value eq 'ARRAY' ) {
429 push @table_options, "$key\n(\n". join ("\n",
430 map { " $_->[0]\t$_->[1]" }
435 elsif ( !defined $value ) {
436 push @index_options, $key;
439 push @index_options, "$key $value";
443 my $index_options = @index_options
444 ? "\n".join("\n", @index_options) : '';
446 if ( $index_type eq PRIMARY_KEY ) {
447 $index_name = $index_name ? mk_name( $index_name )
448 : mk_name( $table_name, 'pk' );
449 $index_name = quote($index_name, $qf);
450 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
451 '(' . join( ', ', @fields ) . ')';
453 elsif ( $index_type eq NORMAL ) {
454 $index_name = $index_name ? mk_name( $index_name )
455 : mk_name( $table_name, $index_name || 'i' );
456 $index_name = quote($index_name, $qf);
458 "CREATE INDEX $index_name on $table_name_q (".
459 join( ', ', @fields ).
462 elsif ( $index_type eq UNIQUE ) {
463 $index_name = $index_name ? mk_name( $index_name )
464 : mk_name( $table_name, $index_name || 'i' );
465 $index_name = quote($index_name, $qf);
467 "CREATE UNIQUE INDEX $index_name on $table_name_q (".
468 join( ', ', @fields ).
472 warn "Unknown index type ($index_type) on table $table_name.\n"
477 if ( my @table_comments = $table->comments ) {
478 for my $comment ( @table_comments ) {
479 next unless $comment;
480 $comment =~ s/'/''/g;
481 push @field_comments, "COMMENT ON TABLE $table_name_q is\n '".
482 $comment . "'" unless $options->{no_comments}
487 my $table_options = @table_options
488 ? "\n".join("\n", @table_options) : '';
489 push @create, "CREATE TABLE $table_name_q (\n" .
490 join( ",\n", map { " $_" } @field_defs,
491 ($options->{delay_constraints} ? () : @constraint_defs) ) .
494 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
499 warn "Truncated " . keys( %truncated ) . " names:\n";
500 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
504 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
508 my ($from_field, $to_field, $options) = @_;
510 my $qt = $options->{quote_table_names};
511 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
512 create_field($to_field, $options, {});
515 if ($to_field->is_nullable && !$from_field->is_nullable) {
516 die 'Cannot remove NOT NULL from table field';
517 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
518 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
521 my $table_name = quote($to_field->table->name,$qt);
523 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
527 my ($new_field, $options) = @_;
529 my $qt = $options->{quote_table_names};
530 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
531 create_field($new_field, $options, {});
533 my $table_name = quote($new_field->table->name,$qt);
535 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
537 join('', @$field_defs));
542 my ($field, $options, $field_name_scope) = @_;
543 my $qf = $options->{quote_field_names};
544 my $qt = $options->{quote_table_names};
546 my (@create, @field_defs, @trigger_defs, @field_comments);
548 my $table_name = $field->table->name;
549 my $table_name_q = quote($table_name, $qt);
554 my $field_name = mk_name(
555 $field->name, '', $field_name_scope, 1
557 my $field_name_q = quote($field_name, $qf);
558 my $field_def = quote($field_name, $qf);
559 $field->name( $field_name );
565 my $data_type = lc $field->data_type;
566 my @size = $field->size;
567 my %extra = $field->extra;
568 my $list = $extra{'list'} || [];
569 # \todo deal with embedded quotes
570 my $commalist = join( ', ', map { qq['$_'] } @$list );
572 if ( $data_type eq 'enum' ) {
573 $check = "CHECK ($field_name_q IN ($commalist))";
574 $data_type = 'varchar2';
576 elsif ( $data_type eq 'set' ) {
577 # XXX add a CHECK constraint maybe
578 # (trickier and slower, than enum :)
579 $data_type = 'varchar2';
582 if (defined $translate{ $data_type }) {
583 if (ref $translate{ $data_type } eq "ARRAY") {
584 ($data_type,$size[0]) = @{$translate{ $data_type }};
586 $data_type = $translate{ $data_type };
589 $data_type ||= 'varchar2';
592 # ensure size is not bigger than max size oracle allows for data type
593 if ( defined $max_size{$data_type} ) {
594 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
596 ref( $max_size{$data_type} ) eq 'ARRAY'
597 ? $max_size{$data_type}->[$i]
598 : $max_size{$data_type};
599 $size[$i] = $max if $size[$i] > $max;
604 # Fixes ORA-02329: column of datatype LOB cannot be
605 # unique or a primary key
607 if ( $data_type eq 'clob' && $field->is_primary_key ) {
608 $data_type = 'varchar2';
610 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
614 if ( $data_type eq 'clob' && $field->is_unique ) {
615 $data_type = 'varchar2';
617 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
622 # Fixes ORA-00907: missing right parenthesis
624 if ( $data_type =~ /(date|clob)/i ) {
629 # Fixes ORA-00906: missing right parenthesis
630 # if size is 0 or undefined
633 if ( $data_type =~ /^($_)$/i ) {
634 $size[0] ||= $max_size{$_};
638 $field_def .= " $data_type";
639 if ( defined $size[0] && $size[0] > 0 ) {
640 $field_def .= '(' . join( ',', @size ) . ')';
646 my $default = $field->default_value;
647 if ( defined $default ) {
649 # Wherein we try to catch a string being used as
650 # a default value for a numerical field. If "true/false,"
651 # then sub "1/0," otherwise just test the truthity of the
652 # argument and use that (naive?).
654 if (ref $default and defined $$default) {
655 $default = $$default;
656 } elsif (ref $default) {
659 $data_type =~ /^number$/i &&
660 $default !~ /^-?\d+$/ &&
663 if ( $default =~ /^true$/i ) {
665 } elsif ( $default =~ /^false$/i ) {
668 $default = $default ? "'1'" : "'0'";
671 $data_type =~ /date/ && (
672 $default eq 'current_timestamp'
677 $default = 'SYSDATE';
679 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
682 $field_def .= " DEFAULT $default",
686 # Not null constraint
688 unless ( $field->is_nullable ) {
689 $field_def .= ' NOT NULL';
692 $field_def .= " $check" if $check;
697 if ( $field->is_auto_increment ) {
698 my $base_name = $table_name . "_". $field_name;
699 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
700 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
702 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
703 push @create, "CREATE SEQUENCE $seq_name";
705 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
706 "BEFORE INSERT ON $table_name_q\n" .
707 "FOR EACH ROW WHEN (\n" .
708 " new.$field_name_q IS NULL".
709 " OR new.$field_name_q = 0\n".
712 " SELECT $seq_name.nextval\n" .
713 " INTO :new." . $field_name_q."\n" .
717 push @trigger_defs, $trigger;
720 if ( lc $field->data_type eq 'timestamp' ) {
721 my $base_name = $table_name . "_". $field_name;
722 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
724 "CREATE OR REPLACE TRIGGER $trig_name\n".
725 "BEFORE INSERT OR UPDATE ON $table_name_q\n".
726 "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
728 " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
731 push @trigger_defs, $trigger;
734 push @field_defs, $field_def;
736 if ( my $comment = $field->comments ) {
737 $comment =~ s/'/''/g;
738 push @field_comments,
739 "COMMENT ON COLUMN $table_name_q.$field_name_q is\n '" .
740 $comment . "';" unless $options->{no_comments};
743 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
749 my ($view, $options) = @_;
750 my $qt = $options->{quote_table_names};
751 my $view_name = quote($view->name,$qt);
754 push @create, qq[DROP VIEW $view_name]
755 if $options->{add_drop_view};
757 push @create, sprintf("CREATE VIEW %s AS\n%s",
764 # -------------------------------------------------------------------
766 my $basename = shift || '';
767 my $type = shift || '';
768 $type = '' if $type =~ /^\d/;
769 my $scope = shift || '';
770 my $critical = shift || '';
771 my $basename_orig = $basename;
773 ? $max_id_length - (length($type) + 1)
775 $basename = substr( $basename, 0, $max_name )
776 if length( $basename ) > $max_name;
777 my $name = $type ? "${type}_$basename" : $basename;
779 if ( $basename ne $basename_orig and $critical ) {
780 my $show_type = $type ? "+'$type'" : "";
781 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
782 "character limit to make '$name'\n" if $WARN;
783 $truncated{ $basename_orig } = $name;
786 $scope ||= \%global_names;
787 if ( my $prev = $scope->{ $name } ) {
788 my $name_orig = $name;
789 substr($name, $max_id_length - 2) = ""
790 if length( $name ) >= $max_id_length - 1;
791 $name .= sprintf( "%02d", $prev++ );
793 warn "The name '$name_orig' has been changed to ",
794 "'$name' to make it unique.\n" if $WARN;
796 $scope->{ $name_orig }++;
805 # -------------------------------------------------------------------
808 $q && $name ? "$quote_char$name$quote_char" : $name;
812 # -------------------------------------------------------------------
813 # All bad art is the result of good intentions.
815 # -------------------------------------------------------------------
821 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
826 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
827 Alexander Hartmaier E<lt>abraxxa@cpan.orgE<gt>,
828 Fabien Wernli E<lt>faxmodem@cpan.orgE<gt>.
832 SQL::Translator, DDL::Oracle, mysql2ora.