lib/SQL/Translator/Producer/Oracle.pm

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