lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.29 2004-01-25 18:12:54 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.29 $ =~ /(\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             unless $no_comments;
 168
 169         $output .=
 170         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 171     }
 172
 173     #
 174     # Print create for each table
 175     #
 176     for my $table ( $schema->get_tables ) {
 177         my $table_name    = $table->name or next;
 178         $table_name       = mk_name( $table_name, '', undef, 1 );
 179         my $table_name_ur = unreserve($table_name) or next;
 180
 181         my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
 182
 183         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 184
 185         my ( %field_name_scope, @field_comments );
 186         for my $field ( $table->get_fields ) {
 187             #
 188             # Field name
 189             #
 190             my $field_name    = mk_name(
 191                 $field->name, '', \%field_name_scope, 1
 192             );
 193             my $field_name_ur = unreserve( $field_name, $table_name );
 194             my $field_def     = $field_name_ur;
 195
 196             #
 197             # Datatype
 198             #
 199             my $check;
 200             my $data_type = lc $field->data_type;
 201             my @size      = $field->size;
 202             my %extra     = $field->extra;
 203             my $list      = $extra{'list'} || [];
 204             # \todo deal with embedded quotes
 205             my $commalist = join( ', ', map { qq['$_'] } @$list );
 206
 207             if ( $data_type eq 'enum' ) {
 208                 $check = "CHECK ($field_name_ur IN ($commalist))";
 209                 $data_type = 'varchar2';
 210             }
 211             elsif ( $data_type eq 'set' ) {
 212                 # XXX add a CHECK constraint maybe
 213                 # (trickier and slower, than enum :)
 214                 $data_type = 'varchar2';
 215             }
 216             else {
 217                 $data_type  = defined $translate{ $data_type } ?
 218                               $translate{ $data_type } :
 219                               $data_type;
 220                 $data_type ||= 'varchar2';
 221             }
 222
 223             #
 224             # Fixes ORA-02329: column of datatype LOB cannot be
 225             # unique or a primary key
 226             #
 227             if ( $data_type eq 'clob' && $field->is_primary_key ) {
 228                 $data_type = 'varchar2';
 229                 $size[0]   = 4000;
 230                 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 231                     if $WARN;
 232             }
 233
 234             #
 235             # Fixes ORA-00907: missing right parenthesis
 236             #
 237             if ( $data_type =~ /(date|clob)/i ) {
 238                 undef @size;
 239             }
 240
 241             $field_def .= " $data_type";
 242             if ( defined $size[0] && $size[0] > 0 ) {
 243                 $field_def .= '(' . join( ', ', @size ) . ')';
 244             }
 245
 246             #
 247             # Default value
 248             #
 249             my $default = $field->default_value;
 250             if ( defined $default ) {
 251                 #
 252                 # Wherein we try to catch a string being used as
 253                 # a default value for a numerical field.  If "true/false,"
 254                 # then sub "1/0," otherwise just test the truthity of the
 255                 # argument and use that (naive?).
 256                 #
 257                 if (
 258                     $data_type =~ /^number$/i &&
 259                     $default   !~ /^\d+$/     &&
 260                     $default   !~ m/null/i
 261                 ) {
 262                     if ( $default =~ /^true$/i ) {
 263                         $default = "'1'";
 264                     }
 265                     elsif ( $default =~ /^false$/i ) {
 266                         $default = "'0'";
 267                     }
 268                     else {
 269                         $default = $default ? "'1'" : "'0'";
 270                     }
 271                 }
 272                 elsif (
 273                     $data_type =~ /date/ && (
 274                         $default eq 'current_timestamp'
 275                         ||
 276                         $default eq 'now()'
 277                     )
 278                 ) {
 279                     $default = 'SYSDATE';
 280                 }
 281                 else {
 282                     $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 283                 }
 284
 285                 $field_def .= " DEFAULT $default",
 286             }
 287
 288             #
 289             # Not null constraint
 290             #
 291             unless ( $field->is_nullable ) {
 292                 $field_def .= ' NOT NULL';
 293             }
 294
 295             $field_def .= " $check" if $check;
 296
 297             #
 298             # Auto_increment
 299             #
 300             if ( $field->is_auto_increment ) {
 301                 my $base_name    = $table_name . "_". $field_name;
 302                 my $seq_name     = mk_name( $base_name, 'sq' );
 303                 my $trigger_name = mk_name( $base_name, 'ai' );
 304
 305                 push @trigger_defs,
 306                     "CREATE SEQUENCE $seq_name;\n" .
 307                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 308                     "BEFORE INSERT ON $table_name_ur\n" .
 309                     "FOR EACH ROW WHEN (\n" .
 310                         " new.$field_name_ur IS NULL".
 311                         " OR new.$field_name_ur = 0\n".
 312                     ")\n".
 313                     "BEGIN\n" .
 314                         " SELECT $seq_name.nextval\n" .
 315                         " INTO :new." . $field->name."\n" .
 316                         " FROM dual;\n" .
 317                     "END;\n/";
 318                 ;
 319             }
 320
 321             if ( lc $field->data_type eq 'timestamp' ) {
 322                 my $base_name = $table_name . "_". $field_name_ur;
 323                 my $trig_name = mk_name( $base_name, 'ts' );
 324                 push @trigger_defs,
 325                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 326                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 327                     "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 328                     "BEGIN \n".
 329                     " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 330                     "END;\n/";
 331             }
 332
 333             push @field_defs, $field_def;
 334
 335             if ( my $comment = $field->comments ) {
 336                 push @field_comments,
 337                     "COMMENT ON COLUMN $table_name.$field_name_ur is\n  '".
 338                     $comment."';" unless $no_comments;
 339             }
 340         }
 341
 342         #
 343         # Table options
 344         #
 345         my @table_options;
 346         for my $opt ( $table->options ) {
 347             if ( ref $opt eq 'HASH' ) {
 348                 my ( $key, $value ) = each %$opt;
 349                 if ( ref $value eq 'ARRAY' ) {
 350                     push @table_options, "$key\n(\n".  join ("\n",
 351                         map { "  $_->[0]\t$_->[1]" }
 352                         map { [ each %$_ ] }
 353                         @$value
 354                     )."\n)";
 355                 }
 356                 elsif ( !defined $value ) {
 357                     push @table_options, $key;
 358                 }
 359                 else {
 360                     push @table_options, "$key    $value";
 361                 }
 362             }
 363         }
 364
 365         #
 366         # Table constraints
 367         #
 368         for my $c ( $table->get_constraints ) {
 369             my $name    = $c->name || '';
 370             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 371             my @rfields = map { unreserve( $_, $table_name ) }
 372                 $c->reference_fields;
 373             next if !@fields && $c->type ne CHECK_C;
 374
 375             if ( $c->type eq PRIMARY_KEY ) {
 376                 $name ||= mk_name( $table_name, 'pk' );
 377                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 378                     '(' . join( ', ', @fields ) . ')';
 379             }
 380             elsif ( $c->type eq UNIQUE ) {
 381                 $name ||= mk_name( $table_name, 'u' );
 382                 for my $f ( $c->fields ) {
 383                     my $field_def = $table->get_field( $f ) or next;
 384                     my $dtype     = $translate{ $field_def->data_type } or next;
 385                     if ( $WARN && $dtype =~ /clob/i ) {
 386                         warn "Oracle will not allow UNIQUE constraints on " .
 387                              "CLOB field '" . $field_def->table->name . '.' .
 388                              $field_def->name . ".'\n"
 389                     }
 390                 }
 391                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 392                     '(' . join( ', ', @fields ) . ')';
 393             }
 394             elsif ( $c->type eq CHECK_C ) {
 395                 $name ||= mk_name( $table_name, 'ck' );
 396                 my $expression = $c->expression || '';
 397                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 398             }
 399             elsif ( $c->type eq FOREIGN_KEY ) {
 400                 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
 401                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 402
 403                 if ( @fields ) {
 404                     $def .= '(' . join( ', ', @fields ) . ')';
 405                 }
 406
 407                 my $ref_table = unreserve($c->reference_table);
 408
 409                 $def .= " REFERENCES $ref_table";
 410
 411                 if ( @rfields ) {
 412                     $def .= ' (' . join( ', ', @rfields ) . ')';
 413                 }
 414
 415                 if ( $c->match_type ) {
 416                     $def .= ' MATCH ' .
 417                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 418                 }
 419
 420                 if ( $c->on_delete ) {
 421                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 422                 }
 423
 424                 if ( $c->on_update ) {
 425                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 426                 }
 427
 428                 push @constraint_defs, $def;
 429             }
 430         }
 431
 432         #
 433         # Index Declarations
 434         #
 435         my @index_defs = ();
 436         for my $index ( $table->get_indices ) {
 437             my $index_name = $index->name || '';
 438             my $index_type = $index->type || NORMAL;
 439             my @fields     = map { unreserve( $_, $table_name ) }
 440                              $index->fields;
 441             next unless @fields;
 442
 443             if ( $index_type eq PRIMARY_KEY ) {
 444                 $index_name ||= mk_name( $table_name, 'pk' );
 445                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 446                     '(' . join( ', ', @fields ) . ')';
 447             }
 448             elsif ( $index_type eq NORMAL ) {
 449                 $index_name ||= mk_name( $table_name, $index_name || 'i' );
 450                 push @index_defs,
 451                     "CREATE INDEX $index_name on $table_name_ur (".
 452                         join( ', ', @fields ).
 453                     ");";
 454             }
 455             else {
 456                 warn "Unknown index type ($index_type) on table $table_name.\n"
 457                     if $WARN;
 458             }
 459         }
 460
 461         my $create_statement;
 462         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 463
 464         if ( my @table_comments = $table->comments ) {
 465             for my $comment ( @table_comments ) {
 466                 next unless $comment;
 467                 push @field_comments, "COMMENT ON TABLE $table_name is\n  '".
 468                     $comment."';" unless $no_comments
 469                 ;
 470             }
 471         }
 472
 473         my $table_options = @table_options
 474             ? "\n".join("\n", @table_options) : '';
 475         $create_statement .= "CREATE TABLE $table_name_ur (\n" .
 476             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 477             "\n)$table_options;"
 478         ;
 479
 480         $output .= join( "\n\n",
 481             @comments,
 482             $create_statement,
 483             @trigger_defs,
 484             @index_defs,
 485             @field_comments,
 486             ''
 487         );
 488     }
 489
 490     if ( $WARN ) {
 491         if ( %truncated ) {
 492             warn "Truncated " . keys( %truncated ) . " names:\n";
 493             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 494         }
 495
 496         if ( %unreserve ) {
 497             warn "Encounted " . keys( %unreserve ) .
 498                 " unsafe names in schema (reserved or invalid):\n";
 499             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 500         }
 501     }
 502
 503     return $output;
 504 }
 505
 506 # -------------------------------------------------------------------
 507 sub mk_name {
 508     my $basename      = shift || '';
 509     my $type          = shift || '';
 510        $type          = '' if $type =~ /^\d/;
 511     my $scope         = shift || '';
 512     my $critical      = shift || '';
 513     my $basename_orig = $basename;
 514     my $max_name      = $type
 515                         ? $max_id_length - (length($type) + 1)
 516                         : $max_id_length;
 517     $basename         = substr( $basename, 0, $max_name )
 518                         if length( $basename ) > $max_name;
 519     my $name          = $type ? "${type}_$basename" : $basename;
 520
 521     if ( $basename ne $basename_orig and $critical ) {
 522         my $show_type = $type ? "+'$type'" : "";
 523         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 524             "character limit to make '$name'\n" if $WARN;
 525         $truncated{ $basename_orig } = $name;
 526     }
 527
 528     $scope ||= \%global_names;
 529     if ( my $prev = $scope->{ $name } ) {
 530         my $name_orig = $name;
 531         $name        .= sprintf( "%02d", ++$prev );
 532         substr($name, $max_id_length - 3) = "00"
 533             if length( $name ) > $max_id_length;
 534
 535         warn "The name '$name_orig' has been changed to ",
 536              "'$name' to make it unique.\n" if $WARN;
 537
 538         $scope->{ $name_orig }++;
 539     }
 540
 541     $scope->{ $name }++;
 542     return $name;
 543 }
 544
 545 # -------------------------------------------------------------------
 546 sub unreserve {
 547     my $name            = shift || '';
 548     my $schema_obj_name = shift || '';
 549
 550     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 551
 552     # also trap fields that don't begin with a letter
 553     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 554
 555     if ( $schema_obj_name ) {
 556         ++$unreserve{"$schema_obj_name.$name"};
 557     }
 558     else {
 559         ++$unreserve{"$name (table name)"};
 560     }
 561
 562     my $unreserve = sprintf '%s_', $name;
 563     return $unreserve.$suffix;
 564 }
 565
 566 1;
 567
 568 # -------------------------------------------------------------------
 569 # All bad art is the result of good intentions.
 570 # Oscar Wilde
 571 # -------------------------------------------------------------------
 572
 573 =pod
 574
 575 =head1 CREDITS
 576
 577 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 578 script.
 579
 580 =head1 AUTHOR
 581
 582 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 583
 584 =head1 SEE ALSO
 585
 586 SQL::Translator, DDL::Oracle, mysql2ora.
 587
 588 =cut