lib/SQL/Translator/Producer/Oracle.pm

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