lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.20 2003-08-18 15:41:53 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.20 $ =~ /(\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     longtext   => 'clob',
  53     mediumtext => 'clob',
  54     text       => 'clob',
  55     tinytext   => '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 #
  92 # Oracle reserved words from:
  93 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
  94 # 817_doc/server.817/a85397/ap_keywd.htm
  95 #
  96 my %ora_reserved = map { $_, 1 } qw(
  97     ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
  98     BETWEEN BY
  99     CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
 100     DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
 101     ELSE EXCLUSIVE EXISTS
 102     FILE FLOAT FOR FROM
 103     GRANT GROUP
 104     HAVING
 105     IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
 106     INTEGER INTERSECT INTO IS
 107     LEVEL LIKE LOCK LONG
 108     MAXEXTENTS MINUS MLSLABEL MODE MODIFY
 109     NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
 110     OF OFFLINE ON ONLINE OPTION OR ORDER
 111     PCTFREE PRIOR PRIVILEGES PUBLIC
 112     RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
 113     SELECT SESSION SET SHARE SIZE SMALLINT START
 114     SUCCESSFUL SYNONYM SYSDATE
 115     TABLE THEN TO TRIGGER
 116     UID UNION UNIQUE UPDATE USER
 117     VALIDATE VALUES VARCHAR VARCHAR2 VIEW
 118     WHENEVER WHERE WITH
 119 );
 120
 121 my $max_id_length    = 30;
 122 my %used_identifiers = ();
 123 my %global_names;
 124 my %unreserve;
 125 my %truncated;
 126
 127 # -------------------------------------------------------------------
 128 sub produce {
 129     my $translator     = shift;
 130     $DEBUG             = $translator->debug;
 131     $WARN              = $translator->show_warnings;
 132     my $no_comments    = $translator->no_comments;
 133     my $add_drop_table = $translator->add_drop_table;
 134     my $schema         = $translator->schema;
 135     my $output;
 136
 137     $output .= header_comment unless ($no_comments);
 138
 139     if ( $translator->parser_type =~ /mysql/i ) {
 140         $output .=
 141         "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 142         "-- but we set it here anyway to be self-consistent.\n".
 143         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 144     }
 145
 146     #
 147     # Print create for each table
 148     #
 149     for my $table ( $schema->get_tables ) {
 150         my $table_name    = $table->name or next;
 151         $table_name       = mk_name( $table_name, '', undef, 1 );
 152         my $table_name_ur = unreserve($table_name) or next;
 153
 154         my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
 155
 156         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 157
 158         my ( %field_name_scope, @field_comments );
 159         for my $field ( $table->get_fields ) {
 160             #
 161             # Field name
 162             #
 163             my $field_name    = mk_name(
 164                 $field->name, '', \%field_name_scope, 1
 165             );
 166             my $field_name_ur = unreserve( $field_name, $table_name );
 167             my $field_def     = $field_name_ur;
 168
 169             #
 170             # Datatype
 171             #
 172             my $check;
 173             my $data_type = lc $field->data_type;
 174             my @size      = $field->size;
 175             my %extra     = $field->extra;
 176             my $list      = $extra{'list'} || [];
 177             # \todo deal with embedded quotes
 178             my $commalist = join( ', ', map { qq['$_'] } @$list );
 179
 180             if ( $data_type eq 'enum' ) {
 181                 $check = "CHECK ($field_name_ur IN ($commalist))";
 182                 $data_type = 'varchar2';
 183             }
 184             elsif ( $data_type eq 'set' ) {
 185                 # XXX add a CHECK constraint maybe
 186                 # (trickier and slower, than enum :)
 187                 $data_type = 'varchar2';
 188             }
 189             else {
 190                 $data_type  = defined $translate{ $data_type } ?
 191                               $translate{ $data_type } :
 192                               die "Unknown datatype: $data_type\n";
 193             }
 194
 195             #
 196             # Fixes ORA-02329: column of datatype LOB cannot be
 197             # unique or a primary key
 198             #
 199             if ( $data_type eq 'clob' && $field->is_primary_key ) {
 200                 $data_type = 'varchar2';
 201                 $size[0] = 4000;
 202                 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 203                     if $WARN;
 204             }
 205
 206             # Fixes ORA-00907: missing right parenthesis
 207             if ($data_type eq 'date') {
 208                 undef @size;
 209             }
 210
 211             $field_def .= " $data_type";
 212             if ( defined $size[0] && $size[0] > 0 ) {
 213                 $field_def .= '(' . join( ', ', @size ) . ')';
 214             }
 215
 216             #
 217             # Default value
 218             #
 219             my $default = $field->default_value;
 220             if ( defined $default ) {
 221                 $field_def .= sprintf(
 222                     ' DEFAULT %s',
 223                     $default =~ m/null/i ? 'NULL' : "'$default'"
 224                 );
 225             }
 226
 227             #
 228             # Not null constraint
 229             #
 230             unless ( $field->is_nullable ) {
 231                 my $constraint_name = mk_name($field_name_ur, 'nn');
 232                 $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
 233             }
 234
 235             $field_def .= " $check" if $check;
 236
 237             #
 238             # Auto_increment
 239             #
 240             if ( $field->is_auto_increment ) {
 241                 my $base_name    = $table_name . "_". $field_name;
 242                 my $seq_name     = mk_name( $base_name, 'sq' );
 243                 my $trigger_name = mk_name( $base_name, 'ai' );
 244
 245                 push @trigger_defs,
 246                     "CREATE SEQUENCE $seq_name;\n" .
 247                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 248                     "BEFORE INSERT ON $table_name\n" .
 249                     "FOR EACH ROW WHEN (\n" .
 250                         " new.$field_name_ur IS NULL".
 251                         " OR new.$field_name_ur = 0\n".
 252                     ")\n".
 253                     "BEGIN\n" .
 254                         " SELECT $seq_name.nextval\n" .
 255                         " INTO :new." . $field->name."\n" .
 256                         " FROM dual;\n" .
 257                     "END;\n/";
 258                 ;
 259             }
 260
 261             if ( lc $field->data_type eq 'timestamp' ) {
 262                 my $base_name = $table_name . "_". $field_name_ur;
 263                 my $trig_name = mk_name( $base_name, 'ts' );
 264                 push @trigger_defs,
 265                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 266                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 267                     "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 268                     "BEGIN \n".
 269                     " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 270                     "END;\n/";
 271             }
 272
 273             push @field_defs, $field_def;
 274
 275             if ( my $comment = $field->comments ) {
 276                 push @field_comments,
 277                     "COMMENT ON COLUMN $table_name.$field_name_ur is\n  '".
 278                     $comment."';";
 279             }
 280         }
 281
 282         #
 283         # Table constraints
 284         #
 285         my $constraint_name_default;
 286         for my $c ( $table->get_constraints ) {
 287             my $name    = $c->name || '';
 288             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 289             my @rfields = map { unreserve( $_, $table_name ) }
 290                 $c->reference_fields;
 291             next unless @fields;
 292
 293             if ( $c->type eq PRIMARY_KEY ) {
 294                 $name ||= mk_name( $table_name, 'pk' );
 295                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 296                     '(' . join( ', ', @fields ) . ')';
 297             }
 298             elsif ( $c->type eq UNIQUE ) {
 299                 $name ||= mk_name( $table_name, ++$constraint_name_default );
 300                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 301                     '(' . join( ', ', @fields ) . ')';
 302             }
 303             elsif ( $c->type eq FOREIGN_KEY ) {
 304                 $name ||= mk_name( $table_name, ++$constraint_name_default );
 305                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 306
 307                 if ( @fields ) {
 308                     $def .= join( ', ', @fields );
 309                 }
 310
 311                 $def .= ' REFERENCES ' . $c->reference_table;
 312
 313                 if ( @rfields ) {
 314                     $def .= ' (' . join( ', ', @rfields ) . ')';
 315                 }
 316
 317                 if ( $c->match_type ) {
 318                     $def .= ' MATCH ' .
 319                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 320                 }
 321
 322                 if ( $c->on_delete ) {
 323                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 324                 }
 325
 326                 if ( $c->on_update ) {
 327                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 328                 }
 329
 330                 push @constraint_defs, $def;
 331             }
 332         }
 333
 334         #
 335         # Index Declarations
 336         #
 337         my @index_defs = ();
 338         my $idx_name_default;
 339         for my $index ( $table->get_indices ) {
 340             my $index_name = $index->name || '';
 341             my $index_type = $index->type || NORMAL;
 342             my @fields     = map { unreserve( $_, $table_name ) }
 343                              $index->fields;
 344             next unless @fields;
 345
 346             if ( $index_type eq PRIMARY_KEY ) {
 347                 $index_name = mk_name( $table_name, 'pk' );
 348                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 349                     '(' . join( ', ', @fields ) . ')';
 350             }
 351             elsif ( $index_type eq UNIQUE ) {
 352                 $index_name = mk_name(
 353                     $table_name, $index_name || ++$idx_name_default
 354                 );
 355                 push @field_defs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 356                     '(' . join( ', ', @fields ) . ')';
 357             }
 358
 359             elsif ( $index_type eq NORMAL ) {
 360                 $index_name = mk_name(
 361                     $table_name, $index_name || ++$idx_name_default
 362                 );
 363                 push @index_defs,
 364                     "CREATE INDEX $index_name on $table_name_ur (".
 365                         join( ', ', @fields ).
 366                     ");";
 367             }
 368             else {
 369                 warn "Unknown index type ($index_type) on table $table_name.\n"
 370                     if $WARN;
 371             }
 372         }
 373
 374         my $create_statement;
 375         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 376         $create_statement .=
 377             join( ",\n", map { "-- $_" } $table->comments ) .
 378             "CREATE TABLE $table_name_ur (\n" .
 379             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 380             "\n);"
 381         ;
 382
 383         $output .= join( "\n\n",
 384             @comments,
 385             $create_statement,
 386             @trigger_defs,
 387             @index_defs,
 388             @field_comments,
 389             ''
 390         );
 391     }
 392
 393     if ( $WARN ) {
 394         if ( %truncated ) {
 395             warn "Truncated " . keys( %truncated ) . " names:\n";
 396             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 397         }
 398
 399         if ( %unreserve ) {
 400             warn "Encounted " . keys( %unreserve ) .
 401                 " unsafe names in schema (reserved or invalid):\n";
 402             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 403         }
 404     }
 405
 406     return $output;
 407 }
 408
 409 # -------------------------------------------------------------------
 410 sub mk_name {
 411     my $basename      = shift || '';
 412     my $type          = shift || '';
 413     my $scope         = shift || '';
 414     my $critical      = shift || '';
 415     my $basename_orig = $basename;
 416     my $max_name      = $type
 417                         ? $max_id_length - (length($type) + 1)
 418                         : $max_id_length;
 419     $basename         = substr( $basename, 0, $max_name )
 420                         if length( $basename ) > $max_name;
 421     my $name          = $type ? "${type}_$basename" : $basename;
 422
 423     if ( $basename ne $basename_orig and $critical ) {
 424         my $show_type = $type ? "+'$type'" : "";
 425         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 426             "character limit to make '$name'\n" if $WARN;
 427         $truncated{ $basename_orig } = $name;
 428     }
 429
 430     $scope ||= \%global_names;
 431     if ( my $prev = $scope->{ $name } ) {
 432         my $name_orig = $name;
 433         $name        .= sprintf( "%02d", ++$prev );
 434         substr($name, $max_id_length - 3) = "00"
 435             if length( $name ) > $max_id_length;
 436
 437         warn "The name '$name_orig' has been changed to ",
 438              "'$name' to make it unique.\n" if $WARN;
 439
 440         $scope->{ $name_orig }++;
 441     }
 442
 443     $scope->{ $name }++;
 444     return $name;
 445 }
 446
 447 # -------------------------------------------------------------------
 448 sub unreserve {
 449     my $name            = shift || '';
 450     my $schema_obj_name = shift || '';
 451
 452     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 453
 454     # also trap fields that don't begin with a letter
 455     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 456
 457     if ( $schema_obj_name ) {
 458         ++$unreserve{"$schema_obj_name.$name"};
 459     }
 460     else {
 461         ++$unreserve{"$name (table name)"};
 462     }
 463
 464     my $unreserve = sprintf '%s_', $name;
 465     return $unreserve.$suffix;
 466 }
 467
 468 1;
 469
 470 # -------------------------------------------------------------------
 471 # All bad art is the result of good intentions.
 472 # Oscar Wilde
 473 # -------------------------------------------------------------------
 474
 475 =head1 NAME
 476
 477 SQL::Translator::Producer::Oracle - Oracle SQL producer
 478
 479 =head1 SYNOPSIS
 480
 481   use SQL::Translator::Parser::MySQL;
 482   use SQL::Translator::Producer::Oracle;
 483
 484   my $original_create = ""; # get this from somewhere...
 485   my $translator = SQL::Translator->new;
 486
 487   $translator->parser("SQL::Translator::Parser::MySQL");
 488   $translator->producer("SQL::Translator::Producer::Oracle");
 489
 490   my $new_create = $translator->translate($original_create);
 491
 492 =head1 DESCRIPTION
 493
 494 SQL::Translator::Producer::Oracle takes a parsed data structure,
 495 created by a SQL::Translator::Parser subclass, and turns it into a
 496 create string suitable for use with an Oracle database.
 497
 498 =head1 CREDITS
 499
 500 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
 501 his "mysql2ora" script.
 502
 503 =head1 AUTHOR
 504
 505 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 506
 507 =head1 SEE ALSO
 508
 509 perl(1).
 510
 511 =cut