lib/SQL/Translator/Producer/Oracle.pm

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