lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.8 2002-12-11 01:44:54 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.8 $ =~ /(\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 ( defined $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,
 301                     "CREATE INDEX $index_name on $table_name_ur (".
 302                         join( ', ', @fields ).
 303                     ");";
 304             }
 305             else {
 306                 warn "Unknown index type ($index_type) on table $table_name.\n"
 307                     if $WARN;
 308             }
 309         }
 310
 311         my $create_statement;
 312         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 313         $create_statement .= "CREATE TABLE $table_name_ur (\n".
 314             join( ",\n", map { "  $_" } @field_decs ).
 315             "\n);"
 316         ;
 317
 318         $output .= join( "\n\n",
 319             @comments,
 320             $create_statement,
 321             @trigger_decs,
 322             @index_decs,
 323             ''
 324         );
 325     }
 326
 327     if ( $WARN ) {
 328         if ( %truncated ) {
 329             warn "Truncated " . keys( %truncated ) . " names:\n";
 330             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 331         }
 332
 333         if ( %unreserve ) {
 334             warn "Encounted " . keys( %unreserve ) .
 335                 " unsafe names in schema (reserved or invalid):\n";
 336             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 337         }
 338     }
 339
 340     return $output;
 341 }
 342
 343 # -------------------------------------------------------------------
 344 sub mk_name {
 345     my ($basename, $type, $scope, $critical) = @_;
 346     my $basename_orig = $basename;
 347     my $max_name      = $type
 348                         ? $max_id_length - (length($type) + 1)
 349                         : $max_id_length;
 350     $basename         = substr( $basename, 0, $max_name )
 351                         if length( $basename ) > $max_name;
 352     my $name          = $type ? "${type}_$basename" : $basename;
 353
 354     if ( $basename ne $basename_orig and $critical ) {
 355         my $show_type = $type ? "+'$type'" : "";
 356         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 357             "character limit to make '$name'\n" if $WARN;
 358         $truncated{ $basename_orig } = $name;
 359     }
 360
 361     $scope ||= \%global_names;
 362     if ( my $prev = $scope->{ $name } ) {
 363         my $name_orig = $name;
 364         $name        .= sprintf( "%02d", ++$prev );
 365         substr($name, $max_id_length - 3) = "00"
 366             if length( $name ) > $max_id_length;
 367
 368         warn "The name '$name_orig' has been changed to ",
 369              "'$name' to make it unique.\n" if $WARN;
 370
 371         $scope->{ $name_orig }++;
 372     }
 373
 374     $scope->{ $name }++;
 375     return $name;
 376 }
 377
 378 # -------------------------------------------------------------------
 379 sub unreserve {
 380     my ( $name, $schema_obj_name ) = @_;
 381     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 382
 383     # also trap fields that don't begin with a letter
 384     return $_[0] if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 385
 386     if ( $schema_obj_name ) {
 387         ++$unreserve{"$schema_obj_name.$name"};
 388     }
 389     else {
 390         ++$unreserve{"$name (table name)"};
 391     }
 392
 393     my $unreserve = sprintf '%s_', $name;
 394     return $unreserve.$suffix;
 395 }
 396
 397 1;
 398
 399 # -------------------------------------------------------------------
 400 # All bad art is the result of good intentions.
 401 # Oscar Wilde
 402 # -------------------------------------------------------------------
 403
 404 =head1 NAME
 405
 406 SQL::Translator::Producer::Oracle - Oracle SQL producer
 407
 408 =head1 SYNOPSIS
 409
 410   use SQL::Translator::Parser::MySQL;
 411   use SQL::Translator::Producer::Oracle;
 412
 413   my $original_create = ""; # get this from somewhere...
 414   my $translator = SQL::Translator->new;
 415
 416   $translator->parser("SQL::Translator::Parser::MySQL");
 417   $translator->producer("SQL::Translator::Producer::Oracle");
 418
 419   my $new_create = $translator->translate($original_create);
 420
 421 =head1 DESCRIPTION
 422
 423 SQL::Translator::Producer::Oracle takes a parsed data structure,
 424 created by a SQL::Translator::Parser subclass, and turns it into a
 425 create string suitable for use with an Oracle database.
 426
 427 =head1 CREDITS
 428
 429 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
 430 his "mysql2ora" script.
 431
 432 =head1 AUTHOR
 433
 434 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 435
 436 =head1 SEE ALSO
 437
 438 perl(1).
 439
 440 =cut