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 = $quote_char if $translator->quote_table_names;
217 my $qf = $quote_char 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,
256 push @view_defs, @$view_def;
260 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
263 $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
265 # If wantarray is not set we have to add "/" in this statement
266 # DBI->do() needs them omitted
267 # triggers may NOT end with a semicolon
268 $create .= join "/\n\n", @trigger_defs;
276 my ($table, $options) = @_;
277 my $qt = $options->{quote_table_names};
278 my $qf = $options->{quote_field_names};
279 my $table_name = $table->name;
280 my $table_name_q = quote($table_name,$qt);
284 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
286 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
287 push @create, qq[DROP TABLE $table_name_q CASCADE CONSTRAINTS] if $options->{add_drop_table};
289 my ( %field_name_scope, @field_comments );
290 for my $field ( $table->get_fields ) {
291 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
292 create_field($field, $options, \%field_name_scope);
293 push @create, @$field_create if ref $field_create;
294 push @field_defs, @$field_defs if ref $field_defs;
295 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
296 push @field_comments, @$field_comments if ref $field_comments;
303 for my $opt ( $table->options ) {
304 if ( ref $opt eq 'HASH' ) {
305 my ( $key, $value ) = each %$opt;
306 if ( ref $value eq 'ARRAY' ) {
307 push @table_options, "$key\n(\n". join ("\n",
308 map { " $_->[0]\t$_->[1]" }
313 elsif ( !defined $value ) {
314 push @table_options, $key;
317 push @table_options, "$key $value";
325 for my $c ( $table->get_constraints ) {
326 my $name = $c->name || '';
327 my @fields = map { quote($_,$qf) } $c->fields;
328 my @rfields = quote($c->reference_fields,$qf);
329 next if !@fields && $c->type ne CHECK_C;
331 if ( $c->type eq PRIMARY_KEY ) {
332 # create a name if delay_constraints
333 $name ||= mk_name( $table_name, 'pk' )
334 if $options->{delay_constraints};
335 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
336 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
338 elsif ( $c->type eq UNIQUE ) {
339 # Don't create UNIQUE constraints identical to the primary key
340 if ( my $pk = $table->primary_key ) {
341 my $u_fields = join(":", @fields);
342 my $pk_fields = join(":", $pk->fields);
343 next if $u_fields eq $pk_fields;
346 # Force prepend of table_name as ORACLE doesn't allow duplicate
347 # CONSTRAINT names even for different tables (ORA-02264)
348 $name = "${table_name}_$name" unless $name =~ /^$table_name/;
350 $name = mk_name( $table_name, 'u' );
352 $name = quote($name, $qf);
354 for my $f ( $c->fields ) {
355 my $field_def = $table->get_field( $f ) or next;
356 my $dtype = $translate{ ref $field_def->data_type eq "ARRAY" ? $field_def->data_type->[0] : $field_def->data_type} or next;
357 if ( $WARN && $dtype =~ /clob/i ) {
358 warn "Oracle will not allow UNIQUE constraints on " .
359 "CLOB field '" . $field_def->table->name . '.' .
360 $field_def->name . ".'\n"
364 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
365 '(' . join( ', ', @fields ) . ')';
367 elsif ( $c->type eq CHECK_C ) {
368 $name ||= mk_name( $name || $table_name, 'ck' );
369 my $expression = $c->expression || '';
370 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
372 elsif ( $c->type eq FOREIGN_KEY ) {
373 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
374 $name = quote($name, $qf);
375 my $def = "CONSTRAINT $name FOREIGN KEY ";
378 $def .= '(' . join( ', ', @fields ) . ')';
381 my $ref_table = quote($c->reference_table,$qt);
383 $def .= " REFERENCES $ref_table";
386 $def .= ' (' . join( ', ', @rfields ) . ')';
389 if ( $c->match_type ) {
391 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
394 if ( $c->on_delete ) {
395 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
398 # disabled by plu 2007-12-29 - doesn't exist for oracle
399 #if ( $c->on_update ) {
400 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
403 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
411 for my $index ( $table->get_indices ) {
412 my $index_name = $index->name || '';
413 my $index_type = $index->type || NORMAL;
414 my @fields = map { quote($_, $qf) } $index->fields;
418 for my $opt ( $index->options ) {
419 if ( ref $opt eq 'HASH' ) {
420 my ( $key, $value ) = each %$opt;
421 if ( ref $value eq 'ARRAY' ) {
422 push @table_options, "$key\n(\n". join ("\n",
423 map { " $_->[0]\t$_->[1]" }
428 elsif ( !defined $value ) {
429 push @index_options, $key;
432 push @index_options, "$key $value";
436 my $index_options = @index_options
437 ? "\n".join("\n", @index_options) : '';
439 if ( $index_type eq PRIMARY_KEY ) {
440 $index_name = $index_name ? mk_name( $index_name )
441 : mk_name( $table_name, 'pk' );
442 $index_name = quote($index_name, $qf);
443 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
444 '(' . join( ', ', @fields ) . ')';
446 elsif ( $index_type eq NORMAL ) {
447 $index_name = $index_name ? mk_name( $index_name )
448 : mk_name( $table_name, $index_name || 'i' );
449 $index_name = quote($index_name, $qf);
451 "CREATE INDEX $index_name on ".quote($table_name,$qt)." (".
452 join( ', ', @fields ).
455 elsif ( $index_type eq UNIQUE ) {
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 UNIQUE INDEX $index_name on $table_name (".
461 join( ', ', @fields ).
465 warn "Unknown index type ($index_type) on table $table_name.\n"
470 if ( my @table_comments = $table->comments ) {
471 for my $comment ( @table_comments ) {
472 next unless $comment;
473 $comment =~ s/'/''/g;
474 push @field_comments, "COMMENT ON TABLE $table_name_q is\n '".
475 $comment . "'" unless $options->{no_comments}
480 my $table_options = @table_options
481 ? "\n".join("\n", @table_options) : '';
482 push @create, "CREATE TABLE $table_name_q (\n" .
483 join( ",\n", map { " $_" } @field_defs,
484 ($options->{delay_constraints} ? () : @constraint_defs) ) .
487 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
492 warn "Truncated " . keys( %truncated ) . " names:\n";
493 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
497 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
501 my ($from_field, $to_field, $options) = @_;
503 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
504 create_field($to_field, $options, {});
507 if ($to_field->is_nullable && !$from_field->is_nullable) {
508 die 'Cannot remove NOT NULL from table field';
509 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
510 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
513 my $table_name = $to_field->table->name;
515 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
519 my ($new_field, $options) = @_;
521 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
522 create_field($new_field, $options, {});
524 my $table_name = $new_field->table->name;
526 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
528 join('', @$field_defs));
533 my ($field, $options, $field_name_scope) = @_;
534 my $qf = $options->{quote_field_names};
535 my $qt = $options->{quote_table_names};
537 my (@create, @field_defs, @trigger_defs, @field_comments);
539 my $table_name = $field->table->name;
540 my $table_name_q = quote($table_name, $qt);
545 my $field_name = mk_name(
546 $field->name, '', $field_name_scope, 1
548 my $field_name_q = quote($field_name, $qf);
549 my $field_def = quote($field_name, $qf);
550 $field->name( $field_name );
556 my $data_type = lc $field->data_type;
557 my @size = $field->size;
558 my %extra = $field->extra;
559 my $list = $extra{'list'} || [];
560 # \todo deal with embedded quotes
561 my $commalist = join( ', ', map { qq['$_'] } @$list );
563 if ( $data_type eq 'enum' ) {
564 $check = "CHECK ($field_name_q IN ($commalist))";
565 $data_type = 'varchar2';
567 elsif ( $data_type eq 'set' ) {
568 # XXX add a CHECK constraint maybe
569 # (trickier and slower, than enum :)
570 $data_type = 'varchar2';
573 if (defined $translate{ $data_type }) {
574 if (ref $translate{ $data_type } eq "ARRAY") {
575 ($data_type,$size[0]) = @{$translate{ $data_type }};
577 $data_type = $translate{ $data_type };
580 $data_type ||= 'varchar2';
583 # ensure size is not bigger than max size oracle allows for data type
584 if ( defined $max_size{$data_type} ) {
585 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
587 ref( $max_size{$data_type} ) eq 'ARRAY'
588 ? $max_size{$data_type}->[$i]
589 : $max_size{$data_type};
590 $size[$i] = $max if $size[$i] > $max;
595 # Fixes ORA-02329: column of datatype LOB cannot be
596 # unique or a primary key
598 if ( $data_type eq 'clob' && $field->is_primary_key ) {
599 $data_type = 'varchar2';
601 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
605 if ( $data_type eq 'clob' && $field->is_unique ) {
606 $data_type = 'varchar2';
608 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
613 # Fixes ORA-00907: missing right parenthesis
615 if ( $data_type =~ /(date|clob)/i ) {
619 $field_def .= " $data_type";
620 if ( defined $size[0] && $size[0] > 0 ) {
621 $field_def .= '(' . join( ',', @size ) . ')';
627 my $default = $field->default_value;
628 if ( defined $default ) {
630 # Wherein we try to catch a string being used as
631 # a default value for a numerical field. If "true/false,"
632 # then sub "1/0," otherwise just test the truthity of the
633 # argument and use that (naive?).
635 if (ref $default and defined $$default) {
636 $default = $$default;
637 } elsif (ref $default) {
640 $data_type =~ /^number$/i &&
641 $default !~ /^-?\d+$/ &&
644 if ( $default =~ /^true$/i ) {
646 } elsif ( $default =~ /^false$/i ) {
649 $default = $default ? "'1'" : "'0'";
652 $data_type =~ /date/ && (
653 $default eq 'current_timestamp'
658 $default = 'SYSDATE';
660 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
663 $field_def .= " DEFAULT $default",
667 # Not null constraint
669 unless ( $field->is_nullable ) {
670 $field_def .= ' NOT NULL';
673 $field_def .= " $check" if $check;
678 if ( $field->is_auto_increment ) {
679 my $base_name = $table_name . "_". $field_name;
680 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
681 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
683 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
684 push @create, "CREATE SEQUENCE $seq_name";
686 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
687 "BEFORE INSERT ON $table_name_q\n" .
688 "FOR EACH ROW WHEN (\n" .
689 " new.$field_name_q IS NULL".
690 " OR new.$field_name_q = 0\n".
693 " SELECT $seq_name.nextval\n" .
694 " INTO :new." . $field_name_q."\n" .
698 push @trigger_defs, $trigger;
701 if ( lc $field->data_type eq 'timestamp' ) {
702 my $base_name = $table_name . "_". $field_name;
703 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
705 "CREATE OR REPLACE TRIGGER $trig_name\n".
706 "BEFORE INSERT OR UPDATE ON $table_name_q\n".
707 "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
709 " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
712 push @trigger_defs, $trigger;
715 push @field_defs, $field_def;
717 if ( my $comment = $field->comments ) {
718 $comment =~ s/'/''/g;
719 push @field_comments,
720 "COMMENT ON COLUMN $table_name.$field_name is\n '" .
721 $comment . "';" unless $options->{no_comments};
724 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
730 my ($view, $options) = @_;
731 my $qt = $options->{quote_table_names};
732 my $qf = $options->{quote_field_names};
733 my $view_name = quote($view->name,$qt);
736 push @create, qq[DROP VIEW $view_name]
737 if $options->{add_drop_view};
739 push @create, sprintf("CREATE VIEW %s AS\n%s",
746 # -------------------------------------------------------------------
748 my $basename = shift || '';
749 my $type = shift || '';
750 $type = '' if $type =~ /^\d/;
751 my $scope = shift || '';
752 my $critical = shift || '';
753 my $basename_orig = $basename;
755 ? $max_id_length - (length($type) + 1)
757 $basename = substr( $basename, 0, $max_name )
758 if length( $basename ) > $max_name;
759 my $name = $type ? "${type}_$basename" : $basename;
761 if ( $basename ne $basename_orig and $critical ) {
762 my $show_type = $type ? "+'$type'" : "";
763 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
764 "character limit to make '$name'\n" if $WARN;
765 $truncated{ $basename_orig } = $name;
768 $scope ||= \%global_names;
769 if ( my $prev = $scope->{ $name } ) {
770 my $name_orig = $name;
771 substr($name, $max_id_length - 2) = ""
772 if length( $name ) >= $max_id_length - 1;
773 $name .= sprintf( "%02d", $prev++ );
775 warn "The name '$name_orig' has been changed to ",
776 "'$name' to make it unique.\n" if $WARN;
778 $scope->{ $name_orig }++;
787 # -------------------------------------------------------------------
790 $q ? "$q$name$q" : $name;
794 # -------------------------------------------------------------------
795 # All bad art is the result of good intentions.
797 # -------------------------------------------------------------------
803 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
808 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
809 Alexander Hartmaier E<lt>abraxxa@cpan.orgE<gt>,
810 Fabien Wernli E<lt>faxmodem@cpan.orgE<gt>.
814 SQL::Translator, DDL::Oracle, mysql2ora.