lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.5 2002-11-23 01:26:56 kycl4rk Exp $
   5 # -------------------------------------------------------------------
   6 # Copyright (C) 2002 Ken Y. Clark <kclark@cpan.org>,
   7 #                    darren chamberlain <darren@cpan.org>
   8 #
   9 # This program is free software; you can redistribute it and/or
  10 # modify it under the terms of the GNU General Public License as
  11 # published by the Free Software Foundation; version 2.
  12 #
  13 # This program is distributed in the hope that it will be useful, but
  14 # WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 # General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  21 # 02111-1307  USA
  22 # -------------------------------------------------------------------
  23
  24 use strict;
  25 use vars qw[ $VERSION $DEBUG ];
  26 $VERSION = sprintf "%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/;
  27 $DEBUG   = 0 unless defined $DEBUG;
  28
  29 my $max_id_length = 30;
  30 my %used_identifiers = ();
  31
  32 my %translate  = (
  33     #
  34     # MySQL types
  35     #
  36     bigint     => 'number',
  37     double     => 'number',
  38     decimal    => 'number',
  39     float      => 'number',
  40     int        => 'number',
  41     mediumint  => 'number',
  42     smallint   => 'number',
  43     tinyint    => 'number',
  44     char       => 'char',
  45     varchar    => 'varchar2',
  46     tinyblob   => 'CLOB',
  47     blob       => 'CLOB',
  48     mediumblob => 'CLOB',
  49     longblob   => 'CLOB',
  50     longtext   => 'long',
  51     mediumtext => 'long',
  52     text       => 'long',
  53     tinytext   => 'long',
  54     enum       => 'varchar2',
  55     set        => 'varchar2',
  56     date       => 'date',
  57     datetime   => 'date',
  58     time       => 'date',
  59     timestamp  => 'date',
  60     year       => 'date',
  61
  62     #
  63     # PostgreSQL types
  64     #
  65     smallint            => '',
  66     integer             => '',
  67     bigint              => '',
  68     decimal             => '',
  69     numeric             => '',
  70     real                => '',
  71     'double precision'  => '',
  72     serial              => '',
  73     bigserial           => '',
  74     money               => '',
  75     character           => '',
  76     'character varying' => '',
  77     bytea               => '',
  78     interval            => '',
  79     boolean             => '',
  80     point               => '',
  81     line                => '',
  82     lseg                => '',
  83     box                 => '',
  84     path                => '',
  85     polygon             => '',
  86     circle              => '',
  87     cidr                => '',
  88     inet                => '',
  89     macaddr             => '',
  90     bit                 => '',
  91     'bit varying'       => '',
  92 );
  93
  94 #
  95 # Oracle reserved words from:
  96 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
  97 # 817_doc/server.817/a85397/ap_keywd.htm
  98 #
  99 my @ora_reserved = qw(
 100     ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
 101     BETWEEN BY
 102     CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
 103     DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
 104     ELSE EXCLUSIVE EXISTS
 105     FILE FLOAT FOR FROM
 106     GRANT GROUP
 107     HAVING
 108     IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
 109     INTEGER INTERSECT INTO IS
 110     LEVEL LIKE LOCK LONG
 111     MAXEXTENTS MINUS MLSLABEL MODE MODIFY
 112     NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
 113     OF OFFLINE ON ONLINE OPTION OR ORDER
 114     PCTFREE PRIOR PRIVILEGES PUBLIC
 115     RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
 116     SELECT SESSION SET SHARE SIZE SMALLINT START
 117     SUCCESSFUL SYNONYM SYSDATE
 118     TABLE THEN TO TRIGGER
 119     UID UNION UNIQUE UPDATE USER
 120     VALIDATE VALUES VARCHAR VARCHAR2 VIEW
 121     WHENEVER WHERE WITH
 122 );
 123
 124 my %ora_reserved = map { $_ => 1 } @ora_reserved;
 125 my %global_names;
 126 my %unreserve;
 127 my %truncated;
 128
 129 sub produce {
 130     my ( $translator, $data ) = @_;
 131     $DEBUG                    = $translator->debug;
 132     my $no_comments           = $translator->no_comments;
 133     my $output;
 134
 135     unless ( $no_comments ) {
 136         $output .=  sprintf
 137             "--\n-- Created by %s\n-- Created on %s\n--\n\n",
 138             __PACKAGE__, scalar localtime;
 139     }
 140
 141     if ( $translator->parser_type =~ /mysql/i ) {
 142         $output .=
 143         "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 144         "-- but we set it here anyway to be self-consistent.\n".
 145         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 146     }
 147
 148     #
 149     # Print create for each table
 150     #
 151     for my $table (
 152         map  { $_->[1] }
 153         sort { $a->[0] <=> $b->[0] }
 154         map  { [ $_->{'order'}, $_ ] }
 155         values %{ $data }
 156     ) {
 157         my $table_name    = $table->{'table_name'};
 158         $table_name       = mk_name( $table_name, '', undef, 1 );
 159         my $table_name_ur = unreserve($table_name);
 160
 161         my ( @comments, @field_decs, @trigger_decs );
 162
 163         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 164
 165         my %field_name_scope;
 166         for my $field (
 167             map  { $_->[1] }
 168             sort { $a->[0] <=> $b->[0] }
 169             map  { [ $_->{'order'}, $_ ] }
 170             values %{ $table->{'fields'} }
 171         ) {
 172             #
 173             # Field name
 174             #
 175             my $field_name    = mk_name(
 176                 $field->{'name'}, '', \%field_name_scope, 1
 177             );
 178             my $field_name_ur = unreserve( $field_name, $table_name );
 179             my $field_str     = $field_name_ur;
 180
 181             #
 182             # Datatype
 183             #
 184             my $check;
 185             my $data_type = lc $field->{'data_type'};
 186             my $list      = $field->{'list'} || [];
 187             my $commalist = join ",", @$list;
 188
 189             if ( $data_type eq 'enum' ) {
 190                 my $len = 0;
 191                 $len = ($len < length($_)) ? length($_) : $len for (@$list);
 192                 $check = "CHECK ($field_name IN ($commalist))";
 193                 $field_str .= " varchar2($len)";
 194             }
 195             elsif ( $data_type eq 'set' ) {
 196                 # XXX add a CHECK constraint maybe
 197                 # (trickier and slower, than enum :)
 198                 my $len     = length $commalist;
 199                 $field_str .= " varchar2($len) /* set $commalist */ ";
 200             }
 201             else {
 202                 $data_type  = defined $translate{ $data_type } ?
 203                               $translate{ $data_type } :
 204                               die "Unknown datatype: $data_type\n";
 205                 $field_str .= ' '.$data_type;
 206                 $field_str .= '('.join(',', @{ $field->{'size'} }).')'
 207                     if @{ $field->{'size'} || [] };
 208             }
 209
 210             #
 211             # Default value
 212             #
 213             if ( $field->{'default'} ) {
 214                 $field_str .= sprintf(
 215                     ' DEFAULT %s',
 216                     $field->{'default'} =~ m/null/i ? 'NULL' :
 217                     "'".$field->{'default'}."'"
 218                 );
 219             }
 220
 221             #
 222             # Not null constraint
 223             #
 224             unless ( $field->{'null'} ) {
 225                 my $constraint_name = mk_name($field_name_ur, 'nn');
 226                 $field_str .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
 227             }
 228
 229             $field_str .= " $check" if $check;
 230
 231             #
 232             # Auto_increment
 233             #
 234             if ( $field->{'is_auto_inc'} ) {
 235                 my $base_name    = $table_name . "_". $field_name;
 236                 my $seq_name     = mk_name( $base_name, 'sq' );
 237                 my $trigger_name = mk_name( $base_name, 'ai' );
 238
 239                 push @trigger_decs,
 240                     "CREATE SEQUENCE $seq_name;\n" .
 241                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 242                     "BEFORE INSERT ON $table_name\n" .
 243                     "FOR EACH ROW WHEN (\n" .
 244                         " new.$field_name_ur IS NULL".
 245                         " OR new.$field_name_ur = 0\n".
 246                     ")\n".
 247                     "BEGIN\n" .
 248                         " SELECT $seq_name.nextval\n" .
 249                         " INTO :new." . $field->{'name'}."\n" .
 250                         " FROM dual;\n" .
 251                     "END;\n/";
 252                 ;
 253             }
 254
 255             if ( uc $field->{'data_type'} eq 'TIMESTAMP' ) {
 256                 my $base_name = $table_name . "_". $field_name_ur;
 257                 my $trig_name = mk_name($base_name,'ts');
 258                 push @trigger_decs,
 259                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 260                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 261                     "FOR EACH ROW WHEN (new.$field_name_ur} IS NULL)\n".
 262                     "BEGIN \n".
 263                     " SELECT sysdate INTO :new.$field_name_ur} FROM dual;\n".
 264                     "END;\n/";
 265             }
 266
 267             push @field_decs, $field_str;
 268         }
 269
 270         #
 271         # Index Declarations
 272         #
 273         my @index_decs = ();
 274         my $idx_name_default;
 275         for my $index ( @{ $table->{'indices'} } ) {
 276             my $index_name = $index->{'name'} || '';
 277             my $index_type = $index->{'type'} || 'normal';
 278             my @fields     = map { unreserve( $_, $table_name ) }
 279                              @{ $index->{'fields'} };
 280             next unless @fields;
 281
 282             if ( $index_type eq 'primary_key' ) {
 283                 $index_name = mk_name( $table_name, 'pk' );
 284                 push @field_decs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 285                     '(' . join( ', ', @fields ) . ')';
 286             }
 287             elsif ( $index_type eq 'unique' ) {
 288                 $index_name = mk_name(
 289                     $table_name, $index_name || ++$idx_name_default
 290                 );
 291                 push @field_decs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 292                     '(' . join( ', ', @fields ) . ')';
 293             }
 294
 295             elsif ( $index_type eq 'normal' ) {
 296                 $index_name = mk_name(
 297                     $table_name, $index_name || ++$idx_name_default
 298                 );
 299                 push @index_decs, "CREATE INDEX $index_name on $table_name (".
 300                     join( ', ', @fields ).  ");";
 301             }
 302             else {
 303                 warn "Unknown index type ($index_type) on table $table_name.\n";
 304             }
 305         }
 306
 307         my $create_statement = "CREATE TABLE $table_name_ur (\n".
 308             join( ",\n", map { "  $_" } @field_decs ).
 309             "\n);"
 310         ;
 311
 312         $output .= join( "\n\n",
 313             @comments,
 314             $create_statement,
 315             @trigger_decs,
 316             @index_decs,
 317             ''
 318         );
 319     }
 320
 321     return $output;
 322 }
 323
 324 # -------------------------------------------------------------------
 325 sub mk_name {
 326     my ($basename, $type, $scope, $critical) = @_;
 327     my $basename_orig = $basename;
 328     my $max_name      = $max_id_length - (length($type) + 1);
 329     $basename         = substr($basename, 0, $max_name)
 330                         if length($basename) > $max_name;
 331     my $name          = $type ? "${type}_$basename" : $basename;
 332
 333     if ( $basename ne $basename_orig and $critical ) {
 334         my $show_type = $type ? "+'$type'" : "";
 335         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 336             "character limit to make '$name'\n" if $DEBUG;
 337         $truncated{$basename_orig} = $name;
 338     }
 339
 340     $scope ||= \%global_names;
 341     return $name unless $scope->{$name}++;
 342     my $name_orig = $name;
 343     $name .= "02";
 344     substr($name, $max_id_length - 3) = "00" if length($name) > $max_id_length;
 345     ++$name while $scope->{$name};
 346     warn "The name '$name_orig' has been changed to ",
 347          "'$name' to make it unique\n" if $DEBUG;
 348     return $name;
 349 }
 350
 351 # -------------------------------------------------------------------
 352 sub unreserve {
 353     my ($name, $schema_obj_name) = @_;
 354     my ($suffix) = ($name =~ s/(\W.*)$//) ? $1 : '';
 355
 356     # also trap fields that don't begin with a letter
 357     return $_[0] if !$ora_reserved{uc $name}
 358         && $name =~ /^[a-z]/i;
 359
 360     if ( $schema_obj_name ) {
 361         ++$unreserve{"$schema_obj_name.$name"};
 362     }
 363     else {
 364         ++$unreserve{"$name (table name)"};
 365     }
 366
 367     my $unreserve = sprintf '%s_', $name;
 368     return $unreserve.$suffix;
 369 }
 370
 371 1;
 372
 373 # -------------------------------------------------------------------
 374 # All bad art is the result of good intentions.
 375 # Oscar Wilde
 376 # -------------------------------------------------------------------
 377
 378 =head1 NAME
 379
 380 SQL::Translator::Producer::Oracle - Oracle SQL producer
 381
 382 =head1 SYNOPSIS
 383
 384   use SQL::Translator::Parser::MySQL;
 385   use SQL::Translator::Producer::Oracle;
 386
 387   my $original_create = ""; # get this from somewhere...
 388   my $translator = SQL::Translator->new;
 389
 390   $translator->parser("SQL::Translator::Parser::MySQL");
 391   $translator->producer("SQL::Translator::Producer::Oracle");
 392
 393   my $new_create = $translator->translate($original_create);
 394
 395 =head1 DESCRIPTION
 396
 397 SQL::Translator::Producer::Oracle takes a parsed data structure,
 398 created by a SQL::Translator::Parser subclass, and turns it into a
 399 create string suitable for use with an Oracle database.
 400
 401 =head1 BUGS
 402
 403 Problem with SQL::Translator::Producer::Oracle: it is keeping track
 404 of the last sequence number used, so as not to duplicate them, which
 405 is reasonable.  However on runs past the first, it seems to be
 406 creating multiple constraint lines, that look like:
 407
 408     CONSTRAINT i_sessions_pk_2 PRIMARY KEY (id),
 409     CONSTRAINT i_sessions_pk_3 PRIMARY KEY (id)
 410
 411 This is a very preliminary finding, and needs to be investigated more
 412 thoroughly, of course.
 413
 414 =head1 CREDITS
 415
 416 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
 417 his "mysql2ora" script.
 418
 419 =head1 AUTHOR
 420
 421 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 422
 423 =head1 SEE ALSO
 424
 425 perl(1).
 426
 427 =cut
 428
 429 __END__
 430 !!!!!Code Graveyard!!!!!
 431 #
 432 # Used to make index names
 433 #
 434 sub make_identifier {
 435     my ( $identifier, @mutations ) = @_;
 436     my $length_of_mutations;
 437     for my $mutation ( @mutations ) {
 438         $length_of_mutations += length( $mutation );
 439     }
 440
 441     if (
 442         length( $identifier ) + $length_of_mutations >
 443         $max_id_length
 444     ) {
 445         $identifier = substr(
 446             $identifier,
 447             0,
 448             $max_id_length - $length_of_mutations
 449         );
 450     }
 451
 452     for my $mutation ( @mutations ) {
 453         if ( $mutation =~ m/.+_$/ ) {
 454             $identifier = $mutation.$identifier;
 455         }
 456         elsif ( $mutation =~ m/^_.+/ ) {
 457             $identifier = $identifier.$mutation;
 458         }
 459     }
 460
 461     if ( $used_identifiers{ $identifier } ) {
 462         my $index = 1;
 463         if ( $identifier =~ m/_(\d+)$/ ) {
 464             $index = $1;
 465             $identifier = substr(
 466                 $identifier,
 467                 0,
 468                 length( $identifier ) - ( length( $index ) + 1 )
 469             );
 470         }
 471         $index++;
 472         return make_identifier( $identifier, '_'.$index );
 473     }
 474
 475     $used_identifiers{ $identifier } = 1;
 476
 477     return $identifier;
 478 }
 479
 480 #
 481 # Checks to see if an identifier is not too long
 482 #
 483 sub check_identifier {
 484     my $identifier = shift;
 485     die "Identifier '$identifier' is too long, unrecoverable error.\n"
 486         if length( $identifier ) > $max_id_length;
 487     return $identifier;
 488 }
 489