lib/SQL/Translator/Producer/Oracle.pm

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