lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.26 2003-10-15 19:00:35 kycl4rk 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 =head1 NAME
  26
  27 SQL::Translator::Producer::Oracle - Oracle SQL producer
  28
  29 =head1 SYNOPSIS
  30
  31   use SQL::Translator;
  32
  33   my $t = SQL::Translator->new( parser => '...', producer => 'Oracle' );
  34   print $translator->translate( $file );
  35
  36 =head1 DESCRIPTION
  37
  38 Creates an SQL DDL suitable for Oracle.
  39
  40 =cut
  41
  42 use strict;
  43 use vars qw[ $VERSION $DEBUG $WARN ];
  44 $VERSION = sprintf "%d.%02d", q$Revision: 1.26 $ =~ /(\d+)\.(\d+)/;
  45 $DEBUG   = 0 unless defined $DEBUG;
  46
  47 use SQL::Translator::Schema::Constants;
  48 use SQL::Translator::Utils qw(header_comment);
  49
  50 my %translate  = (
  51     #
  52     # MySQL types
  53     #
  54     bigint     => 'number',
  55     double     => 'number',
  56     decimal    => 'number',
  57     float      => 'number',
  58     int        => 'number',
  59     integer    => 'number',
  60     mediumint  => 'number',
  61     smallint   => 'number',
  62     tinyint    => 'number',
  63     char       => 'char',
  64     varchar    => 'varchar2',
  65     tinyblob   => 'blob',
  66     blob       => 'blob',
  67     mediumblob => 'blob',
  68     longblob   => 'blob',
  69     tinytext   => 'varchar2',
  70     text       => 'clob',
  71     longtext   => 'clob',
  72     mediumtext => 'clob',
  73     enum       => 'varchar2',
  74     set        => 'varchar2',
  75     date       => 'date',
  76     datetime   => 'date',
  77     time       => 'date',
  78     timestamp  => 'date',
  79     year       => 'date',
  80
  81     #
  82     # PostgreSQL types
  83     #
  84     numeric             => 'number',
  85     'double precision'  => 'number',
  86     serial              => 'number',
  87     bigserial           => 'number',
  88     money               => 'number',
  89     character           => 'char',
  90     'character varying' => 'varchar2',
  91     bytea               => 'BLOB',
  92     interval            => 'number',
  93     boolean             => 'number',
  94     point               => 'number',
  95     line                => 'number',
  96     lseg                => 'number',
  97     box                 => 'number',
  98     path                => 'number',
  99     polygon             => 'number',
 100     circle              => 'number',
 101     cidr                => 'number',
 102     inet                => 'varchar2',
 103     macaddr             => 'varchar2',
 104     bit                 => 'number',
 105     'bit varying'       => 'number',
 106
 107     #
 108     # Oracle types
 109     #
 110     number              => 'number',
 111     varchar2            => 'varchar2',
 112     long                => 'clob',
 113 );
 114
 115 #
 116 # Oracle reserved words from:
 117 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
 118 # 817_doc/server.817/a85397/ap_keywd.htm
 119 #
 120 my %ora_reserved = map { $_, 1 } qw(
 121     ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
 122     BETWEEN BY
 123     CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
 124     DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
 125     ELSE EXCLUSIVE EXISTS
 126     FILE FLOAT FOR FROM
 127     GRANT GROUP
 128     HAVING
 129     IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
 130     INTEGER INTERSECT INTO IS
 131     LEVEL LIKE LOCK LONG
 132     MAXEXTENTS MINUS MLSLABEL MODE MODIFY
 133     NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
 134     OF OFFLINE ON ONLINE OPTION OR ORDER
 135     PCTFREE PRIOR PRIVILEGES PUBLIC
 136     RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
 137     SELECT SESSION SET SHARE SIZE SMALLINT START
 138     SUCCESSFUL SYNONYM SYSDATE
 139     TABLE THEN TO TRIGGER
 140     UID UNION UNIQUE UPDATE USER
 141     VALIDATE VALUES VARCHAR VARCHAR2 VIEW
 142     WHENEVER WHERE WITH
 143 );
 144
 145 my $max_id_length    = 30;
 146 my %used_identifiers = ();
 147 my %global_names;
 148 my %unreserve;
 149 my %truncated;
 150
 151 # -------------------------------------------------------------------
 152 sub produce {
 153     my $translator     = shift;
 154     $DEBUG             = $translator->debug;
 155     $WARN              = $translator->show_warnings;
 156     my $no_comments    = $translator->no_comments;
 157     my $add_drop_table = $translator->add_drop_table;
 158     my $schema         = $translator->schema;
 159     my $output;
 160
 161     $output .= header_comment unless ($no_comments);
 162
 163     if ( $translator->parser_type =~ /mysql/i ) {
 164         $output .=
 165         "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 166         "-- but we set it here anyway to be self-consistent.\n".
 167         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 168     }
 169
 170     #
 171     # Print create for each table
 172     #
 173     for my $table ( $schema->get_tables ) {
 174         my $table_name    = $table->name or next;
 175         $table_name       = mk_name( $table_name, '', undef, 1 );
 176         my $table_name_ur = unreserve($table_name) or next;
 177
 178         my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
 179
 180         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 181
 182         my ( %field_name_scope, @field_comments );
 183         for my $field ( $table->get_fields ) {
 184             #
 185             # Field name
 186             #
 187             my $field_name    = mk_name(
 188                 $field->name, '', \%field_name_scope, 1
 189             );
 190             my $field_name_ur = unreserve( $field_name, $table_name );
 191             my $field_def     = $field_name_ur;
 192
 193             #
 194             # Datatype
 195             #
 196             my $check;
 197             my $data_type = lc $field->data_type;
 198             my @size      = $field->size;
 199             my %extra     = $field->extra;
 200             my $list      = $extra{'list'} || [];
 201             # \todo deal with embedded quotes
 202             my $commalist = join( ', ', map { qq['$_'] } @$list );
 203
 204             if ( $data_type eq 'enum' ) {
 205                 $check = "CHECK ($field_name_ur IN ($commalist))";
 206                 $data_type = 'varchar2';
 207             }
 208             elsif ( $data_type eq 'set' ) {
 209                 # XXX add a CHECK constraint maybe
 210                 # (trickier and slower, than enum :)
 211                 $data_type = 'varchar2';
 212             }
 213             else {
 214                 $data_type  = defined $translate{ $data_type } ?
 215                               $translate{ $data_type } :
 216                               die "Unknown datatype: $data_type\n";
 217             }
 218
 219             #
 220             # Fixes ORA-02329: column of datatype LOB cannot be
 221             # unique or a primary key
 222             #
 223             if ( $data_type eq 'clob' && $field->is_primary_key ) {
 224                 $data_type = 'varchar2';
 225                 $size[0]   = 4000;
 226                 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 227                     if $WARN;
 228             }
 229
 230             #
 231             # Fixes ORA-00907: missing right parenthesis
 232             #
 233             if ( $data_type =~ /(date|clob)/i ) {
 234                 undef @size;
 235             }
 236
 237             $field_def .= " $data_type";
 238             if ( defined $size[0] && $size[0] > 0 ) {
 239                 $field_def .= '(' . join( ', ', @size ) . ')';
 240             }
 241
 242             #
 243             # Default value
 244             #
 245             my $default = $field->default_value;
 246             if ( defined $default ) {
 247                 #
 248                 # Wherein we try to catch a string being used as
 249                 # a default value for a numerical field.  If "true/false,"
 250                 # then sub "1/0," otherwise just test the truthity of the
 251                 # argument and use that (naive?).
 252                 #
 253                 if (
 254                     $data_type =~ /^number$/i &&
 255                     $default   !~ /^\d+$/     &&
 256                     $default   !~ m/null/i
 257                 ) {
 258                     if ( $default =~ /^true$/i ) {
 259                         $default = "'1'";
 260                     }
 261                     elsif ( $default =~ /^false$/i ) {
 262                         $default = "'0'";
 263                     }
 264                     else {
 265                         $default = $default ? "'1'" : "'0'";
 266                     }
 267                 }
 268                 elsif (
 269                     $data_type =~ /date/ && $default eq 'current_timestamp'
 270                 ) {
 271                     $default = 'SYSDATE';
 272                 }
 273                 else {
 274                     $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 275                 }
 276
 277                 $field_def .= " DEFAULT $default",
 278             }
 279
 280             #
 281             # Not null constraint
 282             #
 283             unless ( $field->is_nullable ) {
 284 #                my $constraint_name = mk_name(
 285 #                    join('_', $table_name_ur, $field_name_ur ), 'nn'
 286 #                );
 287 #                $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
 288                 $field_def .= ' NOT NULL';
 289             }
 290
 291             $field_def .= " $check" if $check;
 292
 293             #
 294             # Auto_increment
 295             #
 296             if ( $field->is_auto_increment ) {
 297                 my $base_name    = $table_name . "_". $field_name;
 298                 my $seq_name     = mk_name( $base_name, 'sq' );
 299                 my $trigger_name = mk_name( $base_name, 'ai' );
 300
 301                 push @trigger_defs,
 302                     "CREATE SEQUENCE $seq_name;\n" .
 303                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 304                     "BEFORE INSERT ON $table_name\n" .
 305                     "FOR EACH ROW WHEN (\n" .
 306                         " new.$field_name_ur IS NULL".
 307                         " OR new.$field_name_ur = 0\n".
 308                     ")\n".
 309                     "BEGIN\n" .
 310                         " SELECT $seq_name.nextval\n" .
 311                         " INTO :new." . $field->name."\n" .
 312                         " FROM dual;\n" .
 313                     "END;\n/";
 314                 ;
 315             }
 316
 317             if ( lc $field->data_type eq 'timestamp' ) {
 318                 my $base_name = $table_name . "_". $field_name_ur;
 319                 my $trig_name = mk_name( $base_name, 'ts' );
 320                 push @trigger_defs,
 321                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 322                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 323                     "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 324                     "BEGIN \n".
 325                     " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 326                     "END;\n/";
 327             }
 328
 329             push @field_defs, $field_def;
 330
 331             if ( my $comment = $field->comments ) {
 332                 push @field_comments,
 333                     "COMMENT ON COLUMN $table_name.$field_name_ur is\n  '".
 334                     $comment."';";
 335             }
 336         }
 337
 338         #
 339         # Table options
 340         #
 341         my @table_options;
 342         for my $opt ( $table->options ) {
 343             if ( ref $opt eq 'HASH' ) {
 344                 my ( $key, $value ) = each %$opt;
 345                 if ( ref $value eq 'ARRAY' ) {
 346                     push @table_options, "$key\n(\n".  join ("\n",
 347                         map { "  $_->[0]\t$_->[1]" }
 348                         map { [ each %$_ ] }
 349                         @$value
 350                     )."\n)";
 351                 }
 352                 elsif ( !defined $value ) {
 353                     push @table_options, $key;
 354                 }
 355                 else {
 356                     push @table_options, "$key    $value";
 357                 }
 358             }
 359         }
 360
 361         #
 362         # Table constraints
 363         #
 364         for my $c ( $table->get_constraints ) {
 365             my $name    = $c->name || '';
 366             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 367             my @rfields = map { unreserve( $_, $table_name ) }
 368                 $c->reference_fields;
 369             next if !@fields && $c->type ne CHECK_C;
 370
 371             if ( $c->type eq PRIMARY_KEY ) {
 372                 $name ||= mk_name( $table_name, 'pk' );
 373                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 374                     '(' . join( ', ', @fields ) . ')';
 375             }
 376             elsif ( $c->type eq UNIQUE ) {
 377                 $name ||= mk_name( $table_name, 'u' );
 378                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 379                     '(' . join( ', ', @fields ) . ')';
 380             }
 381             elsif ( $c->type eq CHECK_C ) {
 382                 $name ||= mk_name( $table_name, 'ck' );
 383                 my $expression = $c->expression || '';
 384                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 385             }
 386             elsif ( $c->type eq FOREIGN_KEY ) {
 387                 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
 388                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 389
 390                 if ( @fields ) {
 391                     $def .= '(' . join( ', ', @fields ) . ')';
 392                 }
 393
 394                 my $ref_table = unreserve($c->reference_table);
 395
 396                 $def .= " REFERENCES $ref_table";
 397
 398                 if ( @rfields ) {
 399                     $def .= ' (' . join( ', ', @rfields ) . ')';
 400                 }
 401
 402                 if ( $c->match_type ) {
 403                     $def .= ' MATCH ' .
 404                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 405                 }
 406
 407                 if ( $c->on_delete ) {
 408                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 409                 }
 410
 411                 if ( $c->on_update ) {
 412                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 413                 }
 414
 415                 push @constraint_defs, $def;
 416             }
 417         }
 418
 419         #
 420         # Index Declarations
 421         #
 422         my @index_defs = ();
 423         for my $index ( $table->get_indices ) {
 424             my $index_name = $index->name || '';
 425             my $index_type = $index->type || NORMAL;
 426             my @fields     = map { unreserve( $_, $table_name ) }
 427                              $index->fields;
 428             next unless @fields;
 429
 430             if ( $index_type eq PRIMARY_KEY ) {
 431                 $index_name ||= mk_name( $table_name, 'pk' );
 432                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 433                     '(' . join( ', ', @fields ) . ')';
 434             }
 435             elsif ( $index_type eq NORMAL ) {
 436                 $index_name ||= mk_name( $table_name, $index_name || 'i' );
 437                 push @index_defs,
 438                     "CREATE INDEX $index_name on $table_name_ur (".
 439                         join( ', ', @fields ).
 440                     ");";
 441             }
 442             else {
 443                 warn "Unknown index type ($index_type) on table $table_name.\n"
 444                     if $WARN;
 445             }
 446         }
 447
 448         my $create_statement;
 449         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 450
 451         if ( my @table_comments = $table->comments ) {
 452             for my $comment ( @table_comments ) {
 453                 next unless $comment;
 454                 push @field_comments, "COMMENT ON TABLE $table_name is\n  '".
 455                     $comment."';"
 456                 ;
 457             }
 458         }
 459
 460         my $table_options = @table_options
 461             ? "\n".join("\n", @table_options) : '';
 462         $create_statement .= "CREATE TABLE $table_name_ur (\n" .
 463             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 464             "\n)$table_options;"
 465         ;
 466
 467         $output .= join( "\n\n",
 468             @comments,
 469             $create_statement,
 470             @trigger_defs,
 471             @index_defs,
 472             @field_comments,
 473             ''
 474         );
 475     }
 476
 477     if ( $WARN ) {
 478         if ( %truncated ) {
 479             warn "Truncated " . keys( %truncated ) . " names:\n";
 480             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 481         }
 482
 483         if ( %unreserve ) {
 484             warn "Encounted " . keys( %unreserve ) .
 485                 " unsafe names in schema (reserved or invalid):\n";
 486             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 487         }
 488     }
 489
 490     return $output;
 491 }
 492
 493 # -------------------------------------------------------------------
 494 sub mk_name {
 495     my $basename      = shift || '';
 496     my $type          = shift || '';
 497        $type          = '' if $type =~ /^\d/;
 498     my $scope         = shift || '';
 499     my $critical      = shift || '';
 500     my $basename_orig = $basename;
 501     my $max_name      = $type
 502                         ? $max_id_length - (length($type) + 1)
 503                         : $max_id_length;
 504     $basename         = substr( $basename, 0, $max_name )
 505                         if length( $basename ) > $max_name;
 506     my $name          = $type ? "${type}_$basename" : $basename;
 507
 508     if ( $basename ne $basename_orig and $critical ) {
 509         my $show_type = $type ? "+'$type'" : "";
 510         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 511             "character limit to make '$name'\n" if $WARN;
 512         $truncated{ $basename_orig } = $name;
 513     }
 514
 515     $scope ||= \%global_names;
 516     if ( my $prev = $scope->{ $name } ) {
 517         my $name_orig = $name;
 518         $name        .= sprintf( "%02d", ++$prev );
 519         substr($name, $max_id_length - 3) = "00"
 520             if length( $name ) > $max_id_length;
 521
 522         warn "The name '$name_orig' has been changed to ",
 523              "'$name' to make it unique.\n" if $WARN;
 524
 525         $scope->{ $name_orig }++;
 526     }
 527
 528     $scope->{ $name }++;
 529     return $name;
 530 }
 531
 532 # -------------------------------------------------------------------
 533 sub unreserve {
 534     my $name            = shift || '';
 535     my $schema_obj_name = shift || '';
 536
 537     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 538
 539     # also trap fields that don't begin with a letter
 540     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 541
 542     if ( $schema_obj_name ) {
 543         ++$unreserve{"$schema_obj_name.$name"};
 544     }
 545     else {
 546         ++$unreserve{"$name (table name)"};
 547     }
 548
 549     my $unreserve = sprintf '%s_', $name;
 550     return $unreserve.$suffix;
 551 }
 552
 553 1;
 554
 555 # -------------------------------------------------------------------
 556 # All bad art is the result of good intentions.
 557 # Oscar Wilde
 558 # -------------------------------------------------------------------
 559
 560 =pod
 561
 562 =head1 CREDITS
 563
 564 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 565 script.
 566
 567 =head1 AUTHOR
 568
 569 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 570
 571 =head1 SEE ALSO
 572
 573 SQL::Translator, DDL::Oracle, mysql2ora.
 574
 575 =cut