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             if ( $index_type eq PRIMARY_KEY ) {
 486                 $index_name = $index_name ? mk_name( $index_name )
 487                     : mk_name( $table_name, 'pk' );
 488                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 489                     '(' . join( ', ', @fields ) . ')';
 490             }
 491             elsif ( $index_type eq NORMAL ) {
 492                 $index_name = $index_name ? mk_name( $index_name )
 493                     : mk_name( $table_name, $index_name || 'i' );
 494                 push @index_defs,
 495                     "CREATE INDEX $index_name on $table_name_ur (".
 496                         join( ', ', @fields ).
 497                     ");";
 498             }
 499             elsif ( $index_type eq UNIQUE ) {
 500                 $index_name = $index_name ? mk_name( $index_name )
 501                     : mk_name( $table_name, $index_name || 'i' );
 502                 push @index_defs,
 503                     "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
 504                         join( ', ', @fields ).
 505                     ");";
 506             }
 507             else {
 508                 warn "Unknown index type ($index_type) on table $table_name.\n"
 509                     if $WARN;
 510             }
 511         }
 512
 513         if ( my @table_comments = $table->comments ) {
 514             for my $comment ( @table_comments ) {
 515                 next unless $comment;
 516                 $comment =~ s/'/''/g;
 517                 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
 518                 $comment . "';" unless $options->{no_comments}
 519                 ;
 520             }
 521         }
 522
 523         my $table_options = @table_options
 524             ? "\n".join("\n", @table_options) : '';
 525     push @create, "CREATE TABLE $table_name_ur (\n" .
 526             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 527         "\n)$table_options;";
 528
 529     if ( $WARN ) {
 530         if ( %truncated ) {
 531             warn "Truncated " . keys( %truncated ) . " names:\n";
 532             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 533         }
 534
 535         if ( %unreserve ) {
 536             warn "Encounted " . keys( %unreserve ) .
 537                 " unsafe names in schema (reserved or invalid):\n";
 538             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 539         }
 540     }
 541
 542     return \@create, \@fk_defs, \@trigger_defs, \@index_defs;
 543 }
 544
 545 sub create_view {
 546     my ($view) = @_;
 547
 548     my $out = sprintf("CREATE VIEW %s AS\n%s;",
 549                       $view->name,
 550                       $view->sql);
 551
 552     return $out;
 553 }
 554
 555 # -------------------------------------------------------------------
 556 sub mk_name {
 557     my $basename      = shift || '';
 558     my $type          = shift || '';
 559        $type          = '' if $type =~ /^\d/;
 560     my $scope         = shift || '';
 561     my $critical      = shift || '';
 562     my $basename_orig = $basename;
 563     my $max_name      = $type
 564                         ? $max_id_length - (length($type) + 1)
 565                         : $max_id_length;
 566     $basename         = substr( $basename, 0, $max_name )
 567                         if length( $basename ) > $max_name;
 568     my $name          = $type ? "${type}_$basename" : $basename;
 569
 570     if ( $basename ne $basename_orig and $critical ) {
 571         my $show_type = $type ? "+'$type'" : "";
 572         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 573             "character limit to make '$name'\n" if $WARN;
 574         $truncated{ $basename_orig } = $name;
 575     }
 576
 577     $scope ||= \%global_names;
 578     if ( my $prev = $scope->{ $name } ) {
 579         my $name_orig = $name;
 580         substr($name, $max_id_length - 2) = ""
 581             if length( $name ) >= $max_id_length - 1;
 582         $name        .= sprintf( "%02d", $prev++ );
 583
 584         warn "The name '$name_orig' has been changed to ",
 585              "'$name' to make it unique.\n" if $WARN;
 586
 587         $scope->{ $name_orig }++;
 588     }
 589
 590     $scope->{ $name }++;
 591     return $name;
 592 }
 593
 594 # -------------------------------------------------------------------
 595 sub unreserve {
 596     my $name            = shift || '';
 597     my $schema_obj_name = shift || '';
 598
 599     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 600
 601     # also trap fields that don't begin with a letter
 602     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 603
 604     if ( $schema_obj_name ) {
 605         ++$unreserve{"$schema_obj_name.$name"};
 606     }
 607     else {
 608         ++$unreserve{"$name (table name)"};
 609     }
 610
 611     my $unreserve = sprintf '%s_', $name;
 612     return $unreserve.$suffix;
 613 }
 614
 615 1;
 616
 617 # -------------------------------------------------------------------
 618 # All bad art is the result of good intentions.
 619 # Oscar Wilde
 620 # -------------------------------------------------------------------
 621
 622 =pod
 623
 624 =head1 CREDITS
 625
 626 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 627 script.
 628
 629 =head1 AUTHOR
 630
 631 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 632
 633 =head1 SEE ALSO
 634
 635 SQL::Translator, DDL::Oracle, mysql2ora.
 636
 637 =cut