lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.21 2003-08-19 14:44:00 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 use strict;
  26 use vars qw[ $VERSION $DEBUG $WARN ];
  27 $VERSION = sprintf "%d.%02d", q$Revision: 1.21 $ =~ /(\d+)\.(\d+)/;
  28 $DEBUG   = 0 unless defined $DEBUG;
  29
  30 use SQL::Translator::Schema::Constants;
  31 use SQL::Translator::Utils qw(header_comment);
  32
  33 my %translate  = (
  34     #
  35     # MySQL types
  36     #
  37     bigint     => 'number',
  38     double     => 'number',
  39     decimal    => 'number',
  40     float      => 'number',
  41     int        => 'number',
  42     integer    => 'number',
  43     mediumint  => 'number',
  44     smallint   => 'number',
  45     tinyint    => 'number',
  46     char       => 'char',
  47     varchar    => 'varchar2',
  48     tinyblob   => 'blob',
  49     blob       => 'blob',
  50     mediumblob => 'blob',
  51     longblob   => 'blob',
  52     tinytext   => 'varchar2',
  53     text       => 'clob',
  54     longtext   => 'clob',
  55     mediumtext => 'clob',
  56     enum       => 'varchar2',
  57     set        => 'varchar2',
  58     date       => 'date',
  59     datetime   => 'date',
  60     time       => 'date',
  61     timestamp  => 'date',
  62     year       => 'date',
  63
  64     #
  65     # PostgreSQL types
  66     #
  67     numeric             => 'number',
  68     'double precision'  => 'number',
  69     serial              => 'number',
  70     bigserial           => 'number',
  71     money               => 'number',
  72     character           => 'char',
  73     'character varying' => 'varchar2',
  74     bytea               => 'BLOB',
  75     interval            => 'number',
  76     boolean             => 'number',
  77     point               => 'number',
  78     line                => 'number',
  79     lseg                => 'number',
  80     box                 => 'number',
  81     path                => 'number',
  82     polygon             => 'number',
  83     circle              => 'number',
  84     cidr                => 'number',
  85     inet                => 'varchar2',
  86     macaddr             => 'varchar2',
  87     bit                 => 'number',
  88     'bit varying'       => 'number',
  89 );
  90
  91 #
  92 # Oracle reserved words from:
  93 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
  94 # 817_doc/server.817/a85397/ap_keywd.htm
  95 #
  96 my %ora_reserved = map { $_, 1 } qw(
  97     ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
  98     BETWEEN BY
  99     CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
 100     DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
 101     ELSE EXCLUSIVE EXISTS
 102     FILE FLOAT FOR FROM
 103     GRANT GROUP
 104     HAVING
 105     IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
 106     INTEGER INTERSECT INTO IS
 107     LEVEL LIKE LOCK LONG
 108     MAXEXTENTS MINUS MLSLABEL MODE MODIFY
 109     NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
 110     OF OFFLINE ON ONLINE OPTION OR ORDER
 111     PCTFREE PRIOR PRIVILEGES PUBLIC
 112     RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
 113     SELECT SESSION SET SHARE SIZE SMALLINT START
 114     SUCCESSFUL SYNONYM SYSDATE
 115     TABLE THEN TO TRIGGER
 116     UID UNION UNIQUE UPDATE USER
 117     VALIDATE VALUES VARCHAR VARCHAR2 VIEW
 118     WHENEVER WHERE WITH
 119 );
 120
 121 my $max_id_length    = 30;
 122 my %used_identifiers = ();
 123 my %global_names;
 124 my %unreserve;
 125 my %truncated;
 126
 127 # -------------------------------------------------------------------
 128 sub produce {
 129     my $translator     = shift;
 130     $DEBUG             = $translator->debug;
 131     $WARN              = $translator->show_warnings;
 132     my $no_comments    = $translator->no_comments;
 133     my $add_drop_table = $translator->add_drop_table;
 134     my $schema         = $translator->schema;
 135     my $output;
 136
 137     $output .= header_comment unless ($no_comments);
 138
 139     if ( $translator->parser_type =~ /mysql/i ) {
 140         $output .=
 141         "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 142         "-- but we set it here anyway to be self-consistent.\n".
 143         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 144     }
 145
 146     #
 147     # Print create for each table
 148     #
 149     for my $table ( $schema->get_tables ) {
 150         my $table_name    = $table->name or next;
 151         $table_name       = mk_name( $table_name, '', undef, 1 );
 152         my $table_name_ur = unreserve($table_name) or next;
 153
 154         my ( @comments, @field_defs, @trigger_defs, @constraint_defs );
 155
 156         push @comments, "--\n-- Table: $table_name_ur\n--" unless $no_comments;
 157
 158         my ( %field_name_scope, @field_comments );
 159         for my $field ( $table->get_fields ) {
 160             #
 161             # Field name
 162             #
 163             my $field_name    = mk_name(
 164                 $field->name, '', \%field_name_scope, 1
 165             );
 166             my $field_name_ur = unreserve( $field_name, $table_name );
 167             my $field_def     = $field_name_ur;
 168
 169             #
 170             # Datatype
 171             #
 172             my $check;
 173             my $data_type = lc $field->data_type;
 174             my @size      = $field->size;
 175             my %extra     = $field->extra;
 176             my $list      = $extra{'list'} || [];
 177             # \todo deal with embedded quotes
 178             my $commalist = join( ', ', map { qq['$_'] } @$list );
 179
 180             if ( $data_type eq 'enum' ) {
 181                 $check = "CHECK ($field_name_ur IN ($commalist))";
 182                 $data_type = 'varchar2';
 183             }
 184             elsif ( $data_type eq 'set' ) {
 185                 # XXX add a CHECK constraint maybe
 186                 # (trickier and slower, than enum :)
 187                 $data_type = 'varchar2';
 188             }
 189             else {
 190                 $data_type  = defined $translate{ $data_type } ?
 191                               $translate{ $data_type } :
 192                               die "Unknown datatype: $data_type\n";
 193             }
 194
 195             #
 196             # Fixes ORA-02329: column of datatype LOB cannot be
 197             # unique or a primary key
 198             #
 199             if ( $data_type eq 'clob' && $field->is_primary_key ) {
 200                 $data_type = 'varchar2';
 201                 $size[0]   = 4000;
 202                 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 203                     if $WARN;
 204             }
 205
 206             #
 207             # Fixes ORA-00907: missing right parenthesis
 208             #
 209             if ( $data_type =~ /(date|clob)/i ) {
 210                 undef @size;
 211             }
 212
 213             $field_def .= " $data_type";
 214             if ( defined $size[0] && $size[0] > 0 ) {
 215                 $field_def .= '(' . join( ', ', @size ) . ')';
 216             }
 217
 218             #
 219             # Default value
 220             #
 221             my $default = $field->default_value;
 222             if ( defined $default ) {
 223                 $field_def .= sprintf(
 224                     ' DEFAULT %s',
 225                     $default =~ m/null/i ? 'NULL' : "'$default'"
 226                 );
 227             }
 228
 229             #
 230             # Not null constraint
 231             #
 232             unless ( $field->is_nullable ) {
 233                 my $constraint_name = mk_name($field_name_ur, 'nn');
 234                 $field_def .= ' CONSTRAINT ' . $constraint_name . ' NOT NULL';
 235             }
 236
 237             $field_def .= " $check" if $check;
 238
 239             #
 240             # Auto_increment
 241             #
 242             if ( $field->is_auto_increment ) {
 243                 my $base_name    = $table_name . "_". $field_name;
 244                 my $seq_name     = mk_name( $base_name, 'sq' );
 245                 my $trigger_name = mk_name( $base_name, 'ai' );
 246
 247                 push @trigger_defs,
 248                     "CREATE SEQUENCE $seq_name;\n" .
 249                     "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 250                     "BEFORE INSERT ON $table_name\n" .
 251                     "FOR EACH ROW WHEN (\n" .
 252                         " new.$field_name_ur IS NULL".
 253                         " OR new.$field_name_ur = 0\n".
 254                     ")\n".
 255                     "BEGIN\n" .
 256                         " SELECT $seq_name.nextval\n" .
 257                         " INTO :new." . $field->name."\n" .
 258                         " FROM dual;\n" .
 259                     "END;\n/";
 260                 ;
 261             }
 262
 263             if ( lc $field->data_type eq 'timestamp' ) {
 264                 my $base_name = $table_name . "_". $field_name_ur;
 265                 my $trig_name = mk_name( $base_name, 'ts' );
 266                 push @trigger_defs,
 267                     "CREATE OR REPLACE TRIGGER $trig_name\n".
 268                     "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 269                     "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 270                     "BEGIN \n".
 271                     " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 272                     "END;\n/";
 273             }
 274
 275             push @field_defs, $field_def;
 276
 277             if ( my $comment = $field->comments ) {
 278                 push @field_comments,
 279                     "COMMENT ON COLUMN $table_name.$field_name_ur is\n  '".
 280                     $comment."';";
 281             }
 282         }
 283
 284         #
 285         # Table constraints
 286         #
 287         my $constraint_name_default;
 288         for my $c ( $table->get_constraints ) {
 289             my $name    = $c->name || '';
 290             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 291             my @rfields = map { unreserve( $_, $table_name ) }
 292                 $c->reference_fields;
 293             next unless @fields;
 294
 295             if ( $c->type eq PRIMARY_KEY ) {
 296                 $name ||= mk_name( $table_name, 'pk' );
 297                 push @constraint_defs, "CONSTRAINT $name PRIMARY KEY ".
 298                     '(' . join( ', ', @fields ) . ')';
 299             }
 300             elsif ( $c->type eq UNIQUE ) {
 301                 $name ||= mk_name( $table_name, ++$constraint_name_default );
 302                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 303                     '(' . join( ', ', @fields ) . ')';
 304             }
 305             elsif ( $c->type eq FOREIGN_KEY ) {
 306                 $name ||= mk_name( $table_name, ++$constraint_name_default );
 307                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 308
 309                 if ( @fields ) {
 310                     $def .= join( ', ', @fields );
 311                 }
 312
 313                 $def .= ' REFERENCES ' . $c->reference_table;
 314
 315                 if ( @rfields ) {
 316                     $def .= ' (' . join( ', ', @rfields ) . ')';
 317                 }
 318
 319                 if ( $c->match_type ) {
 320                     $def .= ' MATCH ' .
 321                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 322                 }
 323
 324                 if ( $c->on_delete ) {
 325                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 326                 }
 327
 328                 if ( $c->on_update ) {
 329                     $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 330                 }
 331
 332                 push @constraint_defs, $def;
 333             }
 334         }
 335
 336         #
 337         # Index Declarations
 338         #
 339         my @index_defs = ();
 340         my $idx_name_default;
 341         for my $index ( $table->get_indices ) {
 342             my $index_name = $index->name || '';
 343             my $index_type = $index->type || NORMAL;
 344             my @fields     = map { unreserve( $_, $table_name ) }
 345                              $index->fields;
 346             next unless @fields;
 347
 348             if ( $index_type eq PRIMARY_KEY ) {
 349                 $index_name = mk_name( $table_name, 'pk' );
 350                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 351                     '(' . join( ', ', @fields ) . ')';
 352             }
 353             elsif ( $index_type eq UNIQUE ) {
 354                 $index_name = mk_name(
 355                     $table_name, $index_name || ++$idx_name_default
 356                 );
 357                 push @field_defs, 'CONSTRAINT ' . $index_name . ' UNIQUE ' .
 358                     '(' . join( ', ', @fields ) . ')';
 359             }
 360
 361             elsif ( $index_type eq NORMAL ) {
 362                 $index_name = mk_name(
 363                     $table_name, $index_name || ++$idx_name_default
 364                 );
 365                 push @index_defs,
 366                     "CREATE INDEX $index_name on $table_name_ur (".
 367                         join( ', ', @fields ).
 368                     ");";
 369             }
 370             else {
 371                 warn "Unknown index type ($index_type) on table $table_name.\n"
 372                     if $WARN;
 373             }
 374         }
 375
 376         my $create_statement;
 377         $create_statement  = "DROP TABLE $table_name_ur;\n" if $add_drop_table;
 378
 379         if ( my @table_comments = $table->comments ) {
 380             for my $comment ( @table_comments ) {
 381                 next unless $comment;
 382                 push @field_comments, "COMMENT ON TABLE $table_name is\n  '".
 383                     $comment."';"
 384                 ;
 385             }
 386         }
 387
 388         $create_statement .= "CREATE TABLE $table_name_ur (\n" .
 389             join( ",\n", map { "  $_" } @field_defs, @constraint_defs ) .
 390             "\n);"
 391         ;
 392
 393         $output .= join( "\n\n",
 394             @comments,
 395             $create_statement,
 396             @trigger_defs,
 397             @index_defs,
 398             @field_comments,
 399             ''
 400         );
 401     }
 402
 403     if ( $WARN ) {
 404         if ( %truncated ) {
 405             warn "Truncated " . keys( %truncated ) . " names:\n";
 406             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 407         }
 408
 409         if ( %unreserve ) {
 410             warn "Encounted " . keys( %unreserve ) .
 411                 " unsafe names in schema (reserved or invalid):\n";
 412             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 413         }
 414     }
 415
 416     return $output;
 417 }
 418
 419 # -------------------------------------------------------------------
 420 sub mk_name {
 421     my $basename      = shift || '';
 422     my $type          = shift || '';
 423     my $scope         = shift || '';
 424     my $critical      = shift || '';
 425     my $basename_orig = $basename;
 426     my $max_name      = $type
 427                         ? $max_id_length - (length($type) + 1)
 428                         : $max_id_length;
 429     $basename         = substr( $basename, 0, $max_name )
 430                         if length( $basename ) > $max_name;
 431     my $name          = $type ? "${type}_$basename" : $basename;
 432
 433     if ( $basename ne $basename_orig and $critical ) {
 434         my $show_type = $type ? "+'$type'" : "";
 435         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 436             "character limit to make '$name'\n" if $WARN;
 437         $truncated{ $basename_orig } = $name;
 438     }
 439
 440     $scope ||= \%global_names;
 441     if ( my $prev = $scope->{ $name } ) {
 442         my $name_orig = $name;
 443         $name        .= sprintf( "%02d", ++$prev );
 444         substr($name, $max_id_length - 3) = "00"
 445             if length( $name ) > $max_id_length;
 446
 447         warn "The name '$name_orig' has been changed to ",
 448              "'$name' to make it unique.\n" if $WARN;
 449
 450         $scope->{ $name_orig }++;
 451     }
 452
 453     $scope->{ $name }++;
 454     return $name;
 455 }
 456
 457 # -------------------------------------------------------------------
 458 sub unreserve {
 459     my $name            = shift || '';
 460     my $schema_obj_name = shift || '';
 461
 462     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 463
 464     # also trap fields that don't begin with a letter
 465     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 466
 467     if ( $schema_obj_name ) {
 468         ++$unreserve{"$schema_obj_name.$name"};
 469     }
 470     else {
 471         ++$unreserve{"$name (table name)"};
 472     }
 473
 474     my $unreserve = sprintf '%s_', $name;
 475     return $unreserve.$suffix;
 476 }
 477
 478 1;
 479
 480 # -------------------------------------------------------------------
 481 # All bad art is the result of good intentions.
 482 # Oscar Wilde
 483 # -------------------------------------------------------------------
 484
 485 =head1 NAME
 486
 487 SQL::Translator::Producer::Oracle - Oracle SQL producer
 488
 489 =head1 SYNOPSIS
 490
 491   use SQL::Translator::Parser::MySQL;
 492   use SQL::Translator::Producer::Oracle;
 493
 494   my $original_create = ""; # get this from somewhere...
 495   my $translator = SQL::Translator->new;
 496
 497   $translator->parser("SQL::Translator::Parser::MySQL");
 498   $translator->producer("SQL::Translator::Producer::Oracle");
 499
 500   my $new_create = $translator->translate($original_create);
 501
 502 =head1 DESCRIPTION
 503
 504 SQL::Translator::Producer::Oracle takes a parsed data structure,
 505 created by a SQL::Translator::Parser subclass, and turns it into a
 506 create string suitable for use with an Oracle database.
 507
 508 =head1 CREDITS
 509
 510 A hearty "thank-you" to Tim Bunce for much of the logic stolen from
 511 his "mysql2ora" script.
 512
 513 =head1 AUTHOR
 514
 515 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>
 516
 517 =head1 SEE ALSO
 518
 519 perl(1).
 520
 521 =cut