lib/SQL/Translator/Producer/Oracle.pm

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