lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.32 2004-12-20 17:18:42 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.32 $ =~ /(\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                 $comment =~ s/'/''/g;
 335                 push @field_comments,
 336                     "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
 337                     $comment . "';" unless $no_comments;
 338             }
 339         }
 340
 341         #
 342         # Table options
 343         #
 344         my @table_options;
 345         for my $opt ( $table->options ) {
 346             if ( ref $opt eq 'HASH' ) {
 347                 my ( $key, $value ) = each %$opt;
 348                 if ( ref $value eq 'ARRAY' ) {
 349                     push @table_options, "$key\n(\n".  join ("\n",
 350                         map { "  $_->[0]\t$_->[1]" }
 351                         map { [ each %$_ ] }
 352                         @$value
 353                     )."\n)";
 354                 }
 355                 elsif ( !defined $value ) {
 356                     push @table_options, $key;
 357                 }
 358                 else {
 359                     push @table_options, "$key    $value";
 360                 }
 361             }
 362         }
 363
 364         #
 365         # Table constraints
 366         #
 367         for my $c ( $table->get_constraints ) {
 368             my $name    = $c->name || '';
 369             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 370             my @rfields = map { unreserve( $_, $table_name ) }
 371                 $c->reference_fields;
 372             next if !@fields && $c->type ne CHECK_C;
 373
 374             if ( $c->type eq PRIMARY_KEY ) {
 375                 $name ||= mk_name( $table_name, 'pk' );
 376                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 377                     '(' . join( ', ', @fields ) . ')';
 378             }
 379             elsif ( $c->type eq UNIQUE ) {
 380                 $name = mk_name( $name || $table_name, 'u' );
 381
 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
 392                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 393                     '(' . join( ', ', @fields ) . ')';
 394             }
 395             elsif ( $c->type eq CHECK_C ) {
 396                 $name = mk_name( $name || $table_name, 'ck' );
 397                 my $expression = $c->expression || '';
 398                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 399             }
 400             elsif ( $c->type eq FOREIGN_KEY ) {
 401                 $name = mk_name( join('_', $table_name, $c->fields), 'fk' );
 402                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 403
 404                 if ( @fields ) {
 405                     $def .= '(' . join( ', ', @fields ) . ')';
 406                 }
 407
 408                 my $ref_table = unreserve($c->reference_table);
 409
 410                 $def .= " REFERENCES $ref_table";
 411
 412                 if ( @rfields ) {
 413                     $def .= ' (' . join( ', ', @rfields ) . ')';
 414                 }
 415
 416                 if ( $c->match_type ) {
 417                     $def .= ' MATCH ' .
 418                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 419                 }
 420
 421                 if ( $c->on_delete ) {
 422                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 423                 }
 424
 425                 if ( $c->on_update ) {
 426                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 427                 }
 428
 429                 push @constraint_defs, $def;
 430             }
 431         }
 432
 433         #
 434         # Index Declarations
 435         #
 436         my @index_defs = ();
 437         for my $index ( $table->get_indices ) {
 438             my $index_name = $index->name || '';
 439             my $index_type = $index->type || NORMAL;
 440             my @fields     = map { unreserve( $_, $table_name ) }
 441                              $index->fields;
 442             next unless @fields;
 443
 444             if ( $index_type eq PRIMARY_KEY ) {
 445                 $index_name = $index_name ? mk_name( $index_name )
 446                     : mk_name( $table_name, 'pk' );
 447                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 448                     '(' . join( ', ', @fields ) . ')';
 449             }
 450             elsif ( $index_type eq NORMAL ) {
 451                 $index_name = $index_name ? mk_name( $index_name )
 452                     : mk_name( $table_name, $index_name || 'i' );
 453                 push @index_defs,
 454                     "CREATE INDEX $index_name on $table_name_ur (".
 455                         join( ', ', @fields ).
 456                     ");";
 457             }
 458             else {
 459                 warn "Unknown index type ($index_type) on table $table_name.\n"
 460                     if $WARN;
 461             }
 462         }
 463
 464         my $create_statement;
 465         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 466
 467         if ( my @table_comments = $table->comments ) {
 468             for my $comment ( @table_comments ) {
 469                 next unless $comment;
 470                 $comment =~ s/'/''/g;
 471                 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
 472                     $comment . "';" unless $no_comments
 473                 ;
 474             }
 475         }
 476
 477         my $table_options = @table_options
 478             ? "\n".join("\n", @table_options) : '';
 479         $create_statement .= "CREATE TABLE $table_name_ur (\n" .
 480             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 481             "\n)$table_options;"
 482         ;
 483
 484         $output .= join( "\n\n",
 485             @comments,
 486             $create_statement,
 487             @trigger_defs,
 488             @index_defs,
 489             @field_comments,
 490             ''
 491         );
 492     }
 493
 494     if ( $WARN ) {
 495         if ( %truncated ) {
 496             warn "Truncated " . keys( %truncated ) . " names:\n";
 497             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 498         }
 499
 500         if ( %unreserve ) {
 501             warn "Encounted " . keys( %unreserve ) .
 502                 " unsafe names in schema (reserved or invalid):\n";
 503             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 504         }
 505     }
 506
 507     return $output;
 508 }
 509
 510 # -------------------------------------------------------------------
 511 sub mk_name {
 512     my $basename      = shift || '';
 513     my $type          = shift || '';
 514        $type          = '' if $type =~ /^\d/;
 515     my $scope         = shift || '';
 516     my $critical      = shift || '';
 517     my $basename_orig = $basename;
 518     my $max_name      = $type
 519                         ? $max_id_length - (length($type) + 1)
 520                         : $max_id_length;
 521     $basename         = substr( $basename, 0, $max_name )
 522                         if length( $basename ) > $max_name;
 523     my $name          = $type ? "${type}_$basename" : $basename;
 524
 525     if ( $basename ne $basename_orig and $critical ) {
 526         my $show_type = $type ? "+'$type'" : "";
 527         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 528             "character limit to make '$name'\n" if $WARN;
 529         $truncated{ $basename_orig } = $name;
 530     }
 531
 532     $scope ||= \%global_names;
 533     if ( my $prev = $scope->{ $name } ) {
 534         my $name_orig = $name;
 535         $name        .= sprintf( "%02d", ++$prev );
 536         substr($name, $max_id_length - 2) = ""
 537             if length( $name ) >= $max_id_length - 1;
 538         $name        .= sprintf( "%02d", $prev++ );
 539
 540         warn "The name '$name_orig' has been changed to ",
 541              "'$name' to make it unique.\n" if $WARN;
 542
 543         $scope->{ $name_orig }++;
 544     }
 545
 546     $scope->{ $name }++;
 547     return $name;
 548 }
 549
 550 # -------------------------------------------------------------------
 551 sub unreserve {
 552     my $name            = shift || '';
 553     my $schema_obj_name = shift || '';
 554
 555     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 556
 557     # also trap fields that don't begin with a letter
 558     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 559
 560     if ( $schema_obj_name ) {
 561         ++$unreserve{"$schema_obj_name.$name"};
 562     }
 563     else {
 564         ++$unreserve{"$name (table name)"};
 565     }
 566
 567     my $unreserve = sprintf '%s_', $name;
 568     return $unreserve.$suffix;
 569 }
 570
 571 1;
 572
 573 # -------------------------------------------------------------------
 574 # All bad art is the result of good intentions.
 575 # Oscar Wilde
 576 # -------------------------------------------------------------------
 577
 578 =pod
 579
 580 =head1 CREDITS
 581
 582 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 583 script.
 584
 585 =head1 AUTHOR
 586
 587 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 588
 589 =head1 SEE ALSO
 590
 591 SQL::Translator, DDL::Oracle, mysql2ora.
 592
 593 =cut