lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.12 2003-06-09 02:19:41 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.12 $ =~ /(\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, $data ) = @_;
 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;
 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
 258         #
 259         # Table constraints
 260         #
 261         my $constraint_name_default;
 262         for my $c ( $table->get_constraints ) {
 263             my $name    = $c->name || '';
 264             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 265             my @rfields = map { unreserve( $_, $table_name ) }
 266                 $c->reference_fields;
 267             next unless @fields;
 268
 269             if ( $c->type eq PRIMARY_KEY ) {
 270                 $name ||= mk_name( $table_name, 'pk' );
 271                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 272                     '(' . join( ', ', @fields ) . ')';
 273             }
 274             elsif ( $c->type eq UNIQUE ) {
 275                 $name ||= mk_name( $table_name, ++$constraint_name_default );
 276                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 277                     '(' . join( ', ', @fields ) . ')';
 278             }
 279             elsif ( $c->type eq FOREIGN_KEY ) {
 280                 $name ||= mk_name( $table_name, ++$constraint_name_default );
 281                 my $def = "CONSTRAINT $name FOREIGN KEY REFERENCES ".
 282                     $c->reference_table;
 283
 284                 if ( @rfields ) {
 285                     $def .= ' (' . join( ', ', @rfields ) . ')';
 286                 }
 287
 288                 if ( $c->match_type ) {
 289                     $def .= ' MATCH ' .
 290                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 291                 }
 292
 293                 if ( $c->on_delete ) {
 294                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 295                 }
 296
 297                 if ( $c->on_update ) {
 298                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 299                 }
 300
 301                 push @constraint_defs, $def;
 302             }
 303         }
 304
 305         #
 306         # Index Declarations
 307         #
 308         my @index_defs = ();
 309         my $idx_name_default;
 310         for my $index ( $table->get_indices ) {
 311             my $index_name = $index->name || '';
 312             my $index_type = $index->type || NORMAL;
 313             my @fields     = map { unreserve( $_, $table_name ) }
 314                              $index->fields;
 315             next unless @fields;
 316
 317             if ( $index_type eq PRIMARY_KEY ) {
 318                 $index_name = mk_name( $table_name, 'pk' );
 319                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 320                     '(' . join( ', ', @fields ) . ')';
 321             }
 322             elsif ( $index_type eq UNIQUE ) {
 323                 $index_name = mk_name(
 324                     $table_name, $index_name || ++$idx_name_default
 325                 );
 326                 push @field_defs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 327                     '(' . join( ', ', @fields ) . ')';
 328             }
 329
 330             elsif ( $index_type eq NORMAL ) {
 331                 $index_name = mk_name(
 332                     $table_name, $index_name || ++$idx_name_default
 333                 );
 334                 push @index_defs,
 335                     "CREATE INDEX $index_name on $table_name_ur (".
 336                         join( ', ', @fields ).
 337                     ");";
 338             }
 339             else {
 340                 warn "Unknown index type ($index_type) on table $table_name.\n"
 341                     if $WARN;
 342             }
 343         }
 344
 345         my $create_statement;
 346         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 347         $create_statement .=
 348             join( ",\n", map { "-- $_" } $table->comments ) .
 349             "CREATE TABLE $table_name_ur (\n" .
 350             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 351             "\n);"
 352         ;
 353
 354         $output .= join( "\n\n",
 355             @comments,
 356             $create_statement,
 357             @trigger_defs,
 358             @index_defs,
 359             ''
 360         );
 361     }
 362
 363     if ( $WARN ) {
 364         if ( %truncated ) {
 365             warn "Truncated " . keys( %truncated ) . " names:\n";
 366             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 367         }
 368
 369         if ( %unreserve ) {
 370             warn "Encounted " . keys( %unreserve ) .
 371                 " unsafe names in schema (reserved or invalid):\n";
 372             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 373         }
 374     }
 375
 376     return $output;
 377 }
 378
 379 # -------------------------------------------------------------------
 380 sub mk_name {
 381     my $basename      = shift || '';
 382     my $type          = shift || '';
 383     my $scope         = shift || '';
 384     my $critical      = shift || '';
 385     my $basename_orig = $basename;
 386     my $max_name      = $type
 387                         ? $max_id_length - (length($type) + 1)
 388                         : $max_id_length;
 389     $basename         = substr( $basename, 0, $max_name )
 390                         if length( $basename ) > $max_name;
 391     my $name          = $type ? "${type}_$basename" : $basename;
 392
 393     if ( $basename ne $basename_orig and $critical ) {
 394         my $show_type = $type ? "+'$type'" : "";
 395         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 396             "character limit to make '$name'\n" if $WARN;
 397         $truncated{ $basename_orig } = $name;
 398     }
 399
 400     $scope ||= \%global_names;
 401     if ( my $prev = $scope->{ $name } ) {
 402         my $name_orig = $name;
 403         $name        .= sprintf( "%02d", ++$prev );
 404         substr($name, $max_id_length - 3) = "00"
 405             if length( $name ) > $max_id_length;
 406
 407         warn "The name '$name_orig' has been changed to ",
 408              "'$name' to make it unique.\n" if $WARN;
 409
 410         $scope->{ $name_orig }++;
 411     }
 412
 413     $scope->{ $name }++;
 414     return $name;
 415 }
 416
 417 # -------------------------------------------------------------------
 418 sub unreserve {
 419     my $name            = shift || '';
 420     my $schema_obj_name = shift || '';
 421
 422     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 423
 424     # also trap fields that don't begin with a letter
 425     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 426
 427     if ( $schema_obj_name ) {
 428         ++$unreserve{"$schema_obj_name.$name"};
 429     }
 430     else {
 431         ++$unreserve{"$name (table name)"};
 432     }
 433
 434     my $unreserve = sprintf '%s_', $name;
 435     return $unreserve.$suffix;
 436 }
 437
 438 1;
 439
 440 # -------------------------------------------------------------------
 441 # All bad art is the result of good intentions.
 442 # Oscar Wilde
 443 # -------------------------------------------------------------------
 444
 445 =head1 NAME
 446
 447 SQL::Translator::Producer::Oracle - Oracle SQL producer
 448
 449 =head1 SYNOPSIS
 450
 451   use SQL::Translator::Parser::MySQL;
 452   use SQL::Translator::Producer::Oracle;
 453
 454   my $original_create = ""; # get this from somewhere...
 455   my $translator = SQL::Translator->new;
 456
 457   $translator->parser("SQL::Translator::Parser::MySQL");
 458   $translator->producer("SQL::Translator::Producer::Oracle");
 459
 460   my $new_create = $translator->translate($original_create);
 461
 462 =head1 DESCRIPTION
 463
 464 SQL::Translator::Producer::Oracle takes a parsed data structure,
 465 created by a SQL::Translator::Parser subclass, and turns it into a
 466 create string suitable for use with an Oracle database.
 467
 468 =head1 CREDITS
 469
 470 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
 471 his "mysql2ora" script.
 472
 473 =head1 AUTHOR
 474
 475 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 476
 477 =head1 SEE ALSO
 478
 479 perl(1).
 480
 481 =cut