lib/SQL/Translator/Producer/Oracle.pm

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