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 = '"';
205 my $translator = shift;
206 $DEBUG = $translator->debug;
207 $WARN = $translator->show_warnings || 0;
208 my $no_comments = $translator->no_comments;
209 my $add_drop_table = $translator->add_drop_table;
210 my $schema = $translator->schema;
211 my $oracle_version = $translator->producer_args->{oracle_version} || 0;
212 my $delay_constraints = $translator->producer_args->{delay_constraints};
213 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
215 $create .= header_comment unless ($no_comments);
216 my $qt = 1 if $translator->quote_table_names;
217 my $qf = 1 if $translator->quote_field_names;
219 if ( $translator->parser_type =~ /mysql/i ) {
221 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
222 "-- but we set it here anyway to be self-consistent.\n"
226 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
229 for my $table ( $schema->get_tables ) {
230 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
233 add_drop_table => $add_drop_table,
234 show_warnings => $WARN,
235 no_comments => $no_comments,
236 delay_constraints => $delay_constraints,
237 quote_table_names => $qt,
238 quote_field_names => $qf,
241 push @table_defs, @$table_def;
242 push @fk_defs, @$fk_def;
243 push @trigger_defs, @$trigger_def;
244 push @index_defs, @$index_def;
245 push @constraint_defs, @$constraint_def;
249 foreach my $view ( $schema->get_views ) {
250 my ( $view_def ) = create_view(
253 add_drop_view => $add_drop_table,
254 quote_table_names => $qt,
257 push @view_defs, @$view_def;
261 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
264 $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
266 # If wantarray is not set we have to add "/" in this statement
267 # DBI->do() needs them omitted
268 # triggers may NOT end with a semicolon
269 $create .= join "/\n\n", @trigger_defs;
277 my ($table, $options) = @_;
278 my $qt = $options->{quote_table_names};
279 my $qf = $options->{quote_field_names};
280 my $table_name = $table->name;
281 my $table_name_q = quote($table_name,$qt);
285 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
287 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
288 push @create, qq[DROP TABLE $table_name_q CASCADE CONSTRAINTS] if $options->{add_drop_table};
290 my ( %field_name_scope, @field_comments );
291 for my $field ( $table->get_fields ) {
292 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
293 create_field($field, $options, \%field_name_scope);
294 push @create, @$field_create if ref $field_create;
295 push @field_defs, @$field_defs if ref $field_defs;
296 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
297 push @field_comments, @$field_comments if ref $field_comments;
304 for my $opt ( $table->options ) {
305 if ( ref $opt eq 'HASH' ) {
306 my ( $key, $value ) = each %$opt;
307 if ( ref $value eq 'ARRAY' ) {
308 push @table_options, "$key\n(\n". join ("\n",
309 map { " $_->[0]\t$_->[1]" }
314 elsif ( !defined $value ) {
315 push @table_options, $key;
318 push @table_options, "$key $value";
326 for my $c ( $table->get_constraints ) {
327 my $name = $c->name || '';
328 my @fields = map { quote($_,$qf) } $c->fields;
329 my @rfields = map { quote($_,$qf) } $c->reference_fields;
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 = mk_name( "${table_name}_$name", 'u' ) 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 $on_delete = uc ($c->on_delete || '');
384 my $def = "CONSTRAINT $name FOREIGN KEY ";
387 $def .= '(' . join( ', ', @fields ) . ')';
390 my $ref_table = quote($c->reference_table,$qt);
392 $def .= " REFERENCES $ref_table";
395 $def .= ' (' . join( ', ', @rfields ) . ')';
398 if ( $c->match_type ) {
400 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
403 if ( $on_delete && $on_delete ne "RESTRICT") {
404 $def .= ' ON DELETE '.$c->on_delete;
407 # disabled by plu 2007-12-29 - doesn't exist for oracle
408 #if ( $c->on_update ) {
409 # $def .= ' ON UPDATE '. $c->on_update;
412 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
420 for my $index ( $table->get_indices ) {
421 my $index_name = $index->name || '';
422 my $index_type = $index->type || NORMAL;
423 my @fields = map { quote($_, $qf) } $index->fields;
427 for my $opt ( $index->options ) {
428 if ( ref $opt eq 'HASH' ) {
429 my ( $key, $value ) = each %$opt;
430 if ( ref $value eq 'ARRAY' ) {
431 push @table_options, "$key\n(\n". join ("\n",
432 map { " $_->[0]\t$_->[1]" }
437 elsif ( !defined $value ) {
438 push @index_options, $key;
441 push @index_options, "$key $value";
445 my $index_options = @index_options
446 ? "\n".join("\n", @index_options) : '';
448 if ( $index_type eq PRIMARY_KEY ) {
449 $index_name = $index_name ? mk_name( $index_name )
450 : mk_name( $table_name, 'pk' );
451 $index_name = quote($index_name, $qf);
452 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
453 '(' . join( ', ', @fields ) . ')';
455 elsif ( $index_type eq NORMAL ) {
456 $index_name = $index_name ? mk_name( $index_name )
457 : mk_name( $table_name, $index_name || 'i' );
458 $index_name = quote($index_name, $qf);
460 "CREATE INDEX $index_name on $table_name_q (".
461 join( ', ', @fields ).
464 elsif ( $index_type eq UNIQUE ) {
465 $index_name = $index_name ? mk_name( $index_name )
466 : mk_name( $table_name, $index_name || 'i' );
467 $index_name = quote($index_name, $qf);
469 "CREATE UNIQUE INDEX $index_name on $table_name_q (".
470 join( ', ', @fields ).
474 warn "Unknown index type ($index_type) on table $table_name.\n"
479 if ( my @table_comments = $table->comments ) {
480 for my $comment ( @table_comments ) {
481 next unless $comment;
482 $comment =~ s/'/''/g;
483 push @field_comments, "COMMENT ON TABLE $table_name_q is\n '".
484 $comment . "'" unless $options->{no_comments}
489 my $table_options = @table_options
490 ? "\n".join("\n", @table_options) : '';
491 push @create, "CREATE TABLE $table_name_q (\n" .
492 join( ",\n", map { " $_" } @field_defs,
493 ($options->{delay_constraints} ? () : @constraint_defs) ) .
496 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
501 warn "Truncated " . keys( %truncated ) . " names:\n";
502 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
506 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
510 my ($from_field, $to_field, $options) = @_;
512 my $qt = $options->{quote_table_names};
513 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
514 create_field($to_field, $options, {});
517 if ($to_field->is_nullable && !$from_field->is_nullable) {
518 die 'Cannot remove NOT NULL from table field';
519 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
520 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
523 my $table_name = quote($to_field->table->name,$qt);
525 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
529 my ($new_field, $options) = @_;
531 my $qt = $options->{quote_table_names};
532 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
533 create_field($new_field, $options, {});
535 my $table_name = quote($new_field->table->name,$qt);
537 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
539 join('', @$field_defs));
544 my ($field, $options, $field_name_scope) = @_;
545 my $qf = $options->{quote_field_names};
546 my $qt = $options->{quote_table_names};
548 my (@create, @field_defs, @trigger_defs, @field_comments);
550 my $table_name = $field->table->name;
551 my $table_name_q = quote($table_name, $qt);
556 my $field_name = mk_name(
557 $field->name, '', $field_name_scope, 1
559 my $field_name_q = quote($field_name, $qf);
560 my $field_def = quote($field_name, $qf);
561 $field->name( $field_name );
567 my $data_type = lc $field->data_type;
568 my @size = $field->size;
569 my %extra = $field->extra;
570 my $list = $extra{'list'} || [];
571 # \todo deal with embedded quotes
572 my $commalist = join( ', ', map { qq['$_'] } @$list );
574 if ( $data_type eq 'enum' ) {
575 $check = "CHECK ($field_name_q IN ($commalist))";
576 $data_type = 'varchar2';
578 elsif ( $data_type eq 'set' ) {
579 # XXX add a CHECK constraint maybe
580 # (trickier and slower, than enum :)
581 $data_type = 'varchar2';
584 if (defined $translate{ $data_type }) {
585 if (ref $translate{ $data_type } eq "ARRAY") {
586 ($data_type,$size[0]) = @{$translate{ $data_type }};
588 $data_type = $translate{ $data_type };
591 $data_type ||= 'varchar2';
594 # ensure size is not bigger than max size oracle allows for data type
595 if ( defined $max_size{$data_type} ) {
596 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
598 ref( $max_size{$data_type} ) eq 'ARRAY'
599 ? $max_size{$data_type}->[$i]
600 : $max_size{$data_type};
601 $size[$i] = $max if $size[$i] > $max;
606 # Fixes ORA-02329: column of datatype LOB cannot be
607 # unique or a primary key
609 if ( $data_type eq 'clob' && $field->is_primary_key ) {
610 $data_type = 'varchar2';
612 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
616 if ( $data_type eq 'clob' && $field->is_unique ) {
617 $data_type = 'varchar2';
619 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
624 # Fixes ORA-00907: missing right parenthesis
626 if ( $data_type =~ /(date|clob)/i ) {
631 # Fixes ORA-00906: missing right parenthesis
632 # if size is 0 or undefined
635 if ( $data_type =~ /^($_)$/i ) {
636 $size[0] ||= $max_size{$_};
640 $field_def .= " $data_type";
641 if ( defined $size[0] && $size[0] > 0 ) {
642 $field_def .= '(' . join( ',', @size ) . ')';
648 my $default = $field->default_value;
649 if ( defined $default ) {
651 # Wherein we try to catch a string being used as
652 # a default value for a numerical field. If "true/false,"
653 # then sub "1/0," otherwise just test the truthity of the
654 # argument and use that (naive?).
656 if (ref $default and defined $$default) {
657 $default = $$default;
658 } elsif (ref $default) {
661 $data_type =~ /^number$/i &&
662 $default !~ /^-?\d+$/ &&
665 if ( $default =~ /^true$/i ) {
667 } elsif ( $default =~ /^false$/i ) {
670 $default = $default ? "'1'" : "'0'";
673 $data_type =~ /date/ && (
674 $default eq 'current_timestamp'
679 $default = 'SYSDATE';
681 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
684 $field_def .= " DEFAULT $default",
688 # Not null constraint
690 unless ( $field->is_nullable ) {
691 $field_def .= ' NOT NULL';
694 $field_def .= " $check" if $check;
699 if ( $field->is_auto_increment ) {
700 my $base_name = $table_name . "_". $field_name;
701 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
702 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
704 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
705 push @create, "CREATE SEQUENCE $seq_name";
707 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
708 "BEFORE INSERT ON $table_name_q\n" .
709 "FOR EACH ROW WHEN (\n" .
710 " new.$field_name_q IS NULL".
711 " OR new.$field_name_q = 0\n".
714 " SELECT $seq_name.nextval\n" .
715 " INTO :new." . $field_name_q."\n" .
719 push @trigger_defs, $trigger;
722 if ( lc $field->data_type eq 'timestamp' ) {
723 my $base_name = $table_name . "_". $field_name;
724 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
726 "CREATE OR REPLACE TRIGGER $trig_name\n".
727 "BEFORE INSERT OR UPDATE ON $table_name_q\n".
728 "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
730 " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
733 push @trigger_defs, $trigger;
736 push @field_defs, $field_def;
738 if ( my $comment = $field->comments ) {
739 $comment =~ s/'/''/g;
740 push @field_comments,
741 "COMMENT ON COLUMN $table_name_q.$field_name_q is\n '" .
742 $comment . "';" unless $options->{no_comments};
745 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
751 my ($view, $options) = @_;
752 my $qt = $options->{quote_table_names};
753 my $view_name = quote($view->name,$qt);
756 push @create, qq[DROP VIEW $view_name]
757 if $options->{add_drop_view};
759 push @create, sprintf("CREATE VIEW %s AS\n%s",
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 }++;
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.