lib/SQL/Translator/Producer/Oracle.pm

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