lib/SQL/Translator/Producer/Oracle.pm

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