1 package SQL::Translator::Producer::Oracle;
5 SQL::Translator::Producer::Oracle - Oracle SQL producer
11 my $t = SQL::Translator->new( parser => '...', producer => 'Oracle' );
12 print $translator->translate( $file );
16 Creates an SQL DDL suitable for Oracle.
22 =item delay_constraints
24 This option remove the primary key and other key constraints from the
25 CREATE TABLE statement and adds ALTER TABLEs at the end with it.
27 =item quote_field_names
29 Controls whether quotes are being used around column names in generated DDL.
31 =item quote_table_names
33 Controls whether quotes are being used around table, sequence and trigger names in
40 =head2 Autoincremental primary keys
42 This producer uses sequences and triggers to autoincrement primary key
43 columns, if necessary. SQLPlus and DBI expect a slightly different syntax
44 of CREATE TRIGGER statement. You might have noticed that this
45 producer returns a scalar containing all statements concatenated by
46 newlines or an array of single statements depending on the context
47 (scalar, array) it has been called in.
49 SQLPlus expects following trigger syntax:
51 CREATE OR REPLACE TRIGGER ai_person_id
52 BEFORE INSERT ON person
54 new.id IS NULL OR new.id = 0
57 SELECT sq_person_id.nextval
63 Whereas if you want to create the same trigger using L<DBI/do>, you need
64 to omit the last slash:
66 my $dbh = DBI->connect('dbi:Oracle:mysid', 'scott', 'tiger');
68 CREATE OR REPLACE TRIGGER ai_person_id
69 BEFORE INSERT ON person
71 new.id IS NULL OR new.id = 0
74 SELECT sq_person_id.nextval
80 If you call this producer in array context, we expect you want to process
81 the returned array of statements using L<DBI> like
82 L<DBIx::Class::Schema/deploy> does.
84 To get this working we removed the slash in those statements in version
85 0.09002 of L<SQL::Translator> when called in array context. In scalar
86 context the slash will be still there to ensure compatibility with SQLPlus.
92 our ( $DEBUG, $WARN );
93 our $VERSION = '1.59';
94 $DEBUG = 0 unless defined $DEBUG;
96 use SQL::Translator::Schema::Constants;
97 use SQL::Translator::Utils qw(header_comment);
109 mediumint => 'number',
110 smallint => 'number',
113 varchar => 'varchar2',
116 mediumblob => 'blob',
118 tinytext => 'varchar2',
121 mediumtext => 'clob',
134 'double precision' => 'number',
136 bigserial => 'number',
139 'character varying' => 'varchar2',
141 interval => 'number',
152 macaddr => 'varchar2',
154 'bit varying' => 'number',
160 varchar2 => 'varchar2',
165 # Oracle 8/9 max size of data types from:
166 # http://www.ss64.com/orasyntax/datatypes.html
173 number => [ 38, 127 ],
175 varchar => 4000, # only synonym for varchar2
179 my $max_id_length = 30;
180 my %used_identifiers = ();
184 # Quote used to escape table, field, sequence and trigger names
185 my $quote_char = '"';
188 my $translator = shift;
189 $DEBUG = $translator->debug;
190 $WARN = $translator->show_warnings || 0;
191 my $no_comments = $translator->no_comments;
192 my $add_drop_table = $translator->add_drop_table;
193 my $schema = $translator->schema;
194 my $oracle_version = $translator->producer_args->{oracle_version} || 0;
195 my $delay_constraints = $translator->producer_args->{delay_constraints};
196 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
198 $create .= header_comment unless ($no_comments);
199 my $qt = 1 if $translator->quote_table_names;
200 my $qf = 1 if $translator->quote_field_names;
202 if ( $translator->parser_type =~ /mysql/i ) {
204 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
205 "-- but we set it here anyway to be self-consistent.\n"
209 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
212 for my $table ( $schema->get_tables ) {
213 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
216 add_drop_table => $add_drop_table,
217 show_warnings => $WARN,
218 no_comments => $no_comments,
219 delay_constraints => $delay_constraints,
220 quote_table_names => $qt,
221 quote_field_names => $qf,
224 push @table_defs, @$table_def;
225 push @fk_defs, @$fk_def;
226 push @trigger_defs, @$trigger_def;
227 push @index_defs, @$index_def;
228 push @constraint_defs, @$constraint_def;
232 foreach my $view ( $schema->get_views ) {
233 my ( $view_def ) = create_view(
236 add_drop_view => $add_drop_table,
237 quote_table_names => $qt,
240 push @view_defs, @$view_def;
244 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
247 $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
249 # If wantarray is not set we have to add "/" in this statement
250 # DBI->do() needs them omitted
251 # triggers may NOT end with a semicolon but a "/" instead
259 my ($table, $options) = @_;
260 my $qt = $options->{quote_table_names};
261 my $qf = $options->{quote_field_names};
262 my $table_name = $table->name;
263 my $table_name_q = quote($table_name,$qt);
267 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
269 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
270 push @create, qq[DROP TABLE $table_name_q CASCADE CONSTRAINTS] if $options->{add_drop_table};
272 my ( %field_name_scope, @field_comments );
273 for my $field ( $table->get_fields ) {
274 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
275 create_field($field, $options, \%field_name_scope);
276 push @create, @$field_create if ref $field_create;
277 push @field_defs, @$field_defs if ref $field_defs;
278 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
279 push @field_comments, @$field_comments if ref $field_comments;
286 for my $opt ( $table->options ) {
287 if ( ref $opt eq 'HASH' ) {
288 my ( $key, $value ) = each %$opt;
289 if ( ref $value eq 'ARRAY' ) {
290 push @table_options, "$key\n(\n". join ("\n",
291 map { " $_->[0]\t$_->[1]" }
296 elsif ( !defined $value ) {
297 push @table_options, $key;
300 push @table_options, "$key $value";
308 for my $c ( $table->get_constraints ) {
309 my $name = $c->name || '';
310 my @fields = map { quote($_,$qf) } $c->fields;
311 my @rfields = map { quote($_,$qf) } $c->reference_fields;
313 next if !@fields && $c->type ne CHECK_C;
315 if ( $c->type eq PRIMARY_KEY ) {
316 # create a name if delay_constraints
317 $name ||= mk_name( $table_name, 'pk' )
318 if $options->{delay_constraints};
319 $name = quote($name,$qf);
320 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
321 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
323 elsif ( $c->type eq UNIQUE ) {
324 # Don't create UNIQUE constraints identical to the primary key
325 if ( my $pk = $table->primary_key ) {
326 my $u_fields = join(":", @fields);
327 my $pk_fields = join(":", $pk->fields);
328 next if $u_fields eq $pk_fields;
332 # Force prepend of table_name as ORACLE doesn't allow duplicate
333 # CONSTRAINT names even for different tables (ORA-02264)
334 $name = mk_name( "${table_name}_$name", 'u' ) unless $name =~ /^$table_name/;
337 $name = mk_name( $table_name, 'u' );
340 $name = quote($name, $qf);
342 for my $f ( $c->fields ) {
343 my $field_def = $table->get_field( $f ) or next;
344 my $dtype = $translate{ ref $field_def->data_type eq "ARRAY" ? $field_def->data_type->[0] : $field_def->data_type} or next;
345 if ( $WARN && $dtype =~ /clob/i ) {
346 warn "Oracle will not allow UNIQUE constraints on " .
347 "CLOB field '" . $field_def->table->name . '.' .
348 $field_def->name . ".'\n"
352 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
353 '(' . join( ', ', @fields ) . ')';
355 elsif ( $c->type eq CHECK_C ) {
356 $name ||= mk_name( $name || $table_name, 'ck' );
357 $name = quote($name, $qf);
358 my $expression = $c->expression || '';
359 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
361 elsif ( $c->type eq FOREIGN_KEY ) {
362 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
363 $name = quote($name, $qf);
364 my $on_delete = uc ($c->on_delete || '');
366 my $def = "CONSTRAINT $name FOREIGN KEY ";
369 $def .= '(' . join( ', ', @fields ) . ')';
372 my $ref_table = quote($c->reference_table,$qt);
374 $def .= " REFERENCES $ref_table";
377 $def .= ' (' . join( ', ', @rfields ) . ')';
380 if ( $c->match_type ) {
382 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
385 if ( $on_delete && $on_delete ne "RESTRICT") {
386 $def .= ' ON DELETE '.$c->on_delete;
389 # disabled by plu 2007-12-29 - doesn't exist for oracle
390 #if ( $c->on_update ) {
391 # $def .= ' ON UPDATE '. $c->on_update;
394 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
402 for my $index ( $table->get_indices ) {
403 my $index_name = $index->name || '';
404 my $index_type = $index->type || NORMAL;
405 my @fields = map { quote($_, $qf) } $index->fields;
409 for my $opt ( $index->options ) {
410 if ( ref $opt eq 'HASH' ) {
411 my ( $key, $value ) = each %$opt;
412 if ( ref $value eq 'ARRAY' ) {
413 push @table_options, "$key\n(\n". join ("\n",
414 map { " $_->[0]\t$_->[1]" }
419 elsif ( !defined $value ) {
420 push @index_options, $key;
423 push @index_options, "$key $value";
427 my $index_options = @index_options
428 ? "\n".join("\n", @index_options) : '';
430 if ( $index_type eq PRIMARY_KEY ) {
431 $index_name = $index_name ? mk_name( $index_name )
432 : mk_name( $table_name, 'pk' );
433 $index_name = quote($index_name, $qf);
434 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
435 '(' . join( ', ', @fields ) . ')';
437 elsif ( $index_type eq NORMAL ) {
438 $index_name = $index_name ? mk_name( $index_name )
439 : mk_name( $table_name, $index_name || 'i' );
440 $index_name = quote($index_name, $qf);
442 "CREATE INDEX $index_name on $table_name_q (".
443 join( ', ', @fields ).
446 elsif ( $index_type eq UNIQUE ) {
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 UNIQUE INDEX $index_name on $table_name_q (".
452 join( ', ', @fields ).
456 warn "Unknown index type ($index_type) on table $table_name.\n"
461 if ( my @table_comments = $table->comments ) {
462 for my $comment ( @table_comments ) {
463 next unless $comment;
464 $comment =~ s/'/''/g;
465 push @field_comments, "COMMENT ON TABLE $table_name_q is\n '".
466 $comment . "'" unless $options->{no_comments}
471 my $table_options = @table_options
472 ? "\n".join("\n", @table_options) : '';
473 push @create, "CREATE TABLE $table_name_q (\n" .
474 join( ",\n", map { " $_" } @field_defs,
475 ($options->{delay_constraints} ? () : @constraint_defs) ) .
478 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
483 warn "Truncated " . keys( %truncated ) . " names:\n";
484 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
488 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
492 my ($from_field, $to_field, $options) = @_;
494 my $qt = $options->{quote_table_names};
495 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
496 create_field($to_field, $options, {});
499 if ($to_field->is_nullable && !$from_field->is_nullable) {
500 die 'Cannot remove NOT NULL from table field';
501 } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
502 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
505 my $table_name = quote($to_field->table->name,$qt);
507 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
511 my ($new_field, $options) = @_;
513 my $qt = $options->{quote_table_names};
514 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
515 create_field($new_field, $options, {});
517 my $table_name = quote($new_field->table->name,$qt);
519 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
521 join('', @$field_defs));
526 my ($field, $options, $field_name_scope) = @_;
527 my $qf = $options->{quote_field_names};
528 my $qt = $options->{quote_table_names};
530 my (@create, @field_defs, @trigger_defs, @field_comments);
532 my $table_name = $field->table->name;
533 my $table_name_q = quote($table_name, $qt);
538 my $field_name = mk_name(
539 $field->name, '', $field_name_scope, 1
541 my $field_name_q = quote($field_name, $qf);
542 my $field_def = quote($field_name, $qf);
543 $field->name( $field_name );
549 my $data_type = lc $field->data_type;
550 my @size = $field->size;
551 my %extra = $field->extra;
552 my $list = $extra{'list'} || [];
553 # \todo deal with embedded quotes
554 my $commalist = join( ', ', map { qq['$_'] } @$list );
556 if ( $data_type eq 'enum' ) {
557 $check = "CHECK ($field_name_q IN ($commalist))";
558 $data_type = 'varchar2';
560 elsif ( $data_type eq 'set' ) {
561 # XXX add a CHECK constraint maybe
562 # (trickier and slower, than enum :)
563 $data_type = 'varchar2';
566 if (defined $translate{ $data_type }) {
567 if (ref $translate{ $data_type } eq "ARRAY") {
568 ($data_type,$size[0]) = @{$translate{ $data_type }};
570 $data_type = $translate{ $data_type };
573 $data_type ||= 'varchar2';
576 # ensure size is not bigger than max size oracle allows for data type
577 if ( defined $max_size{$data_type} ) {
578 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
580 ref( $max_size{$data_type} ) eq 'ARRAY'
581 ? $max_size{$data_type}->[$i]
582 : $max_size{$data_type};
583 $size[$i] = $max if $size[$i] > $max;
588 # Fixes ORA-02329: column of datatype LOB cannot be
589 # unique or a primary key
591 if ( $data_type eq 'clob' && $field->is_primary_key ) {
592 $data_type = 'varchar2';
594 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
598 if ( $data_type eq 'clob' && $field->is_unique ) {
599 $data_type = 'varchar2';
601 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
606 # Fixes ORA-00907: missing right parenthesis
608 if ( $data_type =~ /(date|clob)/i ) {
613 # Fixes ORA-00906: missing right parenthesis
614 # if size is 0 or undefined
617 if ( $data_type =~ /^($_)$/i ) {
618 $size[0] ||= $max_size{$_};
622 $field_def .= " $data_type";
623 if ( defined $size[0] && $size[0] > 0 ) {
624 $field_def .= '(' . join( ',', @size ) . ')';
630 my $default = $field->default_value;
631 if ( defined $default ) {
633 # Wherein we try to catch a string being used as
634 # a default value for a numerical field. If "true/false,"
635 # then sub "1/0," otherwise just test the truthity of the
636 # argument and use that (naive?).
638 if (ref $default and defined $$default) {
639 $default = $$default;
640 } elsif (ref $default) {
643 $data_type =~ /^number$/i &&
644 $default !~ /^-?\d+$/ &&
647 if ( $default =~ /^true$/i ) {
649 } elsif ( $default =~ /^false$/i ) {
652 $default = $default ? "'1'" : "'0'";
655 $data_type =~ /date/ && (
656 $default eq 'current_timestamp'
661 $default = 'SYSDATE';
663 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
666 $field_def .= " DEFAULT $default",
670 # Not null constraint
672 unless ( $field->is_nullable ) {
673 $field_def .= ' NOT NULL';
676 $field_def .= " $check" if $check;
681 if ( $field->is_auto_increment ) {
682 my $base_name = $table_name . "_". $field_name;
683 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
684 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
686 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
687 push @create, "CREATE SEQUENCE $seq_name";
689 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
690 "BEFORE INSERT ON $table_name_q\n" .
691 "FOR EACH ROW WHEN (\n" .
692 " new.$field_name_q IS NULL".
693 " OR new.$field_name_q = 0\n".
696 " SELECT $seq_name.nextval\n" .
697 " INTO :new." . $field_name_q."\n" .
701 push @trigger_defs, $trigger;
704 if ( lc $field->data_type eq 'timestamp' ) {
705 my $base_name = $table_name . "_". $field_name;
706 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
708 "CREATE OR REPLACE TRIGGER $trig_name\n".
709 "BEFORE INSERT OR UPDATE ON $table_name_q\n".
710 "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
712 " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
715 push @trigger_defs, $trigger;
718 push @field_defs, $field_def;
720 if ( my $comment = $field->comments ) {
721 $comment =~ s/'/''/g;
722 push @field_comments,
723 "COMMENT ON COLUMN $table_name_q.$field_name_q is\n '" .
724 $comment . "';" unless $options->{no_comments};
727 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
733 my ($view, $options) = @_;
734 my $qt = $options->{quote_table_names};
735 my $view_name = quote($view->name,$qt);
738 push @create, qq[DROP VIEW $view_name]
739 if $options->{add_drop_view};
741 push @create, sprintf("CREATE VIEW %s AS\n%s",
749 my $basename = shift || '';
750 my $type = shift || '';
751 $type = '' if $type =~ /^\d/;
752 my $scope = shift || '';
753 my $critical = shift || '';
754 my $basename_orig = $basename;
756 ? $max_id_length - (length($type) + 1)
758 $basename = substr( $basename, 0, $max_name )
759 if length( $basename ) > $max_name;
760 my $name = $type ? "${type}_$basename" : $basename;
762 if ( $basename ne $basename_orig and $critical ) {
763 my $show_type = $type ? "+'$type'" : "";
764 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
765 "character limit to make '$name'\n" if $WARN;
766 $truncated{ $basename_orig } = $name;
769 $scope ||= \%global_names;
770 if ( my $prev = $scope->{ $name } ) {
771 my $name_orig = $name;
772 substr($name, $max_id_length - 2) = ""
773 if length( $name ) >= $max_id_length - 1;
774 $name .= sprintf( "%02d", $prev++ );
776 warn "The name '$name_orig' has been changed to ",
777 "'$name' to make it unique.\n" if $WARN;
779 $scope->{ $name_orig }++;
790 $q && $name ? "$quote_char$name$quote_char" : $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.