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 add_field {
 450     my ($new_field, $options) = @_;
 451
 452     my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 453       create_field($new_field, $options, {});
 454
 455     my $table_name = $new_field->table->name;
 456     my $table_name_ur = unreserve( $table_name );
 457
 458     my $out = sprintf('ALTER TABLE %s ADD ( %s )',
 459                       $table_name_ur,
 460                       join('', @$field_defs));
 461     return $out;
 462 }
 463
 464 sub create_field {
 465     my ($field, $options, $field_name_scope) = @_;
 466
 467     my (@create, @field_defs, @trigger_defs, @field_comments);
 468
 469     my $table_name = $field->table->name;
 470     my $table_name_ur = unreserve( $table_name );
 471
 472     #
 473     # Field name
 474     #
 475     my $field_name    = mk_name(
 476                                 $field->name, '', $field_name_scope, 1
 477                                );
 478
 479     my $field_name_ur = unreserve( $field_name, $table_name );
 480     my $field_def     = $field_name_ur;
 481     $field->name( $field_name_ur );
 482
 483     #
 484     # Datatype
 485     #
 486     my $check;
 487     my $data_type = lc $field->data_type;
 488     my @size      = $field->size;
 489     my %extra     = $field->extra;
 490     my $list      = $extra{'list'} || [];
 491     # \todo deal with embedded quotes
 492     my $commalist = join( ', ', map { qq['$_'] } @$list );
 493
 494     if ( $data_type eq 'enum' ) {
 495         $check = "CHECK ($field_name_ur IN ($commalist))";
 496         $data_type = 'varchar2';
 497     }
 498     elsif ( $data_type eq 'set' ) {
 499         # XXX add a CHECK constraint maybe
 500         # (trickier and slower, than enum :)
 501         $data_type = 'varchar2';
 502     }
 503     else {
 504         $data_type  = defined $translate{ $data_type } ?
 505           $translate{ $data_type } :
 506             $data_type;
 507         $data_type ||= 'varchar2';
 508     }
 509
 510     #
 511     # Fixes ORA-02329: column of datatype LOB cannot be
 512     # unique or a primary key
 513     #
 514     if ( $data_type eq 'clob' && $field->is_primary_key ) {
 515         $data_type = 'varchar2';
 516         $size[0]   = 4000;
 517         warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 518           if $WARN;
 519     }
 520
 521     if ( $data_type eq 'clob' && $field->is_unique ) {
 522         $data_type = 'varchar2';
 523         $size[0]   = 4000;
 524         warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
 525           if $WARN;
 526     }
 527
 528     #
 529     # Fixes ORA-00907: missing right parenthesis
 530     #
 531     if ( $data_type =~ /(date|clob)/i ) {
 532         undef @size;
 533     }
 534
 535     $field_def .= " $data_type";
 536     if ( defined $size[0] && $size[0] > 0 ) {
 537         $field_def .= '(' . join( ', ', @size ) . ')';
 538     }
 539
 540     #
 541     # Default value
 542     #
 543     my $default = $field->default_value;
 544     if ( defined $default ) {
 545         #
 546         # Wherein we try to catch a string being used as
 547         # a default value for a numerical field.  If "true/false,"
 548         # then sub "1/0," otherwise just test the truthity of the
 549         # argument and use that (naive?).
 550         #
 551         if (
 552             $data_type =~ /^number$/i &&
 553             $default   !~ /^-?\d+$/     &&
 554             $default   !~ m/null/i
 555            ) {
 556             if ( $default =~ /^true$/i ) {
 557                 $default = "'1'";
 558             } elsif ( $default =~ /^false$/i ) {
 559                 $default = "'0'";
 560             } else {
 561                 $default = $default ? "'1'" : "'0'";
 562             }
 563         } elsif (
 564                  $data_type =~ /date/ && (
 565                                           $default eq 'current_timestamp'
 566                                           ||
 567                                           $default eq 'now()'
 568                                          )
 569                 ) {
 570             $default = 'SYSDATE';
 571         } else {
 572             $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 573         }
 574
 575         $field_def .= " DEFAULT $default",
 576     }
 577
 578     #
 579     # Not null constraint
 580     #
 581     unless ( $field->is_nullable ) {
 582         $field_def .= ' NOT NULL';
 583     }
 584
 585     $field_def .= " $check" if $check;
 586
 587     #
 588     # Auto_increment
 589     #
 590     if ( $field->is_auto_increment ) {
 591         my $base_name    = $table_name_ur . "_". $field_name;
 592         my $seq_name     = mk_name( $base_name, 'sq' );
 593         my $trigger_name = mk_name( $base_name, 'ai' );
 594
 595         push @create, qq[DROP SEQUENCE $seq_name;] if $options->{add_drop_table};
 596         push @create, "CREATE SEQUENCE $seq_name;";
 597         push @trigger_defs,
 598           "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 599           "BEFORE INSERT ON $table_name_ur\n" .
 600           "FOR EACH ROW WHEN (\n" .
 601           " new.$field_name_ur IS NULL".
 602           " OR new.$field_name_ur = 0\n".
 603           ")\n".
 604           "BEGIN\n" .
 605           " SELECT $seq_name.nextval\n" .
 606           " INTO :new." . $field->name."\n" .
 607           " FROM dual;\n" .
 608           "END;\n/";
 609         ;
 610     }
 611
 612     if ( lc $field->data_type eq 'timestamp' ) {
 613         my $base_name = $table_name_ur . "_". $field_name_ur;
 614         my $trig_name = mk_name( $base_name, 'ts' );
 615         push @trigger_defs,
 616           "CREATE OR REPLACE TRIGGER $trig_name\n".
 617           "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 618           "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 619           "BEGIN \n".
 620           " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 621           "END;\n/";
 622     }
 623
 624     push @field_defs, $field_def;
 625
 626     if ( my $comment = $field->comments ) {
 627         $comment =~ s/'/''/g;
 628         push @field_comments,
 629           "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
 630             $comment . "';" unless $options->{no_comments};
 631     }
 632
 633     return \@create, \@field_defs, \@trigger_defs, \@field_comments;
 634
 635 }
 636
 637
 638 sub create_view {
 639     my ($view) = @_;
 640
 641     my $out = sprintf("CREATE VIEW %s AS\n%s;",
 642                       $view->name,
 643                       $view->sql);
 644
 645     return $out;
 646 }
 647
 648 # -------------------------------------------------------------------
 649 sub mk_name {
 650     my $basename      = shift || '';
 651     my $type          = shift || '';
 652        $type          = '' if $type =~ /^\d/;
 653     my $scope         = shift || '';
 654     my $critical      = shift || '';
 655     my $basename_orig = $basename;
 656     my $max_name      = $type
 657                         ? $max_id_length - (length($type) + 1)
 658                         : $max_id_length;
 659     $basename         = substr( $basename, 0, $max_name )
 660                         if length( $basename ) > $max_name;
 661     my $name          = $type ? "${type}_$basename" : $basename;
 662
 663     if ( $basename ne $basename_orig and $critical ) {
 664         my $show_type = $type ? "+'$type'" : "";
 665         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 666             "character limit to make '$name'\n" if $WARN;
 667         $truncated{ $basename_orig } = $name;
 668     }
 669
 670     $scope ||= \%global_names;
 671     if ( my $prev = $scope->{ $name } ) {
 672         my $name_orig = $name;
 673         substr($name, $max_id_length - 2) = ""
 674             if length( $name ) >= $max_id_length - 1;
 675         $name        .= sprintf( "%02d", $prev++ );
 676
 677         warn "The name '$name_orig' has been changed to ",
 678              "'$name' to make it unique.\n" if $WARN;
 679
 680         $scope->{ $name_orig }++;
 681     }
 682
 683     $scope->{ $name }++;
 684     return $name;
 685 }
 686
 687 # -------------------------------------------------------------------
 688 sub unreserve {
 689     my $name            = shift || '';
 690     my $schema_obj_name = shift || '';
 691
 692     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 693
 694     # also trap fields that don't begin with a letter
 695     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 696
 697     if ( $schema_obj_name ) {
 698         ++$unreserve{"$schema_obj_name.$name"};
 699     }
 700     else {
 701         ++$unreserve{"$name (table name)"};
 702     }
 703
 704     my $unreserve = sprintf '%s_', $name;
 705     return $unreserve.$suffix;
 706 }
 707
 708 1;
 709
 710 # -------------------------------------------------------------------
 711 # All bad art is the result of good intentions.
 712 # Oscar Wilde
 713 # -------------------------------------------------------------------
 714
 715 =pod
 716
 717 =head1 CREDITS
 718
 719 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 720 script.
 721
 722 =head1 AUTHOR
 723
 724 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 725
 726 =head1 SEE ALSO
 727
 728 SQL::Translator, DDL::Oracle, mysql2ora.
 729
 730 =cut