lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.22 2003-08-20 22:53:26 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.22 $ =~ /(\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 unless @fields;
 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 FOREIGN_KEY ) {
 330                 $name ||= mk_name( $table_name, 'fk' );
 331                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 332
 333                 if ( @fields ) {
 334                     $def .= '(' . join( ', ', @fields ) . ')';
 335                 }
 336
 337                 my $ref_table = unreserve($c->reference_table);
 338
 339                 $def .= " REFERENCES $ref_table";
 340
 341                 if ( @rfields ) {
 342                     $def .= ' (' . join( ', ', @rfields ) . ')';
 343                 }
 344
 345                 if ( $c->match_type ) {
 346                     $def .= ' MATCH ' .
 347                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 348                 }
 349
 350                 if ( $c->on_delete ) {
 351                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 352                 }
 353
 354                 if ( $c->on_update ) {
 355                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 356                 }
 357
 358                 push @constraint_defs, $def;
 359             }
 360         }
 361
 362         #
 363         # Index Declarations
 364         #
 365         my @index_defs = ();
 366         for my $index ( $table->get_indices ) {
 367             my $index_name = $index->name || '';
 368             my $index_type = $index->type || NORMAL;
 369             my @fields     = map { unreserve( $_, $table_name ) }
 370                              $index->fields;
 371             next unless @fields;
 372
 373             if ( $index_type eq PRIMARY_KEY ) {
 374                 $index_name = mk_name( $table_name, 'pk' );
 375                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 376                     '(' . join( ', ', @fields ) . ')';
 377             }
 378             elsif ( $index_type eq NORMAL ) {
 379                 $index_name = mk_name( $table_name, $index_name || 'i' );
 380                 push @index_defs,
 381                     "CREATE INDEX $index_name on $table_name_ur (".
 382                         join( ', ', @fields ).
 383                     ");";
 384             }
 385             else {
 386                 warn "Unknown index type ($index_type) on table $table_name.\n"
 387                     if $WARN;
 388             }
 389         }
 390
 391         my $create_statement;
 392         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 393
 394         if ( my @table_comments = $table->comments ) {
 395             for my $comment ( @table_comments ) {
 396                 next unless $comment;
 397                 push @field_comments, "COMMENT ON TABLE $table_name is\n  '".
 398                     $comment."';"
 399                 ;
 400             }
 401         }
 402
 403         $create_statement .= "CREATE TABLE $table_name_ur (\n" .
 404             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 405             "\n);"
 406         ;
 407
 408         $output .= join( "\n\n",
 409             @comments,
 410             $create_statement,
 411             @trigger_defs,
 412             @index_defs,
 413             @field_comments,
 414             ''
 415         );
 416     }
 417
 418     if ( $WARN ) {
 419         if ( %truncated ) {
 420             warn "Truncated " . keys( %truncated ) . " names:\n";
 421             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 422         }
 423
 424         if ( %unreserve ) {
 425             warn "Encounted " . keys( %unreserve ) .
 426                 " unsafe names in schema (reserved or invalid):\n";
 427             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 428         }
 429     }
 430
 431     return $output;
 432 }
 433
 434 # -------------------------------------------------------------------
 435 sub mk_name {
 436     my $basename      = shift || '';
 437     my $type          = shift || '';
 438        $type          = '' if $type =~ /^\d/;
 439     my $scope         = shift || '';
 440     my $critical      = shift || '';
 441     my $basename_orig = $basename;
 442     my $max_name      = $type
 443                         ? $max_id_length - (length($type) + 1)
 444                         : $max_id_length;
 445     $basename         = substr( $basename, 0, $max_name )
 446                         if length( $basename ) > $max_name;
 447     my $name          = $type ? "${type}_$basename" : $basename;
 448
 449     if ( $basename ne $basename_orig and $critical ) {
 450         my $show_type = $type ? "+'$type'" : "";
 451         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 452             "character limit to make '$name'\n" if $WARN;
 453         $truncated{ $basename_orig } = $name;
 454     }
 455
 456     $scope ||= \%global_names;
 457     if ( my $prev = $scope->{ $name } ) {
 458         my $name_orig = $name;
 459         $name        .= sprintf( "%02d", ++$prev );
 460         substr($name, $max_id_length - 3) = "00"
 461             if length( $name ) > $max_id_length;
 462
 463         warn "The name '$name_orig' has been changed to ",
 464              "'$name' to make it unique.\n" if $WARN;
 465
 466         $scope->{ $name_orig }++;
 467     }
 468
 469     $scope->{ $name }++;
 470     return $name;
 471 }
 472
 473 # -------------------------------------------------------------------
 474 sub unreserve {
 475     my $name            = shift || '';
 476     my $schema_obj_name = shift || '';
 477
 478     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 479
 480     # also trap fields that don't begin with a letter
 481     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 482
 483     if ( $schema_obj_name ) {
 484         ++$unreserve{"$schema_obj_name.$name"};
 485     }
 486     else {
 487         ++$unreserve{"$name (table name)"};
 488     }
 489
 490     my $unreserve = sprintf '%s_', $name;
 491     return $unreserve.$suffix;
 492 }
 493
 494 1;
 495
 496 # -------------------------------------------------------------------
 497 # All bad art is the result of good intentions.
 498 # Oscar Wilde
 499 # -------------------------------------------------------------------
 500
 501 =head1 NAME
 502
 503 SQL::Translator::Producer::Oracle - Oracle SQL producer
 504
 505 =head1 SYNOPSIS
 506
 507   use SQL::Translator::Parser::MySQL;
 508   use SQL::Translator::Producer::Oracle;
 509
 510   my $original_create = ""; # get this from somewhere...
 511   my $translator = SQL::Translator->new;
 512
 513   $translator->parser("SQL::Translator::Parser::MySQL");
 514   $translator->producer("SQL::Translator::Producer::Oracle");
 515
 516   my $new_create = $translator->translate($original_create);
 517
 518 =head1 DESCRIPTION
 519
 520 SQL::Translator::Producer::Oracle takes a parsed data structure,
 521 created by a SQL::Translator::Parser subclass, and turns it into a
 522 create string suitable for use with an Oracle database.
 523
 524 =head1 CREDITS
 525
 526 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
 527 his "mysql2ora" script.
 528
 529 =head1 AUTHOR
 530
 531 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 532
 533 =head1 SEE ALSO
 534
 535 perl(1).
 536
 537 =cut