lib/SQL/Translator/Producer/Oracle.pm

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