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',
136 text => [ 'varchar2', 4000 ],
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
189 number => [ 38, 127 ],
191 varchar => 4000, # only synonym for varchar2
195 my $max_id_length = 30;
196 my %used_identifiers = ();
200 # Quote used to escape table, field, sequence and trigger names
201 my $quote_char = '"';
203 # -------------------------------------------------------------------
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 = quote($c->reference_fields,$qf);
330 next if !@fields && $c->type ne CHECK_C;
332 if ( $c->type eq PRIMARY_KEY ) {
333 # create a name if delay_constraints
334 $name ||= mk_name( $table_name, 'pk' )
335 if $options->{delay_constraints};
336 $name = quote($name,$qf);
337 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
338 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
340 elsif ( $c->type eq UNIQUE ) {
341 # Don't create UNIQUE constraints identical to the primary key
342 if ( my $pk = $table->primary_key ) {
343 my $u_fields = join(":", @fields);
344 my $pk_fields = join(":", $pk->fields);
345 next if $u_fields eq $pk_fields;
348 # Force prepend of table_name as ORACLE doesn't allow duplicate
349 # CONSTRAINT names even for different tables (ORA-02264)
350 $name = "${table_name}_$name" unless $name =~ /^$table_name/;
352 $name = mk_name( $table_name, 'u' );
354 $name = quote($name, $qf);
356 for my $f ( $c->fields ) {
357 my $field_def = $table->get_field( $f ) or next;
358 my $dtype = $translate{ ref $field_def->data_type eq "ARRAY" ? $field_def->data_type->[0] : $field_def->data_type} or next;
359 if ( $WARN && $dtype =~ /clob/i ) {
360 warn "Oracle will not allow UNIQUE constraints on " .
361 "CLOB field '" . $field_def->table->name . '.' .
362 $field_def->name . ".'\n"
366 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
367 '(' . join( ', ', @fields ) . ')';
369 elsif ( $c->type eq CHECK_C ) {
370 $name ||= mk_name( $name || $table_name, 'ck' );
371 $name = quote($name, $qf);
372 my $expression = $c->expression || '';
373 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
375 elsif ( $c->type eq FOREIGN_KEY ) {
376 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
377 $name = quote($name, $qf);
378 my $def = "CONSTRAINT $name FOREIGN KEY ";
381 $def .= '(' . join( ', ', @fields ) . ')';
384 my $ref_table = quote($c->reference_table,$qt);
386 $def .= " REFERENCES $ref_table";
389 $def .= ' (' . join( ', ', @rfields ) . ')';
392 if ( $c->match_type ) {
394 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
397 if ( $c->on_delete ) {
398 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
401 # disabled by plu 2007-12-29 - doesn't exist for oracle
402 #if ( $c->on_update ) {
403 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
406 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
414 for my $index ( $table->get_indices ) {
415 my $index_name = $index->name || '';
416 my $index_type = $index->type || NORMAL;
417 my @fields = map { quote($_, $qf) } $index->fields;
421 for my $opt ( $index->options ) {
422 if ( ref $opt eq 'HASH' ) {
423 my ( $key, $value ) = each %$opt;
424 if ( ref $value eq 'ARRAY' ) {
425 push @table_options, "$key\n(\n". join ("\n",
426 map { " $_->[0]\t$_->[1]" }
431 elsif ( !defined $value ) {
432 push @index_options, $key;
435 push @index_options, "$key $value";
439 my $index_options = @index_options
440 ? "\n".join("\n", @index_options) : '';
442 if ( $index_type eq PRIMARY_KEY ) {
443 $index_name = $index_name ? mk_name( $index_name )
444 : mk_name( $table_name, 'pk' );
445 $index_name = quote($index_name, $qf);
446 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
447 '(' . join( ', ', @fields ) . ')';
449 elsif ( $index_type eq NORMAL ) {
450 $index_name = $index_name ? mk_name( $index_name )
451 : mk_name( $table_name, $index_name || 'i' );
452 $index_name = quote($index_name, $qf);
454 "CREATE INDEX $index_name on $table_name_q (".
455 join( ', ', @fields ).
458 elsif ( $index_type eq UNIQUE ) {
459 $index_name = $index_name ? mk_name( $index_name )
460 : mk_name( $table_name, $index_name || 'i' );
461 $index_name = quote($index_name, $qf);
463 "CREATE UNIQUE INDEX $index_name on $table_name_q (".
464 join( ', ', @fields ).
468 warn "Unknown index type ($index_type) on table $table_name.\n"
473 if ( my @table_comments = $table->comments ) {
474 for my $comment ( @table_comments ) {
475 next unless $comment;
476 $comment =~ s/'/''/g;
477 push @field_comments, "COMMENT ON TABLE $table_name_q is\n '".
478 $comment . "'" unless $options->{no_comments}
483 my $table_options = @table_options
484 ? "\n".join("\n", @table_options) : '';
485 push @create, "CREATE TABLE $table_name_q (\n" .
486 join( ",\n", map { " $_" } @field_defs,
487 ($options->{delay_constraints} ? () : @constraint_defs) ) .
490 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
495 warn "Truncated " . keys( %truncated ) . " names:\n";
496 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
500 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
504 my ($from_field, $to_field, $options) = @_;
506 my $qt = $options->{quote_table_names};
507 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
508 create_field($to_field, $options, {});
511 if ($to_field->is_nullable && !$from_field->is_nullable) {
512 die 'Cannot remove NOT NULL from table field';
513 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
514 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
517 my $table_name = quote($to_field->table->name,$qt);
519 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
523 my ($new_field, $options) = @_;
525 my $qt = $options->{quote_table_names};
526 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
527 create_field($new_field, $options, {});
529 my $table_name = quote($new_field->table->name,$qt);
531 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
533 join('', @$field_defs));
538 my ($field, $options, $field_name_scope) = @_;
539 my $qf = $options->{quote_field_names};
540 my $qt = $options->{quote_table_names};
542 my (@create, @field_defs, @trigger_defs, @field_comments);
544 my $table_name = $field->table->name;
545 my $table_name_q = quote($table_name, $qt);
550 my $field_name = mk_name(
551 $field->name, '', $field_name_scope, 1
553 my $field_name_q = quote($field_name, $qf);
554 my $field_def = quote($field_name, $qf);
555 $field->name( $field_name );
561 my $data_type = lc $field->data_type;
562 my @size = $field->size;
563 my %extra = $field->extra;
564 my $list = $extra{'list'} || [];
565 # \todo deal with embedded quotes
566 my $commalist = join( ', ', map { qq['$_'] } @$list );
568 if ( $data_type eq 'enum' ) {
569 $check = "CHECK ($field_name_q IN ($commalist))";
570 $data_type = 'varchar2';
572 elsif ( $data_type eq 'set' ) {
573 # XXX add a CHECK constraint maybe
574 # (trickier and slower, than enum :)
575 $data_type = 'varchar2';
578 if (defined $translate{ $data_type }) {
579 if (ref $translate{ $data_type } eq "ARRAY") {
580 ($data_type,$size[0]) = @{$translate{ $data_type }};
582 $data_type = $translate{ $data_type };
585 $data_type ||= 'varchar2';
588 # ensure size is not bigger than max size oracle allows for data type
589 if ( defined $max_size{$data_type} ) {
590 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
592 ref( $max_size{$data_type} ) eq 'ARRAY'
593 ? $max_size{$data_type}->[$i]
594 : $max_size{$data_type};
595 $size[$i] = $max if $size[$i] > $max;
600 # Fixes ORA-02329: column of datatype LOB cannot be
601 # unique or a primary key
603 if ( $data_type eq 'clob' && $field->is_primary_key ) {
604 $data_type = 'varchar2';
606 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
610 if ( $data_type eq 'clob' && $field->is_unique ) {
611 $data_type = 'varchar2';
613 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
618 # Fixes ORA-00907: missing right parenthesis
620 if ( $data_type =~ /(date|clob)/i ) {
624 $field_def .= " $data_type";
625 if ( defined $size[0] && $size[0] > 0 ) {
626 $field_def .= '(' . join( ',', @size ) . ')';
632 my $default = $field->default_value;
633 if ( defined $default ) {
635 # Wherein we try to catch a string being used as
636 # a default value for a numerical field. If "true/false,"
637 # then sub "1/0," otherwise just test the truthity of the
638 # argument and use that (naive?).
640 if (ref $default and defined $$default) {
641 $default = $$default;
642 } elsif (ref $default) {
645 $data_type =~ /^number$/i &&
646 $default !~ /^-?\d+$/ &&
649 if ( $default =~ /^true$/i ) {
651 } elsif ( $default =~ /^false$/i ) {
654 $default = $default ? "'1'" : "'0'";
657 $data_type =~ /date/ && (
658 $default eq 'current_timestamp'
663 $default = 'SYSDATE';
665 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
668 $field_def .= " DEFAULT $default",
672 # Not null constraint
674 unless ( $field->is_nullable ) {
675 $field_def .= ' NOT NULL';
678 $field_def .= " $check" if $check;
683 if ( $field->is_auto_increment ) {
684 my $base_name = $table_name . "_". $field_name;
685 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
686 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
688 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
689 push @create, "CREATE SEQUENCE $seq_name";
691 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
692 "BEFORE INSERT ON $table_name_q\n" .
693 "FOR EACH ROW WHEN (\n" .
694 " new.$field_name_q IS NULL".
695 " OR new.$field_name_q = 0\n".
698 " SELECT $seq_name.nextval\n" .
699 " INTO :new." . $field_name_q."\n" .
703 push @trigger_defs, $trigger;
706 if ( lc $field->data_type eq 'timestamp' ) {
707 my $base_name = $table_name . "_". $field_name;
708 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
710 "CREATE OR REPLACE TRIGGER $trig_name\n".
711 "BEFORE INSERT OR UPDATE ON $table_name_q\n".
712 "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
714 " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
717 push @trigger_defs, $trigger;
720 push @field_defs, $field_def;
722 if ( my $comment = $field->comments ) {
723 $comment =~ s/'/''/g;
724 push @field_comments,
725 "COMMENT ON COLUMN $table_name_q.$field_name_q is\n '" .
726 $comment . "';" unless $options->{no_comments};
729 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
735 my ($view, $options) = @_;
736 my $qt = $options->{quote_table_names};
737 my $view_name = quote($view->name,$qt);
740 push @create, qq[DROP VIEW $view_name]
741 if $options->{add_drop_view};
743 push @create, sprintf("CREATE VIEW %s AS\n%s",
750 # -------------------------------------------------------------------
752 my $basename = shift || '';
753 my $type = shift || '';
754 $type = '' if $type =~ /^\d/;
755 my $scope = shift || '';
756 my $critical = shift || '';
757 my $basename_orig = $basename;
759 ? $max_id_length - (length($type) + 1)
761 $basename = substr( $basename, 0, $max_name )
762 if length( $basename ) > $max_name;
763 my $name = $type ? "${type}_$basename" : $basename;
765 if ( $basename ne $basename_orig and $critical ) {
766 my $show_type = $type ? "+'$type'" : "";
767 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
768 "character limit to make '$name'\n" if $WARN;
769 $truncated{ $basename_orig } = $name;
772 $scope ||= \%global_names;
773 if ( my $prev = $scope->{ $name } ) {
774 my $name_orig = $name;
775 substr($name, $max_id_length - 2) = ""
776 if length( $name ) >= $max_id_length - 1;
777 $name .= sprintf( "%02d", $prev++ );
779 warn "The name '$name_orig' has been changed to ",
780 "'$name' to make it unique.\n" if $WARN;
782 $scope->{ $name_orig }++;
791 # -------------------------------------------------------------------
794 $q && $name ? "$quote_char$name$quote_char" : $name;
798 # -------------------------------------------------------------------
799 # All bad art is the result of good intentions.
801 # -------------------------------------------------------------------
807 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
812 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
813 Alexander Hartmaier E<lt>abraxxa@cpan.orgE<gt>,
814 Fabien Wernli E<lt>faxmodem@cpan.orgE<gt>.
818 SQL::Translator, DDL::Oracle, mysql2ora.