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, @index_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, $index_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         push @index_defs, @$index_def;
 184     }
 185
 186     my (@view_defs);
 187     foreach my $view ( $schema->get_views ) {
 188         push @view_defs, create_view($view);
 189     }
 190
 191     return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs) : $create . join ("\n\n", @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, '');
 192 }
 193
 194 sub create_table {
 195     my ($table, $options) = @_;
 196     my $table_name = $table->name;
 197
 198     my $item = '';
 199     my $drop;
 200     my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
 201
 202     push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
 203     push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};
 204
 205     my $table_name_ur = unreserve($table_name) or next;
 206
 207         my ( %field_name_scope, @field_comments );
 208         for my $field ( $table->get_fields ) {
 209             #
 210             # Field name
 211             #
 212             my $field_name    = mk_name(
 213                 $field->name, '', \%field_name_scope, 1
 214             );
 215             my $field_name_ur = unreserve( $field_name, $table_name );
 216             my $field_def     = $field_name_ur;
 217             $field->name( $field_name_ur );
 218
 219             #
 220             # Datatype
 221             #
 222             my $check;
 223             my $data_type = lc $field->data_type;
 224             my @size      = $field->size;
 225             my %extra     = $field->extra;
 226             my $list      = $extra{'list'} || [];
 227             # \todo deal with embedded quotes
 228             my $commalist = join( ', ', map { qq['$_'] } @$list );
 229
 230             if ( $data_type eq 'enum' ) {
 231                 $check = "CHECK ($field_name_ur IN ($commalist))";
 232                 $data_type = 'varchar2';
 233             }
 234             elsif ( $data_type eq 'set' ) {
 235                 # XXX add a CHECK constraint maybe
 236                 # (trickier and slower, than enum :)
 237                 $data_type = 'varchar2';
 238             }
 239             else {
 240                 $data_type  = defined $translate{ $data_type } ?
 241                               $translate{ $data_type } :
 242                               $data_type;
 243                 $data_type ||= 'varchar2';
 244             }
 245
 246             #
 247             # Fixes ORA-02329: column of datatype LOB cannot be
 248             # unique or a primary key
 249             #
 250             if ( $data_type eq 'clob' && $field->is_primary_key ) {
 251                 $data_type = 'varchar2';
 252                 $size[0]   = 4000;
 253                 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 254                     if $WARN;
 255             }
 256
 257             if ( $data_type eq 'clob' && $field->is_unique ) {
 258                 $data_type = 'varchar2';
 259                 $size[0]   = 4000;
 260                 warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
 261                     if $WARN;
 262             }
 263
 264             #
 265             # Fixes ORA-00907: missing right parenthesis
 266             #
 267             if ( $data_type =~ /(date|clob)/i ) {
 268                 undef @size;
 269             }
 270
 271             $field_def .= " $data_type";
 272             if ( defined $size[0] && $size[0] > 0 ) {
 273                 $field_def .= '(' . join( ', ', @size ) . ')';
 274             }
 275
 276             #
 277             # Default value
 278             #
 279             my $default = $field->default_value;
 280             if ( defined $default ) {
 281                 #
 282                 # Wherein we try to catch a string being used as
 283                 # a default value for a numerical field.  If "true/false,"
 284                 # then sub "1/0," otherwise just test the truthity of the
 285                 # argument and use that (naive?).
 286                 #
 287                 if (
 288                     $data_type =~ /^number$/i &&
 289                     $default   !~ /^-?\d+$/     &&
 290                     $default   !~ m/null/i
 291                 ) {
 292                     if ( $default =~ /^true$/i ) {
 293                         $default = "'1'";
 294                     }
 295                     elsif ( $default =~ /^false$/i ) {
 296                         $default = "'0'";
 297                     }
 298                     else {
 299                         $default = $default ? "'1'" : "'0'";
 300                     }
 301                 }
 302                 elsif (
 303                     $data_type =~ /date/ && (
 304                         $default eq 'current_timestamp'
 305                         ||
 306                         $default eq 'now()'
 307                     )
 308                 ) {
 309                     $default = 'SYSDATE';
 310                 }
 311                 else {
 312                     $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 313                 }
 314
 315                 $field_def .= " DEFAULT $default",
 316             }
 317
 318             #
 319             # Not null constraint
 320             #
 321             unless ( $field->is_nullable ) {
 322                 $field_def .= ' NOT NULL';
 323             }
 324
 325             $field_def .= " $check" if $check;
 326
 327             #
 328             # Auto_increment
 329             #
 330             if ( $field->is_auto_increment ) {
 331                 my $base_name    = $table_name_ur . "_". $field_name;
 332                 my $seq_name     = mk_name( $base_name, 'sq' );
 333                 my $trigger_name = mk_name( $base_name, 'ai' );
 334
 335             push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
 336             push @create, "CREATE SEQUENCE $seq_name;";
 337                 push @trigger_defs,
 338                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 339                     "BEFORE INSERT ON $table_name_ur\n" .
 340                     "FOR EACH ROW WHEN (\n" .
 341                         " new.$field_name_ur IS NULL".
 342                         " OR new.$field_name_ur = 0\n".
 343                     ")\n".
 344                     "BEGIN\n" .
 345                         " SELECT $seq_name.nextval\n" .
 346                         " INTO :new." . $field->name."\n" .
 347                         " FROM dual;\n" .
 348                     "END;\n/";
 349                 ;
 350             }
 351
 352             if ( lc $field->data_type eq 'timestamp' ) {
 353                 my $base_name = $table_name_ur . "_". $field_name_ur;
 354                 my $trig_name = mk_name( $base_name, 'ts' );
 355                 push @trigger_defs,
 356                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 357                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 358                     "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 359                     "BEGIN \n".
 360                     " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 361                     "END;\n/";
 362             }
 363
 364             push @field_defs, $field_def;
 365
 366             if ( my $comment = $field->comments ) {
 367                 $comment =~ s/'/''/g;
 368                 push @field_comments,
 369                     "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
 370                 $comment . "';" unless $options->{no_comments};
 371             }
 372         }
 373
 374         #
 375         # Table options
 376         #
 377         my @table_options;
 378         for my $opt ( $table->options ) {
 379             if ( ref $opt eq 'HASH' ) {
 380                 my ( $key, $value ) = each %$opt;
 381                 if ( ref $value eq 'ARRAY' ) {
 382                     push @table_options, "$key\n(\n".  join ("\n",
 383                         map { "  $_->[0]\t$_->[1]" }
 384                         map { [ each %$_ ] }
 385                         @$value
 386                     )."\n)";
 387                 }
 388                 elsif ( !defined $value ) {
 389                     push @table_options, $key;
 390                 }
 391                 else {
 392                     push @table_options, "$key    $value";
 393                 }
 394             }
 395         }
 396
 397         #
 398         # Table constraints
 399         #
 400         for my $c ( $table->get_constraints ) {
 401             my $name    = $c->name || '';
 402             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 403             my @rfields = map { unreserve( $_, $table_name ) }
 404                 $c->reference_fields;
 405             next if !@fields && $c->type ne CHECK_C;
 406
 407             if ( $c->type eq PRIMARY_KEY ) {
 408                 #$name ||= mk_name( $table_name, 'pk' );
 409                 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
 410                         'PRIMARY KEY (' . join( ', ', @fields ) . ')';
 411             }
 412             elsif ( $c->type eq UNIQUE ) {
 413                 # Don't create UNIQUE constraints identical to the primary key
 414                 if ( my $pk = $table->primary_key ) {
 415                                         my $u_fields = join(":", @fields);
 416                                         my $pk_fields = join(":", $pk->fields);
 417                                         next if $u_fields eq $pk_fields;
 418                 }
 419
 420                 $name ||= mk_name( $name || $table_name, 'u' );
 421
 422                 for my $f ( $c->fields ) {
 423                     my $field_def = $table->get_field( $f ) or next;
 424                     my $dtype     = $translate{ $field_def->data_type } or next;
 425                     if ( $WARN && $dtype =~ /clob/i ) {
 426                         warn "Oracle will not allow UNIQUE constraints on " .
 427                              "CLOB field '" . $field_def->table->name . '.' .
 428                              $field_def->name . ".'\n"
 429                     }
 430                 }
 431
 432                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 433                     '(' . join( ', ', @fields ) . ')';
 434             }
 435             elsif ( $c->type eq CHECK_C ) {
 436                 $name ||= mk_name( $name || $table_name, 'ck' );
 437                 my $expression = $c->expression || '';
 438                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 439             }
 440             elsif ( $c->type eq FOREIGN_KEY ) {
 441             $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
 442                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 443
 444                 if ( @fields ) {
 445                     $def .= '(' . join( ', ', @fields ) . ')';
 446                 }
 447
 448                 my $ref_table = unreserve($c->reference_table);
 449
 450                 $def .= " REFERENCES $ref_table";
 451
 452                 if ( @rfields ) {
 453                     $def .= ' (' . join( ', ', @rfields ) . ')';
 454                 }
 455
 456                 if ( $c->match_type ) {
 457                     $def .= ' MATCH ' .
 458                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 459                 }
 460
 461                 if ( $c->on_delete ) {
 462                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 463                 }
 464
 465             # disabled by plu 2007-12-29 - doesn't exist for oracle
 466             #if ( $c->on_update ) {
 467             #    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 468             #}
 469
 470             push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
 471             }
 472         }
 473
 474         #
 475         # Index Declarations
 476         #
 477         my @index_defs = ();
 478         for my $index ( $table->get_indices ) {
 479             my $index_name = $index->name || '';
 480             my $index_type = $index->type || NORMAL;
 481             my @fields     = map { unreserve( $_, $table_name ) }
 482                              $index->fields;
 483             next unless @fields;
 484
 485             my @index_options;
 486             for my $opt ( $index->options ) {
 487                 if ( ref $opt eq 'HASH' ) {
 488                     my ( $key, $value ) = each %$opt;
 489                     if ( ref $value eq 'ARRAY' ) {
 490                         push @table_options, "$key\n(\n".  join ("\n",
 491                             map { "  $_->[0]\t$_->[1]" }
 492                             map { [ each %$_ ] }
 493                            @$value
 494                         )."\n)";
 495                     }
 496                     elsif ( !defined $value ) {
 497                         push @index_options, $key;
 498                     }
 499                     else {
 500                         push @index_options, "$key    $value";
 501                     }
 502                 }
 503             }
 504             my $index_options = @index_options
 505               ? "\n".join("\n", @index_options) : '';
 506
 507             if ( $index_type eq PRIMARY_KEY ) {
 508                 $index_name = $index_name ? mk_name( $index_name )
 509                     : mk_name( $table_name, 'pk' );
 510                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 511                     '(' . join( ', ', @fields ) . ')';
 512             }
 513             elsif ( $index_type eq NORMAL ) {
 514                 $index_name = $index_name ? mk_name( $index_name )
 515                     : mk_name( $table_name, $index_name || 'i' );
 516                 push @index_defs,
 517                     "CREATE INDEX $index_name on $table_name_ur (".
 518                         join( ', ', @fields ).
 519                     ")$index_options;";
 520             }
 521             elsif ( $index_type eq UNIQUE ) {
 522                 $index_name = $index_name ? mk_name( $index_name )
 523                     : mk_name( $table_name, $index_name || 'i' );
 524                 push @index_defs,
 525                     "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
 526                         join( ', ', @fields ).
 527                     ")$index_options;";
 528             }
 529             else {
 530                 warn "Unknown index type ($index_type) on table $table_name.\n"
 531                     if $WARN;
 532             }
 533         }
 534
 535         if ( my @table_comments = $table->comments ) {
 536             for my $comment ( @table_comments ) {
 537                 next unless $comment;
 538                 $comment =~ s/'/''/g;
 539                 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
 540                 $comment . "';" unless $options->{no_comments}
 541                 ;
 542             }
 543         }
 544
 545         my $table_options = @table_options
 546             ? "\n".join("\n", @table_options) : '';
 547     push @create, "CREATE TABLE $table_name_ur (\n" .
 548             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 549         "\n)$table_options;";
 550
 551     if ( $WARN ) {
 552         if ( %truncated ) {
 553             warn "Truncated " . keys( %truncated ) . " names:\n";
 554             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 555         }
 556
 557         if ( %unreserve ) {
 558             warn "Encounted " . keys( %unreserve ) .
 559                 " unsafe names in schema (reserved or invalid):\n";
 560             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 561         }
 562     }
 563
 564     return \@create, \@fk_defs, \@trigger_defs, \@index_defs;
 565 }
 566
 567 sub create_view {
 568     my ($view) = @_;
 569
 570     my $out = sprintf("CREATE VIEW %s AS\n%s;",
 571                       $view->name,
 572                       $view->sql);
 573
 574     return $out;
 575 }
 576
 577 # -------------------------------------------------------------------
 578 sub mk_name {
 579     my $basename      = shift || '';
 580     my $type          = shift || '';
 581        $type          = '' if $type =~ /^\d/;
 582     my $scope         = shift || '';
 583     my $critical      = shift || '';
 584     my $basename_orig = $basename;
 585     my $max_name      = $type
 586                         ? $max_id_length - (length($type) + 1)
 587                         : $max_id_length;
 588     $basename         = substr( $basename, 0, $max_name )
 589                         if length( $basename ) > $max_name;
 590     my $name          = $type ? "${type}_$basename" : $basename;
 591
 592     if ( $basename ne $basename_orig and $critical ) {
 593         my $show_type = $type ? "+'$type'" : "";
 594         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 595             "character limit to make '$name'\n" if $WARN;
 596         $truncated{ $basename_orig } = $name;
 597     }
 598
 599     $scope ||= \%global_names;
 600     if ( my $prev = $scope->{ $name } ) {
 601         my $name_orig = $name;
 602         substr($name, $max_id_length - 2) = ""
 603             if length( $name ) >= $max_id_length - 1;
 604         $name        .= sprintf( "%02d", $prev++ );
 605
 606         warn "The name '$name_orig' has been changed to ",
 607              "'$name' to make it unique.\n" if $WARN;
 608
 609         $scope->{ $name_orig }++;
 610     }
 611
 612     $scope->{ $name }++;
 613     return $name;
 614 }
 615
 616 # -------------------------------------------------------------------
 617 sub unreserve {
 618     my $name            = shift || '';
 619     my $schema_obj_name = shift || '';
 620
 621     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 622
 623     # also trap fields that don't begin with a letter
 624     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 625
 626     if ( $schema_obj_name ) {
 627         ++$unreserve{"$schema_obj_name.$name"};
 628     }
 629     else {
 630         ++$unreserve{"$name (table name)"};
 631     }
 632
 633     my $unreserve = sprintf '%s_', $name;
 634     return $unreserve.$suffix;
 635 }
 636
 637 1;
 638
 639 # -------------------------------------------------------------------
 640 # All bad art is the result of good intentions.
 641 # Oscar Wilde
 642 # -------------------------------------------------------------------
 643
 644 =pod
 645
 646 =head1 CREDITS
 647
 648 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 649 script.
 650
 651 =head1 AUTHOR
 652
 653 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 654
 655 =head1 SEE ALSO
 656
 657 SQL::Translator, DDL::Oracle, mysql2ora.
 658
 659 =cut