lib/SQL/Translator/Producer/Oracle.pm

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