lib/SQL/Translator/Producer/Oracle.pm

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