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.
49 =head2 Autoincremental primary keys
51 This producer uses sequences and triggers to autoincrement primary key
52 columns, if necessary. SQLPlus and DBI expect a slightly different syntax
53 of CREATE TRIGGER statement. You might have noticed that this
54 producer returns a scalar containing all statements concatenated by
55 newlines or an array of single statements depending on the context
56 (scalar, array) it has been called in.
58 SQLPlus expects following trigger syntax:
60 CREATE OR REPLACE TRIGGER ai_person_id
61 BEFORE INSERT ON person
63 new.id IS NULL OR new.id = 0
66 SELECT sq_person_id.nextval
72 Whereas if you want to create the same trigger using L<DBI/do>, you need
73 to omit the last slash:
75 my $dbh = DBI->connect('dbi:Oracle:mysid', 'scott', 'tiger');
77 CREATE OR REPLACE TRIGGER ai_person_id
78 BEFORE INSERT ON person
80 new.id IS NULL OR new.id = 0
83 SELECT sq_person_id.nextval
89 If you call this producer in array context, we expect you want to process
90 the returned array of statements using L<DBI> like
91 L<DBIx::Class::Schema/deploy> does.
93 To get this working we removed the slash in those statements in version
94 0.09002 of L<SQL::Translator> when called in array context. In scalar
95 context the slash will be still there to ensure compatibility with SQLPlus.
100 use vars qw[ $VERSION $DEBUG $WARN ];
102 $DEBUG = 0 unless defined $DEBUG;
104 use SQL::Translator::Schema::Constants;
105 use SQL::Translator::Utils qw(header_comment);
117 mediumint => 'number',
118 smallint => 'number',
121 varchar => 'varchar2',
124 mediumblob => 'blob',
126 tinytext => 'varchar2',
129 mediumtext => 'clob',
142 'double precision' => 'number',
144 bigserial => 'number',
147 'character varying' => 'varchar2',
149 interval => 'number',
160 macaddr => 'varchar2',
162 'bit varying' => 'number',
168 varchar2 => 'varchar2',
173 # Oracle reserved words from:
174 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
175 # 817_doc/server.817/a85397/ap_keywd.htm
177 my %ora_reserved = map { $_, 1 } qw(
178 ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
180 CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
181 DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
182 ELSE EXCLUSIVE EXISTS
186 IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
187 INTEGER INTERSECT INTO IS
189 MAXEXTENTS MINUS MLSLABEL MODE MODIFY
190 NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
191 OF OFFLINE ON ONLINE OPTION OR ORDER
192 PCTFREE PRIOR PRIVILEGES PUBLIC
193 RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
194 SELECT SESSION SET SHARE SIZE SMALLINT START
195 SUCCESSFUL SYNONYM SYSDATE
196 TABLE THEN TO TRIGGER
197 UID UNION UNIQUE UPDATE USER
198 VALIDATE VALUES VARCHAR VARCHAR2 VIEW
203 # Oracle 8/9 max size of data types from:
204 # http://www.ss64.com/orasyntax/datatypes.html
210 number => [ 38, 127 ],
212 varchar => 4000, # only synonym for varchar2
216 my $max_id_length = 30;
217 my %used_identifiers = ();
222 # -------------------------------------------------------------------
224 my $translator = shift;
225 $DEBUG = $translator->debug;
226 $WARN = $translator->show_warnings || 0;
227 my $no_comments = $translator->no_comments;
228 my $add_drop_table = $translator->add_drop_table;
229 my $schema = $translator->schema;
230 my $delay_constraints = $translator->producer_args->{delay_constraints};
231 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
233 $create .= header_comment unless ($no_comments);
235 if ( $translator->parser_type =~ /mysql/i ) {
237 "-- We assume that default NLS_DATE_FORMAT has been changed\n".
238 "-- but we set it here anyway to be self-consistent.\n"
242 "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
245 for my $table ( $schema->get_tables ) {
246 my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
249 add_drop_table => $add_drop_table,
250 show_warnings => $WARN,
251 no_comments => $no_comments,
252 delay_constraints => $delay_constraints,
255 push @table_defs, @$table_def;
256 push @fk_defs, @$fk_def;
257 push @trigger_defs, @$trigger_def;
258 push @index_defs, @$index_def;
259 push @constraint_defs, @$constraint_def;
263 foreach my $view ( $schema->get_views ) {
264 my ( $view_def ) = create_view(
267 add_drop_view => $add_drop_table,
270 push @view_defs, @$view_def;
274 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
277 $create .= join ('', map { $_ ? "$_;\n\n" : () } @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
278 # If wantarray is not set we have to add "/" in this statement
279 # DBI->do() needs them omitted
280 # triggers may NOT end with a semicolon
281 $create .= join "/\n\n", @trigger_defs;
289 my ($table, $options) = @_;
290 my $table_name = $table->name;
294 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
296 my $table_name_ur = unreserve($table_name) or next;
298 push @create, "--\n-- Table: $table_name_ur\n--" unless $options->{no_comments};
299 push @create, qq[DROP TABLE $table_name_ur CASCADE CONSTRAINTS] if $options->{add_drop_table};
301 my ( %field_name_scope, @field_comments );
302 for my $field ( $table->get_fields ) {
303 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
304 create_field($field, $options, \%field_name_scope);
305 push @create, @$field_create if ref $field_create;
306 push @field_defs, @$field_defs if ref $field_defs;
307 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
308 push @field_comments, @$field_comments if ref $field_comments;
315 for my $opt ( $table->options ) {
316 if ( ref $opt eq 'HASH' ) {
317 my ( $key, $value ) = each %$opt;
318 if ( ref $value eq 'ARRAY' ) {
319 push @table_options, "$key\n(\n". join ("\n",
320 map { " $_->[0]\t$_->[1]" }
325 elsif ( !defined $value ) {
326 push @table_options, $key;
329 push @table_options, "$key $value";
337 for my $c ( $table->get_constraints ) {
338 my $name = $c->name || '';
339 my @fields = map { unreserve( $_, $table_name ) } $c->fields;
340 my @rfields = map { unreserve( $_, $table_name ) }
341 $c->reference_fields;
342 next if !@fields && $c->type ne CHECK_C;
344 if ( $c->type eq PRIMARY_KEY ) {
345 # create a name if delay_constraints
346 $name ||= mk_name( $table_name, 'pk' )
347 if $options->{delay_constraints};
348 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
349 'PRIMARY KEY (' . join( ', ', @fields ) . ')';
351 elsif ( $c->type eq UNIQUE ) {
352 # Don't create UNIQUE constraints identical to the primary key
353 if ( my $pk = $table->primary_key ) {
354 my $u_fields = join(":", @fields);
355 my $pk_fields = join(":", $pk->fields);
356 next if $u_fields eq $pk_fields;
359 $name ||= mk_name( $name || $table_name, 'u' );
361 for my $f ( $c->fields ) {
362 my $field_def = $table->get_field( $f ) or next;
363 my $dtype = $translate{ $field_def->data_type } or next;
364 if ( $WARN && $dtype =~ /clob/i ) {
365 warn "Oracle will not allow UNIQUE constraints on " .
366 "CLOB field '" . $field_def->table->name . '.' .
367 $field_def->name . ".'\n"
371 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
372 '(' . join( ', ', @fields ) . ')';
374 elsif ( $c->type eq CHECK_C ) {
375 $name ||= mk_name( $name || $table_name, 'ck' );
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 my $def = "CONSTRAINT $name FOREIGN KEY ";
384 $def .= '(' . join( ', ', @fields ) . ')';
387 my $ref_table = unreserve($c->reference_table);
389 $def .= " REFERENCES $ref_table";
392 $def .= ' (' . join( ', ', @rfields ) . ')';
395 if ( $c->match_type ) {
397 ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
400 if ( $c->on_delete ) {
401 $def .= ' ON DELETE '.join( ' ', $c->on_delete );
404 # disabled by plu 2007-12-29 - doesn't exist for oracle
405 #if ( $c->on_update ) {
406 # $def .= ' ON UPDATE '.join( ' ', $c->on_update );
409 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_ur, $def);
417 for my $index ( $table->get_indices ) {
418 my $index_name = $index->name || '';
419 my $index_type = $index->type || NORMAL;
420 my @fields = map { unreserve( $_, $table_name ) }
425 for my $opt ( $index->options ) {
426 if ( ref $opt eq 'HASH' ) {
427 my ( $key, $value ) = each %$opt;
428 if ( ref $value eq 'ARRAY' ) {
429 push @table_options, "$key\n(\n". join ("\n",
430 map { " $_->[0]\t$_->[1]" }
435 elsif ( !defined $value ) {
436 push @index_options, $key;
439 push @index_options, "$key $value";
443 my $index_options = @index_options
444 ? "\n".join("\n", @index_options) : '';
446 if ( $index_type eq PRIMARY_KEY ) {
447 $index_name = $index_name ? mk_name( $index_name )
448 : mk_name( $table_name, 'pk' );
449 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
450 '(' . join( ', ', @fields ) . ')';
452 elsif ( $index_type eq NORMAL ) {
453 $index_name = $index_name ? mk_name( $index_name )
454 : mk_name( $table_name, $index_name || 'i' );
456 "CREATE INDEX $index_name on $table_name_ur (".
457 join( ', ', @fields ).
460 elsif ( $index_type eq UNIQUE ) {
461 $index_name = $index_name ? mk_name( $index_name )
462 : mk_name( $table_name, $index_name || 'i' );
464 "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
465 join( ', ', @fields ).
469 warn "Unknown index type ($index_type) on table $table_name.\n"
474 if ( my @table_comments = $table->comments ) {
475 for my $comment ( @table_comments ) {
476 next unless $comment;
477 $comment =~ s/'/''/g;
478 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
479 $comment . "'" unless $options->{no_comments}
484 my $table_options = @table_options
485 ? "\n".join("\n", @table_options) : '';
486 push @create, "CREATE TABLE $table_name_ur (\n" .
487 join( ",\n", map { " $_" } @field_defs,
488 ($options->{delay_constraints} ? () : @constraint_defs) ) .
491 @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_ }
496 warn "Truncated " . keys( %truncated ) . " names:\n";
497 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
501 warn "Encounted " . keys( %unreserve ) .
502 " unsafe names in schema (reserved or invalid):\n";
503 warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
507 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
511 my ($from_field, $to_field, $options) = @_;
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 = $to_field->table->name;
524 my $table_name_ur = unreserve( $table_name );
526 return 'ALTER TABLE '.$table_name_ur.' MODIFY ( '.join('', @$field_defs).' )';
530 my ($new_field, $options) = @_;
532 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
533 create_field($new_field, $options, {});
535 my $table_name = $new_field->table->name;
536 my $table_name_ur = unreserve( $table_name );
538 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
540 join('', @$field_defs));
545 my ($field, $options, $field_name_scope) = @_;
547 my (@create, @field_defs, @trigger_defs, @field_comments);
549 my $table_name = $field->table->name;
550 my $table_name_ur = unreserve( $table_name );
555 my $field_name = mk_name(
556 $field->name, '', $field_name_scope, 1
559 my $field_name_ur = unreserve( $field_name, $table_name );
560 my $field_def = $field_name_ur;
561 $field->name( $field_name_ur );
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_ur 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 $data_type = defined $translate{ $data_type } ?
585 $translate{ $data_type } :
587 $data_type ||= 'varchar2';
590 # ensure size is not bigger than max size oracle allows for data type
591 if ( defined $max_size{$data_type} ) {
592 for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
594 ref( $max_size{$data_type} ) eq 'ARRAY'
595 ? $max_size{$data_type}->[$i]
596 : $max_size{$data_type};
597 $size[$i] = $max if $size[$i] > $max;
602 # Fixes ORA-02329: column of datatype LOB cannot be
603 # unique or a primary key
605 if ( $data_type eq 'clob' && $field->is_primary_key ) {
606 $data_type = 'varchar2';
608 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
612 if ( $data_type eq 'clob' && $field->is_unique ) {
613 $data_type = 'varchar2';
615 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
620 # Fixes ORA-00907: missing right parenthesis
622 if ( $data_type =~ /(date|clob)/i ) {
626 $field_def .= " $data_type";
627 if ( defined $size[0] && $size[0] > 0 ) {
628 $field_def .= '(' . join( ',', @size ) . ')';
634 my $default = $field->default_value;
635 if ( defined $default ) {
637 # Wherein we try to catch a string being used as
638 # a default value for a numerical field. If "true/false,"
639 # then sub "1/0," otherwise just test the truthity of the
640 # argument and use that (naive?).
642 if (ref $default and defined $$default) {
643 $default = $$default;
644 } elsif (ref $default) {
647 $data_type =~ /^number$/i &&
648 $default !~ /^-?\d+$/ &&
651 if ( $default =~ /^true$/i ) {
653 } elsif ( $default =~ /^false$/i ) {
656 $default = $default ? "'1'" : "'0'";
659 $data_type =~ /date/ && (
660 $default eq 'current_timestamp'
665 $default = 'SYSDATE';
667 $default = $default =~ m/null/i ? 'NULL' : "'$default'"
670 $field_def .= " DEFAULT $default",
674 # Not null constraint
676 unless ( $field->is_nullable ) {
677 $field_def .= ' NOT NULL';
680 $field_def .= " $check" if $check;
685 if ( $field->is_auto_increment ) {
686 my $base_name = $table_name_ur . "_". $field_name;
687 my $seq_name = mk_name( $base_name, 'sq' );
688 my $trigger_name = mk_name( $base_name, 'ai' );
690 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
691 push @create, "CREATE SEQUENCE $seq_name";
693 "CREATE OR REPLACE TRIGGER $trigger_name\n" .
694 "BEFORE INSERT ON $table_name_ur\n" .
695 "FOR EACH ROW WHEN (\n" .
696 " new.$field_name_ur IS NULL".
697 " OR new.$field_name_ur = 0\n".
700 " SELECT $seq_name.nextval\n" .
701 " INTO :new." . $field->name."\n" .
705 push @trigger_defs, $trigger;
708 if ( lc $field->data_type eq 'timestamp' ) {
709 my $base_name = $table_name_ur . "_". $field_name_ur;
710 my $trig_name = mk_name( $base_name, 'ts' );
712 "CREATE OR REPLACE TRIGGER $trig_name\n".
713 "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
714 "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
716 " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
719 push @trigger_defs, $trigger;
722 push @field_defs, $field_def;
724 if ( my $comment = $field->comments ) {
725 $comment =~ s/'/''/g;
726 push @field_comments,
727 "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
728 $comment . "';" unless $options->{no_comments};
731 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
737 my ($view, $options) = @_;
738 my $view_name = $view->name;
741 push @create, qq[DROP VIEW $view_name]
742 if $options->{add_drop_view};
744 push @create, sprintf("CREATE VIEW %s AS\n%s",
751 # -------------------------------------------------------------------
753 my $basename = shift || '';
754 my $type = shift || '';
755 $type = '' if $type =~ /^\d/;
756 my $scope = shift || '';
757 my $critical = shift || '';
758 my $basename_orig = $basename;
760 ? $max_id_length - (length($type) + 1)
762 $basename = substr( $basename, 0, $max_name )
763 if length( $basename ) > $max_name;
764 my $name = $type ? "${type}_$basename" : $basename;
766 if ( $basename ne $basename_orig and $critical ) {
767 my $show_type = $type ? "+'$type'" : "";
768 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
769 "character limit to make '$name'\n" if $WARN;
770 $truncated{ $basename_orig } = $name;
773 $scope ||= \%global_names;
774 if ( my $prev = $scope->{ $name } ) {
775 my $name_orig = $name;
776 substr($name, $max_id_length - 2) = ""
777 if length( $name ) >= $max_id_length - 1;
778 $name .= sprintf( "%02d", $prev++ );
780 warn "The name '$name_orig' has been changed to ",
781 "'$name' to make it unique.\n" if $WARN;
783 $scope->{ $name_orig }++;
790 # -------------------------------------------------------------------
792 my $name = shift || '';
793 my $schema_obj_name = shift || '';
795 my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
797 # also trap fields that don't begin with a letter
798 return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
800 if ( $schema_obj_name ) {
801 ++$unreserve{"$schema_obj_name.$name"};
804 ++$unreserve{"$name (table name)"};
807 my $unreserve = sprintf '%s_', $name;
808 return $unreserve.$suffix;
813 # -------------------------------------------------------------------
814 # All bad art is the result of good intentions.
816 # -------------------------------------------------------------------
822 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
827 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>.
831 SQL::Translator, DDL::Oracle, mysql2ora.