lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.28 2003-11-05 22:27:55 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.28 $ =~ /(\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/ && $default eq 'current_timestamp'
 274                 ) {
 275                     $default = 'SYSDATE';
 276                 }
 277                 else {
 278                     $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 279                 }
 280
 281                 $field_def .= " DEFAULT $default",
 282             }
 283
 284             #
 285             # Not null constraint
 286             #
 287             unless ( $field->is_nullable ) {
 288 #                my $constraint_name = mk_name(
 289 #                    join('_', $table_name_ur, $field_name_ur ), 'nn'
 290 #                );
 291 #                $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
 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\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                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 383                     '(' . join( ', ', @fields ) . ')';
 384             }
 385             elsif ( $c->type eq CHECK_C ) {
 386                 $name ||= mk_name( $table_name, 'ck' );
 387                 my $expression = $c->expression || '';
 388                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 389             }
 390             elsif ( $c->type eq FOREIGN_KEY ) {
 391                 $name ||= mk_name( join('_', $table_name, $c->fields), 'fk' );
 392                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 393
 394                 if ( @fields ) {
 395                     $def .= '(' . join( ', ', @fields ) . ')';
 396                 }
 397
 398                 my $ref_table = unreserve($c->reference_table);
 399
 400                 $def .= " REFERENCES $ref_table";
 401
 402                 if ( @rfields ) {
 403                     $def .= ' (' . join( ', ', @rfields ) . ')';
 404                 }
 405
 406                 if ( $c->match_type ) {
 407                     $def .= ' MATCH ' .
 408                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 409                 }
 410
 411                 if ( $c->on_delete ) {
 412                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 413                 }
 414
 415                 if ( $c->on_update ) {
 416                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 417                 }
 418
 419                 push @constraint_defs, $def;
 420             }
 421         }
 422
 423         #
 424         # Index Declarations
 425         #
 426         my @index_defs = ();
 427         for my $index ( $table->get_indices ) {
 428             my $index_name = $index->name || '';
 429             my $index_type = $index->type || NORMAL;
 430             my @fields     = map { unreserve( $_, $table_name ) }
 431                              $index->fields;
 432             next unless @fields;
 433
 434             if ( $index_type eq PRIMARY_KEY ) {
 435                 $index_name ||= mk_name( $table_name, 'pk' );
 436                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 437                     '(' . join( ', ', @fields ) . ')';
 438             }
 439             elsif ( $index_type eq NORMAL ) {
 440                 $index_name ||= mk_name( $table_name, $index_name || 'i' );
 441                 push @index_defs,
 442                     "CREATE INDEX $index_name on $table_name_ur (".
 443                         join( ', ', @fields ).
 444                     ");";
 445             }
 446             else {
 447                 warn "Unknown index type ($index_type) on table $table_name.\n"
 448                     if $WARN;
 449             }
 450         }
 451
 452         my $create_statement;
 453         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 454
 455         if ( my @table_comments = $table->comments ) {
 456             for my $comment ( @table_comments ) {
 457                 next unless $comment;
 458                 push @field_comments, "COMMENT ON TABLE $table_name is\n  '".
 459                     $comment."';" unless $no_comments
 460                 ;
 461             }
 462         }
 463
 464         my $table_options = @table_options
 465             ? "\n".join("\n", @table_options) : '';
 466         $create_statement .= "CREATE TABLE $table_name_ur (\n" .
 467             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 468             "\n)$table_options;"
 469         ;
 470
 471         $output .= join( "\n\n",
 472             @comments,
 473             $create_statement,
 474             @trigger_defs,
 475             @index_defs,
 476             @field_comments,
 477             ''
 478         );
 479     }
 480
 481     if ( $WARN ) {
 482         if ( %truncated ) {
 483             warn "Truncated " . keys( %truncated ) . " names:\n";
 484             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 485         }
 486
 487         if ( %unreserve ) {
 488             warn "Encounted " . keys( %unreserve ) .
 489                 " unsafe names in schema (reserved or invalid):\n";
 490             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 491         }
 492     }
 493
 494     return $output;
 495 }
 496
 497 # -------------------------------------------------------------------
 498 sub mk_name {
 499     my $basename      = shift || '';
 500     my $type          = shift || '';
 501        $type          = '' if $type =~ /^\d/;
 502     my $scope         = shift || '';
 503     my $critical      = shift || '';
 504     my $basename_orig = $basename;
 505     my $max_name      = $type
 506                         ? $max_id_length - (length($type) + 1)
 507                         : $max_id_length;
 508     $basename         = substr( $basename, 0, $max_name )
 509                         if length( $basename ) > $max_name;
 510     my $name          = $type ? "${type}_$basename" : $basename;
 511
 512     if ( $basename ne $basename_orig and $critical ) {
 513         my $show_type = $type ? "+'$type'" : "";
 514         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 515             "character limit to make '$name'\n" if $WARN;
 516         $truncated{ $basename_orig } = $name;
 517     }
 518
 519     $scope ||= \%global_names;
 520     if ( my $prev = $scope->{ $name } ) {
 521         my $name_orig = $name;
 522         $name        .= sprintf( "%02d", ++$prev );
 523         substr($name, $max_id_length - 3) = "00"
 524             if length( $name ) > $max_id_length;
 525
 526         warn "The name '$name_orig' has been changed to ",
 527              "'$name' to make it unique.\n" if $WARN;
 528
 529         $scope->{ $name_orig }++;
 530     }
 531
 532     $scope->{ $name }++;
 533     return $name;
 534 }
 535
 536 # -------------------------------------------------------------------
 537 sub unreserve {
 538     my $name            = shift || '';
 539     my $schema_obj_name = shift || '';
 540
 541     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 542
 543     # also trap fields that don't begin with a letter
 544     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 545
 546     if ( $schema_obj_name ) {
 547         ++$unreserve{"$schema_obj_name.$name"};
 548     }
 549     else {
 550         ++$unreserve{"$name (table name)"};
 551     }
 552
 553     my $unreserve = sprintf '%s_', $name;
 554     return $unreserve.$suffix;
 555 }
 556
 557 1;
 558
 559 # -------------------------------------------------------------------
 560 # All bad art is the result of good intentions.
 561 # Oscar Wilde
 562 # -------------------------------------------------------------------
 563
 564 =pod
 565
 566 =head1 CREDITS
 567
 568 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 569 script.
 570
 571 =head1 AUTHOR
 572
 573 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 574
 575 =head1 SEE ALSO
 576
 577 SQL::Translator, DDL::Oracle, mysql2ora.
 578
 579 =cut