lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.24 2003-08-27 02:28:21 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.24 $ =~ /(\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             }
 272
 273             $field_def .= " $check" if $check;
 274
 275             #
 276             # Auto_increment
 277             #
 278             if ( $field->is_auto_increment ) {
 279                 my $base_name    = $table_name . "_". $field_name;
 280                 my $seq_name     = mk_name( $base_name, 'sq' );
 281                 my $trigger_name = mk_name( $base_name, 'ai' );
 282
 283                 push @trigger_defs,
 284                     "CREATE SEQUENCE $seq_name;\n" .
 285                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 286                     "BEFORE INSERT ON $table_name\n" .
 287                     "FOR EACH ROW WHEN (\n" .
 288                         " new.$field_name_ur IS NULL".
 289                         " OR new.$field_name_ur = 0\n".
 290                     ")\n".
 291                     "BEGIN\n" .
 292                         " SELECT $seq_name.nextval\n" .
 293                         " INTO :new." . $field->name."\n" .
 294                         " FROM dual;\n" .
 295                     "END;\n/";
 296                 ;
 297             }
 298
 299             if ( lc $field->data_type eq 'timestamp' ) {
 300                 my $base_name = $table_name . "_". $field_name_ur;
 301                 my $trig_name = mk_name( $base_name, 'ts' );
 302                 push @trigger_defs,
 303                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 304                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 305                     "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 306                     "BEGIN \n".
 307                     " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 308                     "END;\n/";
 309             }
 310
 311             push @field_defs, $field_def;
 312
 313             if ( my $comment = $field->comments ) {
 314                 push @field_comments,
 315                     "COMMENT ON COLUMN $table_name.$field_name_ur is\n  '".
 316                     $comment."';";
 317             }
 318         }
 319
 320         #
 321         # Table constraints
 322         #
 323         for my $c ( $table->get_constraints ) {
 324             my $name    = $c->name || '';
 325             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 326             my @rfields = map { unreserve( $_, $table_name ) }
 327                 $c->reference_fields;
 328             next if !@fields && $c->type ne CHECK_C;
 329
 330             if ( $c->type eq PRIMARY_KEY ) {
 331                 $name ||= mk_name( $table_name, 'pk' );
 332                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 333                     '(' . join( ', ', @fields ) . ')';
 334             }
 335             elsif ( $c->type eq UNIQUE ) {
 336                 $name ||= mk_name( $table_name, 'u' );
 337                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 338                     '(' . join( ', ', @fields ) . ')';
 339             }
 340             elsif ( $c->type eq CHECK_C ) {
 341                 $name ||= mk_name( $table_name, 'ck' );
 342                 my $expression = $c->expression || '';
 343                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 344             }
 345             elsif ( $c->type eq FOREIGN_KEY ) {
 346                 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
 347                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 348
 349                 if ( @fields ) {
 350                     $def .= '(' . join( ', ', @fields ) . ')';
 351                 }
 352
 353                 my $ref_table = unreserve($c->reference_table);
 354
 355                 $def .= " REFERENCES $ref_table";
 356
 357                 if ( @rfields ) {
 358                     $def .= ' (' . join( ', ', @rfields ) . ')';
 359                 }
 360
 361                 if ( $c->match_type ) {
 362                     $def .= ' MATCH ' .
 363                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 364                 }
 365
 366                 if ( $c->on_delete ) {
 367                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 368                 }
 369
 370                 if ( $c->on_update ) {
 371                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 372                 }
 373
 374                 push @constraint_defs, $def;
 375             }
 376         }
 377
 378         #
 379         # Index Declarations
 380         #
 381         my @index_defs = ();
 382         for my $index ( $table->get_indices ) {
 383             my $index_name = $index->name || '';
 384             my $index_type = $index->type || NORMAL;
 385             my @fields     = map { unreserve( $_, $table_name ) }
 386                              $index->fields;
 387             next unless @fields;
 388
 389             if ( $index_type eq PRIMARY_KEY ) {
 390                 $index_name ||= mk_name( $table_name, 'pk' );
 391                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 392                     '(' . join( ', ', @fields ) . ')';
 393             }
 394             elsif ( $index_type eq NORMAL ) {
 395                 $index_name ||= mk_name( $table_name, $index_name || 'i' );
 396                 push @index_defs,
 397                     "CREATE INDEX $index_name on $table_name_ur (".
 398                         join( ', ', @fields ).
 399                     ");";
 400             }
 401             else {
 402                 warn "Unknown index type ($index_type) on table $table_name.\n"
 403                     if $WARN;
 404             }
 405         }
 406
 407         my $create_statement;
 408         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 409
 410         if ( my @table_comments = $table->comments ) {
 411             for my $comment ( @table_comments ) {
 412                 next unless $comment;
 413                 push @field_comments, "COMMENT ON TABLE $table_name is\n  '".
 414                     $comment."';"
 415                 ;
 416             }
 417         }
 418
 419         $create_statement .= "CREATE TABLE $table_name_ur (\n" .
 420             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 421             "\n);"
 422         ;
 423
 424         $output .= join( "\n\n",
 425             @comments,
 426             $create_statement,
 427             @trigger_defs,
 428             @index_defs,
 429             @field_comments,
 430             ''
 431         );
 432     }
 433
 434     if ( $WARN ) {
 435         if ( %truncated ) {
 436             warn "Truncated " . keys( %truncated ) . " names:\n";
 437             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 438         }
 439
 440         if ( %unreserve ) {
 441             warn "Encounted " . keys( %unreserve ) .
 442                 " unsafe names in schema (reserved or invalid):\n";
 443             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 444         }
 445     }
 446
 447     return $output;
 448 }
 449
 450 # -------------------------------------------------------------------
 451 sub mk_name {
 452     my $basename      = shift || '';
 453     my $type          = shift || '';
 454        $type          = '' if $type =~ /^\d/;
 455     my $scope         = shift || '';
 456     my $critical      = shift || '';
 457     my $basename_orig = $basename;
 458     my $max_name      = $type
 459                         ? $max_id_length - (length($type) + 1)
 460                         : $max_id_length;
 461     $basename         = substr( $basename, 0, $max_name )
 462                         if length( $basename ) > $max_name;
 463     my $name          = $type ? "${type}_$basename" : $basename;
 464
 465     if ( $basename ne $basename_orig and $critical ) {
 466         my $show_type = $type ? "+'$type'" : "";
 467         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 468             "character limit to make '$name'\n" if $WARN;
 469         $truncated{ $basename_orig } = $name;
 470     }
 471
 472     $scope ||= \%global_names;
 473     if ( my $prev = $scope->{ $name } ) {
 474         my $name_orig = $name;
 475         $name        .= sprintf( "%02d", ++$prev );
 476         substr($name, $max_id_length - 3) = "00"
 477             if length( $name ) > $max_id_length;
 478
 479         warn "The name '$name_orig' has been changed to ",
 480              "'$name' to make it unique.\n" if $WARN;
 481
 482         $scope->{ $name_orig }++;
 483     }
 484
 485     $scope->{ $name }++;
 486     return $name;
 487 }
 488
 489 # -------------------------------------------------------------------
 490 sub unreserve {
 491     my $name            = shift || '';
 492     my $schema_obj_name = shift || '';
 493
 494     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 495
 496     # also trap fields that don't begin with a letter
 497     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 498
 499     if ( $schema_obj_name ) {
 500         ++$unreserve{"$schema_obj_name.$name"};
 501     }
 502     else {
 503         ++$unreserve{"$name (table name)"};
 504     }
 505
 506     my $unreserve = sprintf '%s_', $name;
 507     return $unreserve.$suffix;
 508 }
 509
 510 1;
 511
 512 # -------------------------------------------------------------------
 513 # All bad art is the result of good intentions.
 514 # Oscar Wilde
 515 # -------------------------------------------------------------------
 516
 517 =head1 NAME
 518
 519 SQL::Translator::Producer::Oracle - Oracle SQL producer
 520
 521 =head1 SYNOPSIS
 522
 523   use SQL::Translator::Parser::MySQL;
 524   use SQL::Translator::Producer::Oracle;
 525
 526   my $original_create = ""; # get this from somewhere...
 527   my $translator = SQL::Translator->new;
 528
 529   $translator->parser("SQL::Translator::Parser::MySQL");
 530   $translator->producer("SQL::Translator::Producer::Oracle");
 531
 532   my $new_create = $translator->translate($original_create);
 533
 534 =head1 DESCRIPTION
 535
 536 SQL::Translator::Producer::Oracle takes a parsed data structure,
 537 created by a SQL::Translator::Parser subclass, and turns it into a
 538 create string suitable for use with an Oracle database.
 539
 540 =head1 CREDITS
 541
 542 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
 543 his "mysql2ora" script.
 544
 545 =head1 AUTHOR
 546
 547 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 548
 549 =head1 SEE ALSO
 550
 551 perl(1).
 552
 553 =cut