lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.34 2005-08-10 16:33:39 duality72 Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002-4 SQLFairy Authors
   7 #
   8 # This program is free software; you can redistribute it and/or
   9 # modify it under the terms of the GNU General Public License as
  10 # published by the Free Software Foundation; version 2.
  11 #
  12 # This program is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 # General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with this program; if not, write to the Free Software
  19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  20 # 02111-1307  USA
  21 # -------------------------------------------------------------------
  22
  23 =head1 NAME
  24
  25 SQL::Translator::Producer::Oracle - Oracle SQL producer
  26
  27 =head1 SYNOPSIS
  28
  29   use SQL::Translator;
  30
  31   my $t = SQL::Translator->new( parser => '...', producer => 'Oracle' );
  32   print $translator->translate( $file );
  33
  34 =head1 DESCRIPTION
  35
  36 Creates an SQL DDL suitable for Oracle.
  37
  38 =cut
  39
  40 use strict;
  41 use vars qw[ $VERSION $DEBUG $WARN ];
  42 $VERSION = sprintf "%d.%02d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/;
  43 $DEBUG   = 0 unless defined $DEBUG;
  44
  45 use SQL::Translator::Schema::Constants;
  46 use SQL::Translator::Utils qw(header_comment);
  47
  48 my %translate  = (
  49     #
  50     # MySQL types
  51     #
  52     bigint     => 'number',
  53     double     => 'number',
  54     decimal    => 'number',
  55     float      => 'number',
  56     int        => 'number',
  57     integer    => 'number',
  58     mediumint  => 'number',
  59     smallint   => 'number',
  60     tinyint    => 'number',
  61     char       => 'char',
  62     varchar    => 'varchar2',
  63     tinyblob   => 'blob',
  64     blob       => 'blob',
  65     mediumblob => 'blob',
  66     longblob   => 'blob',
  67     tinytext   => 'varchar2',
  68     text       => 'clob',
  69     longtext   => 'clob',
  70     mediumtext => 'clob',
  71     enum       => 'varchar2',
  72     set        => 'varchar2',
  73     date       => 'date',
  74     datetime   => 'date',
  75     time       => 'date',
  76     timestamp  => 'date',
  77     year       => 'date',
  78
  79     #
  80     # PostgreSQL types
  81     #
  82     numeric             => 'number',
  83     'double precision'  => 'number',
  84     serial              => 'number',
  85     bigserial           => 'number',
  86     money               => 'number',
  87     character           => 'char',
  88     'character varying' => 'varchar2',
  89     bytea               => 'BLOB',
  90     interval            => 'number',
  91     boolean             => 'number',
  92     point               => 'number',
  93     line                => 'number',
  94     lseg                => 'number',
  95     box                 => 'number',
  96     path                => 'number',
  97     polygon             => 'number',
  98     circle              => 'number',
  99     cidr                => 'number',
 100     inet                => 'varchar2',
 101     macaddr             => 'varchar2',
 102     bit                 => 'number',
 103     'bit varying'       => 'number',
 104
 105     #
 106     # Oracle types
 107     #
 108     number              => 'number',
 109     varchar2            => 'varchar2',
 110     long                => 'clob',
 111 );
 112
 113 #
 114 # Oracle reserved words from:
 115 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
 116 # 817_doc/server.817/a85397/ap_keywd.htm
 117 #
 118 my %ora_reserved = map { $_, 1 } qw(
 119     ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
 120     BETWEEN BY
 121     CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
 122     DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
 123     ELSE EXCLUSIVE EXISTS
 124     FILE FLOAT FOR FROM
 125     GRANT GROUP
 126     HAVING
 127     IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
 128     INTEGER INTERSECT INTO IS
 129     LEVEL LIKE LOCK LONG
 130     MAXEXTENTS MINUS MLSLABEL MODE MODIFY
 131     NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
 132     OF OFFLINE ON ONLINE OPTION OR ORDER
 133     PCTFREE PRIOR PRIVILEGES PUBLIC
 134     RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
 135     SELECT SESSION SET SHARE SIZE SMALLINT START
 136     SUCCESSFUL SYNONYM SYSDATE
 137     TABLE THEN TO TRIGGER
 138     UID UNION UNIQUE UPDATE USER
 139     VALIDATE VALUES VARCHAR VARCHAR2 VIEW
 140     WHENEVER WHERE WITH
 141 );
 142
 143 my $max_id_length    = 30;
 144 my %used_identifiers = ();
 145 my %global_names;
 146 my %unreserve;
 147 my %truncated;
 148
 149 # -------------------------------------------------------------------
 150 sub produce {
 151     my $translator     = shift;
 152     $DEBUG             = $translator->debug;
 153     $WARN              = $translator->show_warnings || 0;
 154     my $no_comments    = $translator->no_comments;
 155     my $add_drop_table = $translator->add_drop_table;
 156     my $schema         = $translator->schema;
 157     my ($output, $create, @table_defs, @fk_defs, @trigger_defs);
 158
 159     $create .= header_comment unless ($no_comments);
 160
 161     if ( $translator->parser_type =~ /mysql/i ) {
 162         $create .=
 163             "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 164             "-- but we set it here anyway to be self-consistent.\n"
 165             unless $no_comments;
 166
 167         $create .=
 168         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 169     }
 170
 171     for my $table ( $schema->get_tables ) {
 172         my ( $table_def, $fk_def, $trigger_def ) = create_table(
 173             $table,
 174             {
 175                 add_drop_table => $add_drop_table,
 176                 show_warnings  => $WARN,
 177                 no_comments    => $no_comments,
 178             }
 179         );
 180         push @table_defs, @$table_def;
 181         push @fk_defs, @$fk_def;
 182         push @trigger_defs, @$trigger_def;
 183     }
 184
 185     my (@view_defs);
 186     foreach my $view ( $schema->get_views ) {
 187         push @view_defs, create_view($view);
 188     }
 189
 190     return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs) : $create . join ("\n\n", @table_defs, @view_defs, @fk_defs, @trigger_defs);
 191 }
 192
 193 sub create_table {
 194     my ($table, $options) = @_;
 195     my $table_name = $table->name;
 196
 197     my $item = '';
 198     my $drop;
 199     my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
 200
 201     push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
 202     push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};
 203
 204     my $table_name_ur = unreserve($table_name) or next;
 205
 206         my ( %field_name_scope, @field_comments );
 207         for my $field ( $table->get_fields ) {
 208             #
 209             # Field name
 210             #
 211             my $field_name    = mk_name(
 212                 $field->name, '', \%field_name_scope, 1
 213             );
 214             my $field_name_ur = unreserve( $field_name, $table_name );
 215             my $field_def     = $field_name_ur;
 216             $field->name( $field_name_ur );
 217
 218             #
 219             # Datatype
 220             #
 221             my $check;
 222             my $data_type = lc $field->data_type;
 223             my @size      = $field->size;
 224             my %extra     = $field->extra;
 225             my $list      = $extra{'list'} || [];
 226             # \todo deal with embedded quotes
 227             my $commalist = join( ', ', map { qq['$_'] } @$list );
 228
 229             if ( $data_type eq 'enum' ) {
 230                 $check = "CHECK ($field_name_ur IN ($commalist))";
 231                 $data_type = 'varchar2';
 232             }
 233             elsif ( $data_type eq 'set' ) {
 234                 # XXX add a CHECK constraint maybe
 235                 # (trickier and slower, than enum :)
 236                 $data_type = 'varchar2';
 237             }
 238             else {
 239                 $data_type  = defined $translate{ $data_type } ?
 240                               $translate{ $data_type } :
 241                               $data_type;
 242                 $data_type ||= 'varchar2';
 243             }
 244
 245             #
 246             # Fixes ORA-02329: column of datatype LOB cannot be
 247             # unique or a primary key
 248             #
 249             if ( $data_type eq 'clob' && $field->is_primary_key ) {
 250                 $data_type = 'varchar2';
 251                 $size[0]   = 4000;
 252                 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 253                     if $WARN;
 254             }
 255
 256             if ( $data_type eq 'clob' && $field->is_unique ) {
 257                 $data_type = 'varchar2';
 258                 $size[0]   = 4000;
 259                 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
 260                     if $WARN;
 261             }
 262
 263             #
 264             # Fixes ORA-00907: missing right parenthesis
 265             #
 266             if ( $data_type =~ /(date|clob)/i ) {
 267                 undef @size;
 268             }
 269
 270             $field_def .= " $data_type";
 271             if ( defined $size[0] && $size[0] > 0 ) {
 272                 $field_def .= '(' . join( ', ', @size ) . ')';
 273             }
 274
 275             #
 276             # Default value
 277             #
 278             my $default = $field->default_value;
 279             if ( defined $default ) {
 280                 #
 281                 # Wherein we try to catch a string being used as
 282                 # a default value for a numerical field.  If "true/false,"
 283                 # then sub "1/0," otherwise just test the truthity of the
 284                 # argument and use that (naive?).
 285                 #
 286                 if (
 287                     $data_type =~ /^number$/i &&
 288                     $default   !~ /^-?\d+$/     &&
 289                     $default   !~ m/null/i
 290                 ) {
 291                     if ( $default =~ /^true$/i ) {
 292                         $default = "'1'";
 293                     }
 294                     elsif ( $default =~ /^false$/i ) {
 295                         $default = "'0'";
 296                     }
 297                     else {
 298                         $default = $default ? "'1'" : "'0'";
 299                     }
 300                 }
 301                 elsif (
 302                     $data_type =~ /date/ && (
 303                         $default eq 'current_timestamp'
 304                         ||
 305                         $default eq 'now()'
 306                     )
 307                 ) {
 308                     $default = 'SYSDATE';
 309                 }
 310                 else {
 311                     $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 312                 }
 313
 314                 $field_def .= " DEFAULT $default",
 315             }
 316
 317             #
 318             # Not null constraint
 319             #
 320             unless ( $field->is_nullable ) {
 321                 $field_def .= ' NOT NULL';
 322             }
 323
 324             $field_def .= " $check" if $check;
 325
 326             #
 327             # Auto_increment
 328             #
 329             if ( $field->is_auto_increment ) {
 330                 my $base_name    = $table_name_ur . "_". $field_name;
 331                 my $seq_name     = mk_name( $base_name, 'sq' );
 332                 my $trigger_name = mk_name( $base_name, 'ai' );
 333
 334             push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
 335             push @create, "CREATE SEQUENCE $seq_name;";
 336                 push @trigger_defs,
 337                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 338                     "BEFORE INSERT ON $table_name_ur\n" .
 339                     "FOR EACH ROW WHEN (\n" .
 340                         " new.$field_name_ur IS NULL".
 341                         " OR new.$field_name_ur = 0\n".
 342                     ")\n".
 343                     "BEGIN\n" .
 344                         " SELECT $seq_name.nextval\n" .
 345                         " INTO :new." . $field->name."\n" .
 346                         " FROM dual;\n" .
 347                     "END;\n/";
 348                 ;
 349             }
 350
 351             if ( lc $field->data_type eq 'timestamp' ) {
 352                 my $base_name = $table_name_ur . "_". $field_name_ur;
 353                 my $trig_name = mk_name( $base_name, 'ts' );
 354                 push @trigger_defs,
 355                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 356                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 357                     "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 358                     "BEGIN \n".
 359                     " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 360                     "END;\n/";
 361             }
 362
 363             push @field_defs, $field_def;
 364
 365             if ( my $comment = $field->comments ) {
 366                 $comment =~ s/'/''/g;
 367                 push @field_comments,
 368                     "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
 369                 $comment . "';" unless $options->{no_comments};
 370             }
 371         }
 372
 373         #
 374         # Table options
 375         #
 376         my @table_options;
 377         for my $opt ( $table->options ) {
 378             if ( ref $opt eq 'HASH' ) {
 379                 my ( $key, $value ) = each %$opt;
 380                 if ( ref $value eq 'ARRAY' ) {
 381                     push @table_options, "$key\n(\n".  join ("\n",
 382                         map { "  $_->[0]\t$_->[1]" }
 383                         map { [ each %$_ ] }
 384                         @$value
 385                     )."\n)";
 386                 }
 387                 elsif ( !defined $value ) {
 388                     push @table_options, $key;
 389                 }
 390                 else {
 391                     push @table_options, "$key    $value";
 392                 }
 393             }
 394         }
 395
 396         #
 397         # Table constraints
 398         #
 399         for my $c ( $table->get_constraints ) {
 400             my $name    = $c->name || '';
 401             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 402             my @rfields = map { unreserve( $_, $table_name ) }
 403                 $c->reference_fields;
 404             next if !@fields && $c->type ne CHECK_C;
 405
 406             if ( $c->type eq PRIMARY_KEY ) {
 407                 #$name ||= mk_name( $table_name, 'pk' );
 408                 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
 409                         'PRIMARY KEY (' . join( ', ', @fields ) . ')';
 410             }
 411             elsif ( $c->type eq UNIQUE ) {
 412                 # Don't create UNIQUE constraints identical to the primary key
 413                 if ( my $pk = $table->primary_key ) {
 414                                         my $u_fields = join(":", @fields);
 415                                         my $pk_fields = join(":", $pk->fields);
 416                                         next if $u_fields eq $pk_fields;
 417                 }
 418
 419                 $name ||= mk_name( $name || $table_name, 'u' );
 420
 421                 for my $f ( $c->fields ) {
 422                     my $field_def = $table->get_field( $f ) or next;
 423                     my $dtype     = $translate{ $field_def->data_type } or next;
 424                     if ( $WARN && $dtype =~ /clob/i ) {
 425                         warn "Oracle will not allow UNIQUE constraints on " .
 426                              "CLOB field '" . $field_def->table->name . '.' .
 427                              $field_def->name . ".'\n"
 428                     }
 429                 }
 430
 431                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 432                     '(' . join( ', ', @fields ) . ')';
 433             }
 434             elsif ( $c->type eq CHECK_C ) {
 435                 $name ||= mk_name( $name || $table_name, 'ck' );
 436                 my $expression = $c->expression || '';
 437                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 438             }
 439             elsif ( $c->type eq FOREIGN_KEY ) {
 440             $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
 441                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 442
 443                 if ( @fields ) {
 444                     $def .= '(' . join( ', ', @fields ) . ')';
 445                 }
 446
 447                 my $ref_table = unreserve($c->reference_table);
 448
 449                 $def .= " REFERENCES $ref_table";
 450
 451                 if ( @rfields ) {
 452                     $def .= ' (' . join( ', ', @rfields ) . ')';
 453                 }
 454
 455                 if ( $c->match_type ) {
 456                     $def .= ' MATCH ' .
 457                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 458                 }
 459
 460                 if ( $c->on_delete ) {
 461                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 462                 }
 463
 464             # disabled by plu 2007-12-29 - doesn't exist for oracle
 465             #if ( $c->on_update ) {
 466             #    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 467             #}
 468
 469             push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
 470             }
 471         }
 472
 473         #
 474         # Index Declarations
 475         #
 476         my @index_defs = ();
 477         for my $index ( $table->get_indices ) {
 478             my $index_name = $index->name || '';
 479             my $index_type = $index->type || NORMAL;
 480             my @fields     = map { unreserve( $_, $table_name ) }
 481                              $index->fields;
 482             next unless @fields;
 483
 484             if ( $index_type eq PRIMARY_KEY ) {
 485                 $index_name = $index_name ? mk_name( $index_name )
 486                     : mk_name( $table_name, 'pk' );
 487                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 488                     '(' . join( ', ', @fields ) . ')';
 489             }
 490             elsif ( $index_type eq NORMAL ) {
 491                 $index_name = $index_name ? mk_name( $index_name )
 492                     : mk_name( $table_name, $index_name || 'i' );
 493                 push @index_defs,
 494                     "CREATE INDEX $index_name on $table_name_ur (".
 495                         join( ', ', @fields ).
 496                     ");";
 497             }
 498             else {
 499                 warn "Unknown index type ($index_type) on table $table_name.\n"
 500                     if $WARN;
 501             }
 502         }
 503
 504         if ( my @table_comments = $table->comments ) {
 505             for my $comment ( @table_comments ) {
 506                 next unless $comment;
 507                 $comment =~ s/'/''/g;
 508                 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
 509                 $comment . "';" unless $options->{no_comments}
 510                 ;
 511             }
 512         }
 513
 514         my $table_options = @table_options
 515             ? "\n".join("\n", @table_options) : '';
 516     push @create, "CREATE TABLE $table_name_ur (\n" .
 517             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 518         "\n)$table_options;";
 519
 520     if ( $WARN ) {
 521         if ( %truncated ) {
 522             warn "Truncated " . keys( %truncated ) . " names:\n";
 523             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 524         }
 525
 526         if ( %unreserve ) {
 527             warn "Encounted " . keys( %unreserve ) .
 528                 " unsafe names in schema (reserved or invalid):\n";
 529             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 530         }
 531     }
 532
 533     return \@create, \@fk_defs, \@trigger_defs;
 534 }
 535
 536 sub create_view {
 537     my ($view) = @_;
 538
 539     my $out = sprintf("CREATE VIEW %s AS\n%s;",
 540                       $view->name,
 541                       $view->sql);
 542
 543     return $out;
 544 }
 545
 546 # -------------------------------------------------------------------
 547 sub mk_name {
 548     my $basename      = shift || '';
 549     my $type          = shift || '';
 550        $type          = '' if $type =~ /^\d/;
 551     my $scope         = shift || '';
 552     my $critical      = shift || '';
 553     my $basename_orig = $basename;
 554     my $max_name      = $type
 555                         ? $max_id_length - (length($type) + 1)
 556                         : $max_id_length;
 557     $basename         = substr( $basename, 0, $max_name )
 558                         if length( $basename ) > $max_name;
 559     my $name          = $type ? "${type}_$basename" : $basename;
 560
 561     if ( $basename ne $basename_orig and $critical ) {
 562         my $show_type = $type ? "+'$type'" : "";
 563         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 564             "character limit to make '$name'\n" if $WARN;
 565         $truncated{ $basename_orig } = $name;
 566     }
 567
 568     $scope ||= \%global_names;
 569     if ( my $prev = $scope->{ $name } ) {
 570         my $name_orig = $name;
 571         substr($name, $max_id_length - 2) = ""
 572             if length( $name ) >= $max_id_length - 1;
 573         $name        .= sprintf( "%02d", $prev++ );
 574
 575         warn "The name '$name_orig' has been changed to ",
 576              "'$name' to make it unique.\n" if $WARN;
 577
 578         $scope->{ $name_orig }++;
 579     }
 580
 581     $scope->{ $name }++;
 582     return $name;
 583 }
 584
 585 # -------------------------------------------------------------------
 586 sub unreserve {
 587     my $name            = shift || '';
 588     my $schema_obj_name = shift || '';
 589
 590     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 591
 592     # also trap fields that don't begin with a letter
 593     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 594
 595     if ( $schema_obj_name ) {
 596         ++$unreserve{"$schema_obj_name.$name"};
 597     }
 598     else {
 599         ++$unreserve{"$name (table name)"};
 600     }
 601
 602     my $unreserve = sprintf '%s_', $name;
 603     return $unreserve.$suffix;
 604 }
 605
 606 1;
 607
 608 # -------------------------------------------------------------------
 609 # All bad art is the result of good intentions.
 610 # Oscar Wilde
 611 # -------------------------------------------------------------------
 612
 613 =pod
 614
 615 =head1 CREDITS
 616
 617 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 618 script.
 619
 620 =head1 AUTHOR
 621
 622 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 623
 624 =head1 SEE ALSO
 625
 626 SQL::Translator, DDL::Oracle, mysql2ora.
 627
 628 =cut