lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.19 2003-08-17 07:51:33 rossta 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.19 $ =~ /(\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 "', '", @$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             # Fixes ORA-02329: column of datatype LOB cannot be unique or a primary key
 196             if ( $data_type eq 'clob' && $field->is_primary_key ) {
 197                 $data_type = 'varchar2';
 198                 $size[0] = 4000;
 199             }
 200
 201             # Fixes ORA-00907: missing right parenthesis
 202             if ($data_type eq 'date') {
 203                 undef @size;
 204             }
 205
 206             $field_def .= " $data_type";
 207             if ( defined $size[0] && $size[0] > 0 ) {
 208                 $field_def .= '(' . join( ', ', @size ) . ')';
 209             }
 210
 211             #
 212             # Default value
 213             #
 214             my $default = $field->default_value;
 215             if ( defined $default ) {
 216                 $field_def .= sprintf(
 217                     ' DEFAULT %s',
 218                     $default =~ m/null/i ? 'NULL' : "'$default'"
 219                 );
 220             }
 221
 222             #
 223             # Not null constraint
 224             #
 225             unless ( $field->is_nullable ) {
 226                 my $constraint_name = mk_name($field_name_ur, 'nn');
 227                 $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
 228             }
 229
 230             $field_def .= " $check" if $check;
 231
 232             #
 233             # Auto_increment
 234             #
 235             if ( $field->is_auto_increment ) {
 236                 my $base_name    = $table_name . "_". $field_name;
 237                 my $seq_name     = mk_name( $base_name, 'sq' );
 238                 my $trigger_name = mk_name( $base_name, 'ai' );
 239
 240                 push @trigger_defs,
 241                     "CREATE SEQUENCE $seq_name;\n" .
 242                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 243                     "BEFORE INSERT ON $table_name\n" .
 244                     "FOR EACH ROW WHEN (\n" .
 245                         " new.$field_name_ur IS NULL".
 246                         " OR new.$field_name_ur = 0\n".
 247                     ")\n".
 248                     "BEGIN\n" .
 249                         " SELECT $seq_name.nextval\n" .
 250                         " INTO :new." . $field->name."\n" .
 251                         " FROM dual;\n" .
 252                     "END;\n/";
 253                 ;
 254             }
 255
 256             if ( lc $field->data_type eq 'timestamp' ) {
 257                 my $base_name = $table_name . "_". $field_name_ur;
 258                 my $trig_name = mk_name( $base_name, 'ts' );
 259                 push @trigger_defs,
 260                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 261                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 262                     "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 263                     "BEGIN \n".
 264                     " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 265                     "END;\n/";
 266             }
 267
 268             push @field_defs, $field_def;
 269
 270             if ( my $comment = $field->comments ) {
 271                 push @field_comments,
 272                     "COMMENT ON COLUMN $table_name.$field_name_ur is\n  '".
 273                     $comment."';";
 274             }
 275         }
 276
 277         #
 278         # Table constraints
 279         #
 280         my $constraint_name_default;
 281         for my $c ( $table->get_constraints ) {
 282             my $name    = $c->name || '';
 283             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 284             my @rfields = map { unreserve( $_, $table_name ) }
 285                 $c->reference_fields;
 286             next unless @fields;
 287
 288             if ( $c->type eq PRIMARY_KEY ) {
 289                 $name ||= mk_name( $table_name, 'pk' );
 290                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 291                     '(' . join( ', ', @fields ) . ')';
 292             }
 293             elsif ( $c->type eq UNIQUE ) {
 294                 $name ||= mk_name( $table_name, ++$constraint_name_default );
 295                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 296                     '(' . join( ', ', @fields ) . ')';
 297             }
 298             elsif ( $c->type eq FOREIGN_KEY ) {
 299                 $name ||= mk_name( $table_name, ++$constraint_name_default );
 300                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 301
 302                 if ( @fields ) {
 303                     $def .= join( ', ', @fields );
 304                 }
 305
 306                 $def .= ' REFERENCES ' . $c->reference_table;
 307
 308                 if ( @rfields ) {
 309                     $def .= ' (' . join( ', ', @rfields ) . ')';
 310                 }
 311
 312                 if ( $c->match_type ) {
 313                     $def .= ' MATCH ' .
 314                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 315                 }
 316
 317                 if ( $c->on_delete ) {
 318                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 319                 }
 320
 321                 if ( $c->on_update ) {
 322                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 323                 }
 324
 325                 push @constraint_defs, $def;
 326             }
 327         }
 328
 329         #
 330         # Index Declarations
 331         #
 332         my @index_defs = ();
 333         my $idx_name_default;
 334         for my $index ( $table->get_indices ) {
 335             my $index_name = $index->name || '';
 336             my $index_type = $index->type || NORMAL;
 337             my @fields     = map { unreserve( $_, $table_name ) }
 338                              $index->fields;
 339             next unless @fields;
 340
 341             if ( $index_type eq PRIMARY_KEY ) {
 342                 $index_name = mk_name( $table_name, 'pk' );
 343                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 344                     '(' . join( ', ', @fields ) . ')';
 345             }
 346             elsif ( $index_type eq UNIQUE ) {
 347                 $index_name = mk_name(
 348                     $table_name, $index_name || ++$idx_name_default
 349                 );
 350                 push @field_defs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 351                     '(' . join( ', ', @fields ) . ')';
 352             }
 353
 354             elsif ( $index_type eq NORMAL ) {
 355                 $index_name = mk_name(
 356                     $table_name, $index_name || ++$idx_name_default
 357                 );
 358                 push @index_defs,
 359                     "CREATE INDEX $index_name on $table_name_ur (".
 360                         join( ', ', @fields ).
 361                     ");";
 362             }
 363             else {
 364                 warn "Unknown index type ($index_type) on table $table_name.\n"
 365                     if $WARN;
 366             }
 367         }
 368
 369         my $create_statement;
 370         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 371         $create_statement .=
 372             join( ",\n", map { "-- $_" } $table->comments ) .
 373             "CREATE TABLE $table_name_ur (\n" .
 374             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 375             "\n);"
 376         ;
 377
 378         $output .= join( "\n\n",
 379             @comments,
 380             $create_statement,
 381             @trigger_defs,
 382             @index_defs,
 383             @field_comments,
 384             ''
 385         );
 386     }
 387
 388     if ( $WARN ) {
 389         if ( %truncated ) {
 390             warn "Truncated " . keys( %truncated ) . " names:\n";
 391             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 392         }
 393
 394         if ( %unreserve ) {
 395             warn "Encounted " . keys( %unreserve ) .
 396                 " unsafe names in schema (reserved or invalid):\n";
 397             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 398         }
 399     }
 400
 401     return $output;
 402 }
 403
 404 # -------------------------------------------------------------------
 405 sub mk_name {
 406     my $basename      = shift || '';
 407     my $type          = shift || '';
 408     my $scope         = shift || '';
 409     my $critical      = shift || '';
 410     my $basename_orig = $basename;
 411     my $max_name      = $type
 412                         ? $max_id_length - (length($type) + 1)
 413                         : $max_id_length;
 414     $basename         = substr( $basename, 0, $max_name )
 415                         if length( $basename ) > $max_name;
 416     my $name          = $type ? "${type}_$basename" : $basename;
 417
 418     if ( $basename ne $basename_orig and $critical ) {
 419         my $show_type = $type ? "+'$type'" : "";
 420         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 421             "character limit to make '$name'\n" if $WARN;
 422         $truncated{ $basename_orig } = $name;
 423     }
 424
 425     $scope ||= \%global_names;
 426     if ( my $prev = $scope->{ $name } ) {
 427         my $name_orig = $name;
 428         $name        .= sprintf( "%02d", ++$prev );
 429         substr($name, $max_id_length - 3) = "00"
 430             if length( $name ) > $max_id_length;
 431
 432         warn "The name '$name_orig' has been changed to ",
 433              "'$name' to make it unique.\n" if $WARN;
 434
 435         $scope->{ $name_orig }++;
 436     }
 437
 438     $scope->{ $name }++;
 439     return $name;
 440 }
 441
 442 # -------------------------------------------------------------------
 443 sub unreserve {
 444     my $name            = shift || '';
 445     my $schema_obj_name = shift || '';
 446
 447     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 448
 449     # also trap fields that don't begin with a letter
 450     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 451
 452     if ( $schema_obj_name ) {
 453         ++$unreserve{"$schema_obj_name.$name"};
 454     }
 455     else {
 456         ++$unreserve{"$name (table name)"};
 457     }
 458
 459     my $unreserve = sprintf '%s_', $name;
 460     return $unreserve.$suffix;
 461 }
 462
 463 1;
 464
 465 # -------------------------------------------------------------------
 466 # All bad art is the result of good intentions.
 467 # Oscar Wilde
 468 # -------------------------------------------------------------------
 469
 470 =head1 NAME
 471
 472 SQL::Translator::Producer::Oracle - Oracle SQL producer
 473
 474 =head1 SYNOPSIS
 475
 476   use SQL::Translator::Parser::MySQL;
 477   use SQL::Translator::Producer::Oracle;
 478
 479   my $original_create = ""; # get this from somewhere...
 480   my $translator = SQL::Translator->new;
 481
 482   $translator->parser("SQL::Translator::Parser::MySQL");
 483   $translator->producer("SQL::Translator::Producer::Oracle");
 484
 485   my $new_create = $translator->translate($original_create);
 486
 487 =head1 DESCRIPTION
 488
 489 SQL::Translator::Producer::Oracle takes a parsed data structure,
 490 created by a SQL::Translator::Parser subclass, and turns it into a
 491 create string suitable for use with an Oracle database.
 492
 493 =head1 CREDITS
 494
 495 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
 496 his "mysql2ora" script.
 497
 498 =head1 AUTHOR
 499
 500 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 501
 502 =head1 SEE ALSO
 503
 504 perl(1).
 505
 506 =cut