lib/SQL/Translator/Producer/Oracle.pm

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