lib/SQL/Translator/Producer/Oracle.pm

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