lib/SQL/Translator/Producer/Oracle.pm

   1 package SQL::Translator::Producer::Oracle;
   2
   3 # -------------------------------------------------------------------
   4 # $Id: Oracle.pm,v 1.34 2005-08-10 16:33:39 duality72 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 =head1 producer_args
  39
  40 =over
  41
  42 =item delay_constraints
  43
  44 This option remove the primary key and other key constraints from the
  45 CREATE TABLE statement and adds ALTER TABLEs at the end with it.
  46
  47 =back
  48
  49 =cut
  50
  51 use strict;
  52 use vars qw[ $VERSION $DEBUG $WARN ];
  53 $VERSION = sprintf "%d.%02d", q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/;
  54 $DEBUG   = 0 unless defined $DEBUG;
  55
  56 use SQL::Translator::Schema::Constants;
  57 use SQL::Translator::Utils qw(header_comment);
  58
  59 my %translate  = (
  60     #
  61     # MySQL types
  62     #
  63     bigint     => 'number',
  64     double     => 'number',
  65     decimal    => 'number',
  66     float      => 'number',
  67     int        => 'number',
  68     integer    => 'number',
  69     mediumint  => 'number',
  70     smallint   => 'number',
  71     tinyint    => 'number',
  72     char       => 'char',
  73     varchar    => 'varchar2',
  74     tinyblob   => 'blob',
  75     blob       => 'blob',
  76     mediumblob => 'blob',
  77     longblob   => 'blob',
  78     tinytext   => 'varchar2',
  79     text       => 'clob',
  80     longtext   => 'clob',
  81     mediumtext => 'clob',
  82     enum       => 'varchar2',
  83     set        => 'varchar2',
  84     date       => 'date',
  85     datetime   => 'date',
  86     time       => 'date',
  87     timestamp  => 'date',
  88     year       => 'date',
  89
  90     #
  91     # PostgreSQL types
  92     #
  93     numeric             => 'number',
  94     'double precision'  => 'number',
  95     serial              => 'number',
  96     bigserial           => 'number',
  97     money               => 'number',
  98     character           => 'char',
  99     'character varying' => 'varchar2',
 100     bytea               => 'BLOB',
 101     interval            => 'number',
 102     boolean             => 'number',
 103     point               => 'number',
 104     line                => 'number',
 105     lseg                => 'number',
 106     box                 => 'number',
 107     path                => 'number',
 108     polygon             => 'number',
 109     circle              => 'number',
 110     cidr                => 'number',
 111     inet                => 'varchar2',
 112     macaddr             => 'varchar2',
 113     bit                 => 'number',
 114     'bit varying'       => 'number',
 115
 116     #
 117     # Oracle types
 118     #
 119     number              => 'number',
 120     varchar2            => 'varchar2',
 121     long                => 'clob',
 122 );
 123
 124 #
 125 # Oracle reserved words from:
 126 # http://technet.oracle.com/docs/products/oracle8i/doc_library/\
 127 # 817_doc/server.817/a85397/ap_keywd.htm
 128 #
 129 my %ora_reserved = map { $_, 1 } qw(
 130     ACCESS ADD ALL ALTER AND ANY AS ASC AUDIT
 131     BETWEEN BY
 132     CHAR CHECK CLUSTER COLUMN COMMENT COMPRESS CONNECT CREATE CURRENT
 133     DATE DECIMAL DEFAULT DELETE DESC DISTINCT DROP
 134     ELSE EXCLUSIVE EXISTS
 135     FILE FLOAT FOR FROM
 136     GRANT GROUP
 137     HAVING
 138     IDENTIFIED IMMEDIATE IN INCREMENT INDEX INITIAL INSERT
 139     INTEGER INTERSECT INTO IS
 140     LEVEL LIKE LOCK LONG
 141     MAXEXTENTS MINUS MLSLABEL MODE MODIFY
 142     NOAUDIT NOCOMPRESS NOT NOWAIT NULL NUMBER
 143     OF OFFLINE ON ONLINE OPTION OR ORDER
 144     PCTFREE PRIOR PRIVILEGES PUBLIC
 145     RAW RENAME RESOURCE REVOKE ROW ROWID ROWNUM ROWS
 146     SELECT SESSION SET SHARE SIZE SMALLINT START
 147     SUCCESSFUL SYNONYM SYSDATE
 148     TABLE THEN TO TRIGGER
 149     UID UNION UNIQUE UPDATE USER
 150     VALIDATE VALUES VARCHAR VARCHAR2 VIEW
 151     WHENEVER WHERE WITH
 152 );
 153
 154 my $max_id_length    = 30;
 155 my %used_identifiers = ();
 156 my %global_names;
 157 my %unreserve;
 158 my %truncated;
 159
 160 # -------------------------------------------------------------------
 161 sub produce {
 162     my $translator     = shift;
 163     $DEBUG             = $translator->debug;
 164     $WARN              = $translator->show_warnings || 0;
 165     my $no_comments    = $translator->no_comments;
 166     my $add_drop_table = $translator->add_drop_table;
 167     my $schema         = $translator->schema;
 168     my $delay_constraints = $translator->producer_args->{delay_constraints};
 169     my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
 170
 171     $create .= header_comment unless ($no_comments);
 172
 173     if ( $translator->parser_type =~ /mysql/i ) {
 174         $create .=
 175             "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 176             "-- but we set it here anyway to be self-consistent.\n"
 177             unless $no_comments;
 178
 179         $create .=
 180         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 181     }
 182
 183     for my $table ( $schema->get_tables ) {
 184         my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def) = create_table(
 185             $table,
 186             {
 187                 add_drop_table => $add_drop_table,
 188                 show_warnings  => $WARN,
 189                 no_comments    => $no_comments,
 190                 delay_constraints => $delay_constraints
 191             }
 192         );
 193         push @table_defs, @$table_def;
 194         push @fk_defs, @$fk_def;
 195         push @trigger_defs, @$trigger_def;
 196         push @index_defs, @$index_def;
 197         push @constraint_defs, @$constraint_def;
 198     }
 199
 200     my (@view_defs);
 201     foreach my $view ( $schema->get_views ) {
 202         push @view_defs, create_view($view);
 203     }
 204
 205     return wantarray ? (defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs) : $create . join ("\n\n", @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs, '');
 206 }
 207
 208 sub create_table {
 209     my ($table, $options) = @_;
 210     my $table_name = $table->name;
 211
 212     my $item = '';
 213     my $drop;
 214     my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
 215
 216     push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
 217     push @create, qq[DROP TABLE $table_name CASCADE CONSTRAINTS;] if $options->{add_drop_table};
 218
 219     my $table_name_ur = unreserve($table_name) or next;
 220
 221         my ( %field_name_scope, @field_comments );
 222         for my $field ( $table->get_fields ) {
 223             my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 224               create_field($field, $options, \%field_name_scope);
 225             push @create, @$field_create if ref $field_create;
 226             push @field_defs, @$field_defs if ref $field_defs;
 227             push @trigger_defs, @$trigger_defs if ref $trigger_defs;
 228             push @field_comments, @$field_comments if ref $field_comments;
 229         }
 230
 231         #
 232         # Table options
 233         #
 234         my @table_options;
 235         for my $opt ( $table->options ) {
 236             if ( ref $opt eq 'HASH' ) {
 237                 my ( $key, $value ) = each %$opt;
 238                 if ( ref $value eq 'ARRAY' ) {
 239                     push @table_options, "$key\n(\n".  join ("\n",
 240                         map { "  $_->[0]\t$_->[1]" }
 241                         map { [ each %$_ ] }
 242                         @$value
 243                     )."\n)";
 244                 }
 245                 elsif ( !defined $value ) {
 246                     push @table_options, $key;
 247                 }
 248                 else {
 249                     push @table_options, "$key    $value";
 250                 }
 251             }
 252         }
 253
 254         #
 255         # Table constraints
 256         #
 257         for my $c ( $table->get_constraints ) {
 258             my $name    = $c->name || '';
 259             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 260             my @rfields = map { unreserve( $_, $table_name ) }
 261                 $c->reference_fields;
 262             next if !@fields && $c->type ne CHECK_C;
 263
 264             if ( $c->type eq PRIMARY_KEY ) {
 265                 # create a name if delay_constraints
 266                 $name ||= mk_name( $table_name, 'pk' )
 267                   if $options->{delay_constraints};
 268                 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
 269                         'PRIMARY KEY (' . join( ', ', @fields ) . ')';
 270             }
 271             elsif ( $c->type eq UNIQUE ) {
 272                 # Don't create UNIQUE constraints identical to the primary key
 273                 if ( my $pk = $table->primary_key ) {
 274                                         my $u_fields = join(":", @fields);
 275                                         my $pk_fields = join(":", $pk->fields);
 276                                         next if $u_fields eq $pk_fields;
 277                 }
 278
 279                 $name ||= mk_name( $name || $table_name, 'u' );
 280
 281                 for my $f ( $c->fields ) {
 282                     my $field_def = $table->get_field( $f ) or next;
 283                     my $dtype     = $translate{ $field_def->data_type } or next;
 284                     if ( $WARN && $dtype =~ /clob/i ) {
 285                         warn "Oracle will not allow UNIQUE constraints on " .
 286                              "CLOB field '" . $field_def->table->name . '.' .
 287                              $field_def->name . ".'\n"
 288                     }
 289                 }
 290
 291                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 292                     '(' . join( ', ', @fields ) . ')';
 293             }
 294             elsif ( $c->type eq CHECK_C ) {
 295                 $name ||= mk_name( $name || $table_name, 'ck' );
 296                 my $expression = $c->expression || '';
 297                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 298             }
 299             elsif ( $c->type eq FOREIGN_KEY ) {
 300             $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
 301                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 302
 303                 if ( @fields ) {
 304                     $def .= '(' . join( ', ', @fields ) . ')';
 305                 }
 306
 307                 my $ref_table = unreserve($c->reference_table);
 308
 309                 $def .= " REFERENCES $ref_table";
 310
 311                 if ( @rfields ) {
 312                     $def .= ' (' . join( ', ', @rfields ) . ')';
 313                 }
 314
 315                 if ( $c->match_type ) {
 316                     $def .= ' MATCH ' .
 317                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 318                 }
 319
 320                 if ( $c->on_delete ) {
 321                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 322                 }
 323
 324             # disabled by plu 2007-12-29 - doesn't exist for oracle
 325             #if ( $c->on_update ) {
 326             #    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 327             #}
 328
 329             push @fk_defs, sprintf("ALTER TABLE %s ADD %s;", $table, $def);
 330             }
 331         }
 332
 333         #
 334         # Index Declarations
 335         #
 336         my @index_defs = ();
 337         for my $index ( $table->get_indices ) {
 338             my $index_name = $index->name || '';
 339             my $index_type = $index->type || NORMAL;
 340             my @fields     = map { unreserve( $_, $table_name ) }
 341                              $index->fields;
 342             next unless @fields;
 343
 344             my @index_options;
 345             for my $opt ( $index->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 @index_options, $key;
 357                     }
 358                     else {
 359                         push @index_options, "$key    $value";
 360                     }
 361                 }
 362             }
 363             my $index_options = @index_options
 364               ? "\n".join("\n", @index_options) : '';
 365
 366             if ( $index_type eq PRIMARY_KEY ) {
 367                 $index_name = $index_name ? mk_name( $index_name )
 368                     : mk_name( $table_name, 'pk' );
 369                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 370                     '(' . join( ', ', @fields ) . ')';
 371             }
 372             elsif ( $index_type eq NORMAL ) {
 373                 $index_name = $index_name ? mk_name( $index_name )
 374                     : mk_name( $table_name, $index_name || 'i' );
 375                 push @index_defs,
 376                     "CREATE INDEX $index_name on $table_name_ur (".
 377                         join( ', ', @fields ).
 378                     ")$index_options;";
 379             }
 380             elsif ( $index_type eq UNIQUE ) {
 381                 $index_name = $index_name ? mk_name( $index_name )
 382                     : mk_name( $table_name, $index_name || 'i' );
 383                 push @index_defs,
 384                     "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
 385                         join( ', ', @fields ).
 386                     ")$index_options;";
 387             }
 388             else {
 389                 warn "Unknown index type ($index_type) on table $table_name.\n"
 390                     if $WARN;
 391             }
 392         }
 393
 394         if ( my @table_comments = $table->comments ) {
 395             for my $comment ( @table_comments ) {
 396                 next unless $comment;
 397                 $comment =~ s/'/''/g;
 398                 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
 399                 $comment . "';" unless $options->{no_comments}
 400                 ;
 401             }
 402         }
 403
 404         my $table_options = @table_options
 405             ? "\n".join("\n", @table_options) : '';
 406     push @create, "CREATE TABLE $table_name_ur (\n" .
 407             join( ",\n", map { "  $_" } @field_defs,
 408             ($options->{delay_constraints} ? () : @constraint_defs) ) .
 409             "\n)$table_options;";
 410
 411     @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_.';'  }
 412       @constraint_defs;
 413
 414     if ( $WARN ) {
 415         if ( %truncated ) {
 416             warn "Truncated " . keys( %truncated ) . " names:\n";
 417             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 418         }
 419
 420         if ( %unreserve ) {
 421             warn "Encounted " . keys( %unreserve ) .
 422                 " unsafe names in schema (reserved or invalid):\n";
 423             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 424         }
 425     }
 426
 427     return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
 428 }
 429
 430 sub alter_field {
 431     my ($from_field, $to_field, $options) = @_;
 432
 433     my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 434       create_field($to_field, $options, {});
 435
 436     # Fix ORA-01442
 437     if ($to_field->is_nullable && !$from_field->is_nullable) {
 438         die 'Cannot remove NOT NULL from table field';
 439     } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
 440         @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
 441     }
 442
 443     my $table_name = $to_field->table->name;
 444     my $table_name_ur = unreserve( $table_name );
 445
 446     return 'ALTER TABLE '.$table_name_ur.' MODIFY ( '.join('', @$field_defs).' )';
 447 }
 448
 449 sub create_field {
 450     my ($field, $options, $field_name_scope) = @_;
 451
 452     my (@create, @field_defs, @trigger_defs, @field_comments);
 453
 454     my $table_name = $field->table->name;
 455     my $table_name_ur = unreserve( $table_name );
 456
 457     #
 458     # Field name
 459     #
 460     my $field_name    = mk_name(
 461                                 $field->name, '', $field_name_scope, 1
 462                                );
 463
 464     my $field_name_ur = unreserve( $field_name, $table_name );
 465     my $field_def     = $field_name_ur;
 466     $field->name( $field_name_ur );
 467
 468     #
 469     # Datatype
 470     #
 471     my $check;
 472     my $data_type = lc $field->data_type;
 473     my @size      = $field->size;
 474     my %extra     = $field->extra;
 475     my $list      = $extra{'list'} || [];
 476     # \todo deal with embedded quotes
 477     my $commalist = join( ', ', map { qq['$_'] } @$list );
 478
 479     if ( $data_type eq 'enum' ) {
 480         $check = "CHECK ($field_name_ur IN ($commalist))";
 481         $data_type = 'varchar2';
 482     }
 483     elsif ( $data_type eq 'set' ) {
 484         # XXX add a CHECK constraint maybe
 485         # (trickier and slower, than enum :)
 486         $data_type = 'varchar2';
 487     }
 488     else {
 489         $data_type  = defined $translate{ $data_type } ?
 490           $translate{ $data_type } :
 491             $data_type;
 492         $data_type ||= 'varchar2';
 493     }
 494
 495     #
 496     # Fixes ORA-02329: column of datatype LOB cannot be
 497     # unique or a primary key
 498     #
 499     if ( $data_type eq 'clob' && $field->is_primary_key ) {
 500         $data_type = 'varchar2';
 501         $size[0]   = 4000;
 502         warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 503           if $WARN;
 504     }
 505
 506     if ( $data_type eq 'clob' && $field->is_unique ) {
 507         $data_type = 'varchar2';
 508         $size[0]   = 4000;
 509         warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
 510           if $WARN;
 511     }
 512
 513     #
 514     # Fixes ORA-00907: missing right parenthesis
 515     #
 516     if ( $data_type =~ /(date|clob)/i ) {
 517         undef @size;
 518     }
 519
 520     $field_def .= " $data_type";
 521     if ( defined $size[0] && $size[0] > 0 ) {
 522         $field_def .= '(' . join( ', ', @size ) . ')';
 523     }
 524
 525     #
 526     # Default value
 527     #
 528     my $default = $field->default_value;
 529     if ( defined $default ) {
 530         #
 531         # Wherein we try to catch a string being used as
 532         # a default value for a numerical field.  If "true/false,"
 533         # then sub "1/0," otherwise just test the truthity of the
 534         # argument and use that (naive?).
 535         #
 536         if (
 537             $data_type =~ /^number$/i &&
 538             $default   !~ /^-?\d+$/     &&
 539             $default   !~ m/null/i
 540            ) {
 541             if ( $default =~ /^true$/i ) {
 542                 $default = "'1'";
 543             } elsif ( $default =~ /^false$/i ) {
 544                 $default = "'0'";
 545             } else {
 546                 $default = $default ? "'1'" : "'0'";
 547             }
 548         } elsif (
 549                  $data_type =~ /date/ && (
 550                                           $default eq 'current_timestamp'
 551                                           ||
 552                                           $default eq 'now()'
 553                                          )
 554                 ) {
 555             $default = 'SYSDATE';
 556         } else {
 557             $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 558         }
 559
 560         $field_def .= " DEFAULT $default",
 561     }
 562
 563     #
 564     # Not null constraint
 565     #
 566     unless ( $field->is_nullable ) {
 567         $field_def .= ' NOT NULL';
 568     }
 569
 570     $field_def .= " $check" if $check;
 571
 572     #
 573     # Auto_increment
 574     #
 575     if ( $field->is_auto_increment ) {
 576         my $base_name    = $table_name_ur . "_". $field_name;
 577         my $seq_name     = mk_name( $base_name, 'sq' );
 578         my $trigger_name = mk_name( $base_name, 'ai' );
 579
 580         push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
 581         push @create, "CREATE SEQUENCE $seq_name;";
 582         push @trigger_defs,
 583           "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 584           "BEFORE INSERT ON $table_name_ur\n" .
 585           "FOR EACH ROW WHEN (\n" .
 586           " new.$field_name_ur IS NULL".
 587           " OR new.$field_name_ur = 0\n".
 588           ")\n".
 589           "BEGIN\n" .
 590           " SELECT $seq_name.nextval\n" .
 591           " INTO :new." . $field->name."\n" .
 592           " FROM dual;\n" .
 593           "END;\n/";
 594         ;
 595     }
 596
 597     if ( lc $field->data_type eq 'timestamp' ) {
 598         my $base_name = $table_name_ur . "_". $field_name_ur;
 599         my $trig_name = mk_name( $base_name, 'ts' );
 600         push @trigger_defs,
 601           "CREATE OR REPLACE TRIGGER $trig_name\n".
 602           "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 603           "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 604           "BEGIN \n".
 605           " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 606           "END;\n/";
 607     }
 608
 609     push @field_defs, $field_def;
 610
 611     if ( my $comment = $field->comments ) {
 612         $comment =~ s/'/''/g;
 613         push @field_comments,
 614           "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
 615             $comment . "';" unless $options->{no_comments};
 616     }
 617
 618     return \@create, \@field_defs, \@trigger_defs, \@field_comments;
 619
 620 }
 621
 622
 623 sub create_view {
 624     my ($view) = @_;
 625
 626     my $out = sprintf("CREATE VIEW %s AS\n%s;",
 627                       $view->name,
 628                       $view->sql);
 629
 630     return $out;
 631 }
 632
 633 # -------------------------------------------------------------------
 634 sub mk_name {
 635     my $basename      = shift || '';
 636     my $type          = shift || '';
 637        $type          = '' if $type =~ /^\d/;
 638     my $scope         = shift || '';
 639     my $critical      = shift || '';
 640     my $basename_orig = $basename;
 641     my $max_name      = $type
 642                         ? $max_id_length - (length($type) + 1)
 643                         : $max_id_length;
 644     $basename         = substr( $basename, 0, $max_name )
 645                         if length( $basename ) > $max_name;
 646     my $name          = $type ? "${type}_$basename" : $basename;
 647
 648     if ( $basename ne $basename_orig and $critical ) {
 649         my $show_type = $type ? "+'$type'" : "";
 650         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 651             "character limit to make '$name'\n" if $WARN;
 652         $truncated{ $basename_orig } = $name;
 653     }
 654
 655     $scope ||= \%global_names;
 656     if ( my $prev = $scope->{ $name } ) {
 657         my $name_orig = $name;
 658         substr($name, $max_id_length - 2) = ""
 659             if length( $name ) >= $max_id_length - 1;
 660         $name        .= sprintf( "%02d", $prev++ );
 661
 662         warn "The name '$name_orig' has been changed to ",
 663              "'$name' to make it unique.\n" if $WARN;
 664
 665         $scope->{ $name_orig }++;
 666     }
 667
 668     $scope->{ $name }++;
 669     return $name;
 670 }
 671
 672 # -------------------------------------------------------------------
 673 sub unreserve {
 674     my $name            = shift || '';
 675     my $schema_obj_name = shift || '';
 676
 677     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 678
 679     # also trap fields that don't begin with a letter
 680     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 681
 682     if ( $schema_obj_name ) {
 683         ++$unreserve{"$schema_obj_name.$name"};
 684     }
 685     else {
 686         ++$unreserve{"$name (table name)"};
 687     }
 688
 689     my $unreserve = sprintf '%s_', $name;
 690     return $unreserve.$suffix;
 691 }
 692
 693 1;
 694
 695 # -------------------------------------------------------------------
 696 # All bad art is the result of good intentions.
 697 # Oscar Wilde
 698 # -------------------------------------------------------------------
 699
 700 =pod
 701
 702 =head1 CREDITS
 703
 704 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 705 script.
 706
 707 =head1 AUTHOR
 708
 709 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 710
 711 =head1 SEE ALSO
 712
 713 SQL::Translator, DDL::Oracle, mysql2ora.
 714
 715 =cut