lib/SQL/Translator/Producer/Oracle.pm

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