lib/SQL/Translator/Producer/Oracle.pm

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