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.60';
94 $DEBUG = 0 unless defined $DEBUG;
96 use base 'SQL::Translator::Producer';
97 use SQL::Translator::Schema::Constants;
98 use SQL::Translator::Utils qw(header_comment);
110 mediumint => 'number',
111 smallint => 'number',
114 varchar => 'varchar2',
117 mediumblob => 'blob',
119 tinytext => 'varchar2',
122 mediumtext => 'clob',
135 'double precision' => 'number',
137 bigserial => 'number',
140 'character varying' => 'varchar2',
142 interval => 'number',
153 macaddr => 'varchar2',
155 'bit varying' => 'number',
161 varchar2 => 'varchar2',
166 # Oracle 8/9 max size of data types from:
167 # http://www.ss64.com/orasyntax/datatypes.html
174 number => [ 38, 127 ],
176 varchar => 4000, # only synonym for varchar2
180 my $max_id_length = 30;
181 my %used_identifiers = ();
185 # Quote used to escape table, field, sequence and trigger names
186 my $quote_char = '"';
189 my $translator = shift;
190 $DEBUG = $translator->debug;
191 $WARN = $translator->show_warnings || 0;
192 my $no_comments = $translator->no_comments;
193 my $add_drop_table = $translator->add_drop_table;
194 my $schema = $translator->schema;
195 my $oracle_version = $translator->producer_args->{oracle_version} || 0;
196 my $delay_constraints = $translator->producer_args->{delay_constraints};
197 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
199 $create .= header_comment unless ($no_comments);
200 my $qt = 1 if $translator->quote_table_names;
201 my $qf = 1 if $translator->quote_field_names;
203 if ( $translator->parser_type =~ /mysql/i ) {
205 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
206 "-- but we set it here anyway to be self-consistent.\n"
210 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
213 for my $table ( $schema->get_tables ) {
214 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
217 add_drop_table => $add_drop_table,
218 show_warnings => $WARN,
219 no_comments => $no_comments,
220 delay_constraints => $delay_constraints,
221 quote_table_names => $qt,
222 quote_field_names => $qf,
225 push @table_defs, @$table_def;
226 push @fk_defs, @$fk_def;
227 push @trigger_defs, @$trigger_def;
228 push @index_defs, @$index_def;
229 push @constraint_defs, @$constraint_def;
233 foreach my $view ( $schema->get_views ) {
234 my ( $view_def ) = create_view(
237 add_drop_view => $add_drop_table,
238 quote_table_names => $qt,
241 push @view_defs, @$view_def;
245 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
248 $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
250 # If wantarray is not set we have to add "/" in this statement
251 # DBI->do() needs them omitted
252 # triggers may NOT end with a semicolon but a "/" instead
260 my ($table, $options) = @_;
261 my $qt = $options->{quote_table_names};
262 my $qf = $options->{quote_field_names};
263 my $table_name = $table->name;
264 my $table_name_q = quote($table_name,$qt);
268 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
270 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
271 push @create, qq[DROP TABLE $table_name_q CASCADE CONSTRAINTS] if $options->{add_drop_table};
273 my ( %field_name_scope, @field_comments );
274 for my $field ( $table->get_fields ) {
275 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
276 create_field($field, $options, \%field_name_scope);
277 push @create, @$field_create if ref $field_create;
278 push @field_defs, @$field_defs if ref $field_defs;
279 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
280 push @field_comments, @$field_comments if ref $field_comments;
287 for my $opt ( $table->options ) {
288 if ( ref $opt eq 'HASH' ) {
289 my ( $key, $value ) = each %$opt;
290 if ( ref $value eq 'ARRAY' ) {
291 push @table_options, "$key\n(\n". join ("\n",
292 map { " $_->[0]\t$_->[1]" }
297 elsif ( !defined $value ) {
298 push @table_options, $key;
301 push @table_options, "$key $value";
309 for my $c ( $table->get_constraints ) {
310 my $name = $c->name || '';
311 my @fields = map { quote($_,$qf) } $c->fields;
312 my @rfields = map { quote($_,$qf) } $c->reference_fields;
314 next if !@fields && $c->type ne CHECK_C;
316 if ( $c->type eq PRIMARY_KEY ) {
317 # create a name if delay_constraints
318 $name ||= mk_name( $table_name, 'pk' )
319 if $options->{delay_constraints};
320 $name = quote($name,$qf);
321 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
322 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
324 elsif ( $c->type eq UNIQUE ) {
325 # Don't create UNIQUE constraints identical to the primary key
326 if ( my $pk = $table->primary_key ) {
327 my $u_fields = join(":", @fields);
328 my $pk_fields = join(":", $pk->fields);
329 next if $u_fields eq $pk_fields;
333 # Force prepend of table_name as ORACLE doesn't allow duplicate
334 # CONSTRAINT names even for different tables (ORA-02264)
335 $name = mk_name( "${table_name}_$name", 'u' ) unless $name =~ /^$table_name/;
338 $name = mk_name( $table_name, 'u' );
341 $name = quote($name, $qf);
343 for my $f ( $c->fields ) {
344 my $field_def = $table->get_field( $f ) or next;
345 my $dtype = $translate{ ref $field_def->data_type eq "ARRAY" ? $field_def->data_type->[0] : $field_def->data_type} or next;
346 if ( $WARN && $dtype =~ /clob/i ) {
347 warn "Oracle will not allow UNIQUE constraints on " .
348 "CLOB field '" . $field_def->table->name . '.' .
349 $field_def->name . ".'\n"
353 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
354 '(' . join( ', ', @fields ) . ')';
356 elsif ( $c->type eq CHECK_C ) {
357 $name ||= mk_name( $name || $table_name, 'ck' );
358 $name = quote($name, $qf);
359 my $expression = $c->expression || '';
360 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
362 elsif ( $c->type eq FOREIGN_KEY ) {
363 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
364 $name = quote($name, $qf);
365 my $on_delete = uc ($c->on_delete || '');
367 my $def = "CONSTRAINT $name FOREIGN KEY ";
370 $def .= '(' . join( ', ', @fields ) . ')';
373 my $ref_table = quote($c->reference_table,$qt);
375 $def .= " REFERENCES $ref_table";
378 $def .= ' (' . join( ', ', @rfields ) . ')';
381 if ( $c->match_type ) {
383 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
386 if ( $on_delete && $on_delete ne "RESTRICT") {
387 $def .= ' ON DELETE '.$c->on_delete;
390 # disabled by plu 2007-12-29 - doesn't exist for oracle
391 #if ( $c->on_update ) {
392 # $def .= ' ON UPDATE '. $c->on_update;
395 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
403 for my $index ( $table->get_indices ) {
404 my $index_name = $index->name || '';
405 my $index_type = $index->type || NORMAL;
406 my @fields = map { quote($_, $qf) } $index->fields;
410 for my $opt ( $index->options ) {
411 if ( ref $opt eq 'HASH' ) {
412 my ( $key, $value ) = each %$opt;
413 if ( ref $value eq 'ARRAY' ) {
414 push @table_options, "$key\n(\n". join ("\n",
415 map { " $_->[0]\t$_->[1]" }
420 elsif ( !defined $value ) {
421 push @index_options, $key;
424 push @index_options, "$key $value";
428 my $index_options = @index_options
429 ? "\n".join("\n", @index_options) : '';
431 if ( $index_type eq PRIMARY_KEY ) {
432 $index_name = $index_name ? mk_name( $index_name )
433 : mk_name( $table_name, 'pk' );
434 $index_name = quote($index_name, $qf);
435 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
436 '(' . join( ', ', @fields ) . ')';
438 elsif ( $index_type eq NORMAL ) {
439 $index_name = $index_name ? mk_name( $index_name )
440 : mk_name( $table_name, $index_name || 'i' );
441 $index_name = quote($index_name, $qf);
443 "CREATE INDEX $index_name on $table_name_q (".
444 join( ', ', @fields ).
447 elsif ( $index_type eq UNIQUE ) {
448 $index_name = $index_name ? mk_name( $index_name )
449 : mk_name( $table_name, $index_name || 'i' );
450 $index_name = quote($index_name, $qf);
452 "CREATE UNIQUE INDEX $index_name on $table_name_q (".
453 join( ', ', @fields ).
457 warn "Unknown index type ($index_type) on table $table_name.\n"
462 if ( my @table_comments = $table->comments ) {
463 for my $comment ( @table_comments ) {
464 next unless $comment;
465 $comment = __PACKAGE__->_quote_string($comment);
466 push @field_comments, "COMMENT ON TABLE $table_name_q is\n $comment"
467 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 my $commalist = join( ', ', map { __PACKAGE__->_quote_string($_) } @$list );
555 if ( $data_type eq 'enum' ) {
556 $check = "CHECK ($field_name_q IN ($commalist))";
557 $data_type = 'varchar2';
559 elsif ( $data_type eq 'set' ) {
560 # XXX add a CHECK constraint maybe
561 # (trickier and slower, than enum :)
562 $data_type = 'varchar2';
565 if (defined $translate{ $data_type }) {
566 if (ref $translate{ $data_type } eq "ARRAY") {
567 ($data_type,$size[0]) = @{$translate{ $data_type }};
569 $data_type = $translate{ $data_type };
572 $data_type ||= 'varchar2';
575 # ensure size is not bigger than max size oracle allows for data type
576 if ( defined $max_size{$data_type} ) {
577 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
579 ref( $max_size{$data_type} ) eq 'ARRAY'
580 ? $max_size{$data_type}->[$i]
581 : $max_size{$data_type};
582 $size[$i] = $max if $size[$i] > $max;
587 # Fixes ORA-02329: column of datatype LOB cannot be
588 # unique or a primary key
590 if ( $data_type eq 'clob' && $field->is_primary_key ) {
591 $data_type = 'varchar2';
593 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
597 if ( $data_type eq 'clob' && $field->is_unique ) {
598 $data_type = 'varchar2';
600 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
605 # Fixes ORA-00907: missing right parenthesis
607 if ( $data_type =~ /(date|clob)/i ) {
612 # Fixes ORA-00906: missing right parenthesis
613 # if size is 0 or undefined
616 if ( $data_type =~ /^($_)$/i ) {
617 $size[0] ||= $max_size{$_};
621 $field_def .= " $data_type";
622 if ( defined $size[0] && $size[0] > 0 ) {
623 $field_def .= '(' . join( ',', @size ) . ')';
629 my $default = $field->default_value;
630 if ( defined $default ) {
632 # Wherein we try to catch a string being used as
633 # a default value for a numerical field. If "true/false,"
634 # then sub "1/0," otherwise just test the truthity of the
635 # argument and use that (naive?).
637 if (ref $default and defined $$default) {
638 $default = $$default;
639 } elsif (ref $default) {
642 $data_type =~ /^number$/i &&
643 $default !~ /^-?\d+$/ &&
646 if ( $default =~ /^true$/i ) {
648 } elsif ( $default =~ /^false$/i ) {
651 $default = $default ? "'1'" : "'0'";
654 $data_type =~ /date/ && (
655 $default eq 'current_timestamp'
660 $default = 'SYSDATE';
662 $default = $default =~ m/null/i ? 'NULL' : __PACKAGE__->_quote_string($default);
665 $field_def .= " DEFAULT $default",
669 # Not null constraint
671 unless ( $field->is_nullable ) {
672 $field_def .= ' NOT NULL';
675 $field_def .= " $check" if $check;
680 if ( $field->is_auto_increment ) {
681 my $base_name = $table_name . "_". $field_name;
682 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
683 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
685 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
686 push @create, "CREATE SEQUENCE $seq_name";
688 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
689 "BEFORE INSERT ON $table_name_q\n" .
690 "FOR EACH ROW WHEN (\n" .
691 " new.$field_name_q IS NULL".
692 " OR new.$field_name_q = 0\n".
695 " SELECT $seq_name.nextval\n" .
696 " INTO :new." . $field_name_q."\n" .
700 push @trigger_defs, $trigger;
703 if ( lc $field->data_type eq 'timestamp' ) {
704 my $base_name = $table_name . "_". $field_name;
705 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
707 "CREATE OR REPLACE TRIGGER $trig_name\n".
708 "BEFORE INSERT OR UPDATE ON $table_name_q\n".
709 "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
711 " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
714 push @trigger_defs, $trigger;
717 push @field_defs, $field_def;
719 if ( my $comment = $field->comments ) {
720 $comment =~ __PACKAGE__->_quote_string($comment);
721 push @field_comments,
722 "COMMENT ON COLUMN $table_name_q.$field_name_q is\n $comment;"
723 unless $options->{no_comments};
726 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
732 my ($view, $options) = @_;
733 my $qt = $options->{quote_table_names};
734 my $view_name = quote($view->name,$qt);
735 my $extra = $view->extra;
737 my $view_type = 'VIEW';
738 my $view_options = '';
739 if ( my $materialized = $extra->{materialized} ) {
740 $view_type = 'MATERIALIZED VIEW';
741 $view_options .= ' '.$materialized;
745 push @create, qq[DROP $view_type $view_name]
746 if $options->{add_drop_view};
748 push @create, sprintf("CREATE %s %s%s AS\n%s",
758 my $basename = shift || '';
759 my $type = shift || '';
760 $type = '' if $type =~ /^\d/;
761 my $scope = shift || '';
762 my $critical = shift || '';
763 my $basename_orig = $basename;
765 ? $max_id_length - (length($type) + 1)
767 $basename = substr( $basename, 0, $max_name )
768 if length( $basename ) > $max_name;
769 my $name = $type ? "${type}_$basename" : $basename;
771 if ( $basename ne $basename_orig and $critical ) {
772 my $show_type = $type ? "+'$type'" : "";
773 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
774 "character limit to make '$name'\n" if $WARN;
775 $truncated{ $basename_orig } = $name;
778 $scope ||= \%global_names;
779 if ( my $prev = $scope->{ $name } ) {
780 my $name_orig = $name;
781 substr($name, $max_id_length - 2) = ""
782 if length( $name ) >= $max_id_length - 1;
783 $name .= sprintf( "%02d", $prev++ );
785 warn "The name '$name_orig' has been changed to ",
786 "'$name' to make it unique.\n" if $WARN;
788 $scope->{ $name_orig }++;
799 return $name unless $q && $name;
800 $name =~ s/\Q$quote_char/$quote_char$quote_char/g;
801 return "$quote_char$name$quote_char";
805 # -------------------------------------------------------------------
806 # All bad art is the result of good intentions.
808 # -------------------------------------------------------------------
814 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
819 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
820 Alexander Hartmaier E<lt>abraxxa@cpan.orgE<gt>,
821 Fabien Wernli E<lt>faxmodem@cpan.orgE<gt>.
825 SQL::Translator, DDL::Oracle, mysql2ora.