lib/SQL/Translator/Producer/Oracle.pm

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