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 #
 155 # Oracle 8/9 max size of data types from:
 156 # http://www.ss64.com/orasyntax/datatypes.html
 157 #
 158 my %max_size = (
 159     char      => 2000,
 160     nchar     => 2000,
 161     nvarchar2 => 4000,
 162     number    => [ 38, 127 ],
 163     raw       => 2000,
 164     varchar   => 4000,          # only synonym for varchar2
 165     varchar2  => 4000,
 166 );
 167
 168 my $max_id_length    = 30;
 169 my %used_identifiers = ();
 170 my %global_names;
 171 my %unreserve;
 172 my %truncated;
 173
 174 # -------------------------------------------------------------------
 175 sub produce {
 176     my $translator     = shift;
 177     $DEBUG             = $translator->debug;
 178     $WARN              = $translator->show_warnings || 0;
 179     my $no_comments    = $translator->no_comments;
 180     my $add_drop_table = $translator->add_drop_table;
 181     my $schema         = $translator->schema;
 182     my $delay_constraints = $translator->producer_args->{delay_constraints};
 183     my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
 184
 185     $create .= header_comment unless ($no_comments);
 186
 187     if ( $translator->parser_type =~ /mysql/i ) {
 188         $create .=
 189             "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 190             "-- but we set it here anyway to be self-consistent.\n"
 191             unless $no_comments;
 192
 193         $create .=
 194         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 195     }
 196
 197     for my $table ( $schema->get_tables ) {
 198         my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
 199             $table,
 200             {
 201                 add_drop_table    => $add_drop_table,
 202                 show_warnings     => $WARN,
 203                 no_comments       => $no_comments,
 204                 delay_constraints => $delay_constraints,
 205                 wantarray         => wantarray ? 1 : 0,
 206             }
 207         );
 208         push @table_defs, @$table_def;
 209         push @fk_defs, @$fk_def;
 210         push @trigger_defs, @$trigger_def;
 211         push @index_defs, @$index_def;
 212         push @constraint_defs, @$constraint_def;
 213     }
 214
 215     my (@view_defs);
 216     foreach my $view ( $schema->get_views ) {
 217         push @view_defs, create_view($view);
 218     }
 219
 220     if (wantarray) {
 221         return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
 222     }
 223     else {
 224         $create .= join ('', map { $_ ? "$_;\n\n" : () } @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
 225         # triggers may NOT end with a semicolon
 226         $create .= join "\n\n", @trigger_defs;
 227         return $create;
 228     }
 229 }
 230
 231 sub create_table {
 232     my ($table, $options) = @_;
 233     my $table_name = $table->name;
 234
 235     my $item = '';
 236     my $drop;
 237     my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
 238
 239     my $table_name_ur = unreserve($table_name) or next;
 240
 241     push @create, "--\n-- Table: $table_name_ur\n--" unless $options->{no_comments};
 242     push @create, qq[DROP TABLE $table_name_ur CASCADE CONSTRAINTS] if $options->{add_drop_table};
 243
 244         my ( %field_name_scope, @field_comments );
 245         for my $field ( $table->get_fields ) {
 246             my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 247               create_field($field, $options, \%field_name_scope);
 248             push @create, @$field_create if ref $field_create;
 249             push @field_defs, @$field_defs if ref $field_defs;
 250             push @trigger_defs, @$trigger_defs if ref $trigger_defs;
 251             push @field_comments, @$field_comments if ref $field_comments;
 252         }
 253
 254         #
 255         # Table options
 256         #
 257         my @table_options;
 258         for my $opt ( $table->options ) {
 259             if ( ref $opt eq 'HASH' ) {
 260                 my ( $key, $value ) = each %$opt;
 261                 if ( ref $value eq 'ARRAY' ) {
 262                     push @table_options, "$key\n(\n".  join ("\n",
 263                         map { "  $_->[0]\t$_->[1]" }
 264                         map { [ each %$_ ] }
 265                         @$value
 266                     )."\n)";
 267                 }
 268                 elsif ( !defined $value ) {
 269                     push @table_options, $key;
 270                 }
 271                 else {
 272                     push @table_options, "$key    $value";
 273                 }
 274             }
 275         }
 276
 277         #
 278         # Table constraints
 279         #
 280         for my $c ( $table->get_constraints ) {
 281             my $name    = $c->name || '';
 282             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 283             my @rfields = map { unreserve( $_, $table_name ) }
 284                 $c->reference_fields;
 285             next if !@fields && $c->type ne CHECK_C;
 286
 287             if ( $c->type eq PRIMARY_KEY ) {
 288                 # create a name if delay_constraints
 289                 $name ||= mk_name( $table_name, 'pk' )
 290                   if $options->{delay_constraints};
 291                 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
 292                         'PRIMARY KEY (' . join( ', ', @fields ) . ')';
 293             }
 294             elsif ( $c->type eq UNIQUE ) {
 295                 # Don't create UNIQUE constraints identical to the primary key
 296                 if ( my $pk = $table->primary_key ) {
 297                                         my $u_fields = join(":", @fields);
 298                                         my $pk_fields = join(":", $pk->fields);
 299                                         next if $u_fields eq $pk_fields;
 300                 }
 301
 302                 $name ||= mk_name( $name || $table_name, 'u' );
 303
 304                 for my $f ( $c->fields ) {
 305                     my $field_def = $table->get_field( $f ) or next;
 306                     my $dtype     = $translate{ $field_def->data_type } or next;
 307                     if ( $WARN && $dtype =~ /clob/i ) {
 308                         warn "Oracle will not allow UNIQUE constraints on " .
 309                              "CLOB field '" . $field_def->table->name . '.' .
 310                              $field_def->name . ".'\n"
 311                     }
 312                 }
 313
 314                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 315                     '(' . join( ', ', @fields ) . ')';
 316             }
 317             elsif ( $c->type eq CHECK_C ) {
 318                 $name ||= mk_name( $name || $table_name, 'ck' );
 319                 my $expression = $c->expression || '';
 320                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 321             }
 322             elsif ( $c->type eq FOREIGN_KEY ) {
 323                 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
 324                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 325
 326                 if ( @fields ) {
 327                     $def .= '(' . join( ', ', @fields ) . ')';
 328                 }
 329
 330                 my $ref_table = unreserve($c->reference_table);
 331
 332                 $def .= " REFERENCES $ref_table";
 333
 334                 if ( @rfields ) {
 335                     $def .= ' (' . join( ', ', @rfields ) . ')';
 336                 }
 337
 338                 if ( $c->match_type ) {
 339                     $def .= ' MATCH ' .
 340                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 341                 }
 342
 343                 if ( $c->on_delete ) {
 344                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 345                 }
 346
 347                 # disabled by plu 2007-12-29 - doesn't exist for oracle
 348                 #if ( $c->on_update ) {
 349                 #    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 350                 #}
 351
 352                 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_ur, $def);
 353             }
 354         }
 355
 356         #
 357         # Index Declarations
 358         #
 359         my @index_defs = ();
 360         for my $index ( $table->get_indices ) {
 361             my $index_name = $index->name || '';
 362             my $index_type = $index->type || NORMAL;
 363             my @fields     = map { unreserve( $_, $table_name ) }
 364                              $index->fields;
 365             next unless @fields;
 366
 367             my @index_options;
 368             for my $opt ( $index->options ) {
 369                 if ( ref $opt eq 'HASH' ) {
 370                     my ( $key, $value ) = each %$opt;
 371                     if ( ref $value eq 'ARRAY' ) {
 372                         push @table_options, "$key\n(\n".  join ("\n",
 373                             map { "  $_->[0]\t$_->[1]" }
 374                             map { [ each %$_ ] }
 375                            @$value
 376                         )."\n)";
 377                     }
 378                     elsif ( !defined $value ) {
 379                         push @index_options, $key;
 380                     }
 381                     else {
 382                         push @index_options, "$key    $value";
 383                     }
 384                 }
 385             }
 386             my $index_options = @index_options
 387               ? "\n".join("\n", @index_options) : '';
 388
 389             if ( $index_type eq PRIMARY_KEY ) {
 390                 $index_name = $index_name ? mk_name( $index_name )
 391                     : mk_name( $table_name, 'pk' );
 392                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 393                     '(' . join( ', ', @fields ) . ')';
 394             }
 395             elsif ( $index_type eq NORMAL ) {
 396                 $index_name = $index_name ? mk_name( $index_name )
 397                     : mk_name( $table_name, $index_name || 'i' );
 398                 push @index_defs,
 399                     "CREATE INDEX $index_name on $table_name_ur (".
 400                         join( ', ', @fields ).
 401                     ")$index_options";
 402             }
 403             elsif ( $index_type eq UNIQUE ) {
 404                 $index_name = $index_name ? mk_name( $index_name )
 405                     : mk_name( $table_name, $index_name || 'i' );
 406                 push @index_defs,
 407                     "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
 408                         join( ', ', @fields ).
 409                     ")$index_options";
 410             }
 411             else {
 412                 warn "Unknown index type ($index_type) on table $table_name.\n"
 413                     if $WARN;
 414             }
 415         }
 416
 417         if ( my @table_comments = $table->comments ) {
 418             for my $comment ( @table_comments ) {
 419                 next unless $comment;
 420                 $comment =~ s/'/''/g;
 421                 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
 422                 $comment . "'" unless $options->{no_comments}
 423                 ;
 424             }
 425         }
 426
 427         my $table_options = @table_options
 428             ? "\n".join("\n", @table_options) : '';
 429     push @create, "CREATE TABLE $table_name_ur (\n" .
 430             join( ",\n", map { "  $_" } @field_defs,
 431             ($options->{delay_constraints} ? () : @constraint_defs) ) .
 432             "\n)$table_options";
 433
 434     @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_  }
 435       @constraint_defs;
 436
 437     if ( $WARN ) {
 438         if ( %truncated ) {
 439             warn "Truncated " . keys( %truncated ) . " names:\n";
 440             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 441         }
 442
 443         if ( %unreserve ) {
 444             warn "Encounted " . keys( %unreserve ) .
 445                 " unsafe names in schema (reserved or invalid):\n";
 446             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 447         }
 448     }
 449
 450     return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
 451 }
 452
 453 sub alter_field {
 454     my ($from_field, $to_field, $options) = @_;
 455
 456     my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 457       create_field($to_field, $options, {});
 458
 459     # Fix ORA-01442
 460     if ($to_field->is_nullable && !$from_field->is_nullable) {
 461         die 'Cannot remove NOT NULL from table field';
 462     } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
 463         @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
 464     }
 465
 466     my $table_name = $to_field->table->name;
 467     my $table_name_ur = unreserve( $table_name );
 468
 469     return 'ALTER TABLE '.$table_name_ur.' MODIFY ( '.join('', @$field_defs).' )';
 470 }
 471
 472 sub add_field {
 473     my ($new_field, $options) = @_;
 474
 475     my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 476       create_field($new_field, $options, {});
 477
 478     my $table_name = $new_field->table->name;
 479     my $table_name_ur = unreserve( $table_name );
 480
 481     my $out = sprintf('ALTER TABLE %s ADD ( %s )',
 482                       $table_name_ur,
 483                       join('', @$field_defs));
 484     return $out;
 485 }
 486
 487 sub create_field {
 488     my ($field, $options, $field_name_scope) = @_;
 489
 490     my (@create, @field_defs, @trigger_defs, @field_comments);
 491
 492     my $table_name = $field->table->name;
 493     my $table_name_ur = unreserve( $table_name );
 494
 495     #
 496     # Field name
 497     #
 498     my $field_name    = mk_name(
 499                                 $field->name, '', $field_name_scope, 1
 500                                );
 501
 502     my $field_name_ur = unreserve( $field_name, $table_name );
 503     my $field_def     = $field_name_ur;
 504     $field->name( $field_name_ur );
 505
 506     #
 507     # Datatype
 508     #
 509     my $check;
 510     my $data_type = lc $field->data_type;
 511     my @size      = $field->size;
 512     my %extra     = $field->extra;
 513     my $list      = $extra{'list'} || [];
 514     # \todo deal with embedded quotes
 515     my $commalist = join( ', ', map { qq['$_'] } @$list );
 516
 517     if ( $data_type eq 'enum' ) {
 518         $check = "CHECK ($field_name_ur IN ($commalist))";
 519         $data_type = 'varchar2';
 520     }
 521     elsif ( $data_type eq 'set' ) {
 522         # XXX add a CHECK constraint maybe
 523         # (trickier and slower, than enum :)
 524         $data_type = 'varchar2';
 525     }
 526     else {
 527         $data_type  = defined $translate{ $data_type } ?
 528           $translate{ $data_type } :
 529             $data_type;
 530         $data_type ||= 'varchar2';
 531     }
 532
 533     # ensure size is not bigger than max size oracle allows for data type
 534     if ( defined $max_size{$data_type} ) {
 535         for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
 536             my $max =
 537               ref( $max_size{$data_type} ) eq 'ARRAY'
 538               ? $max_size{$data_type}->[$i]
 539               : $max_size{$data_type};
 540             $size[$i] = $max if $size[$i] > $max;
 541         }
 542     }
 543
 544     #
 545     # Fixes ORA-02329: column of datatype LOB cannot be
 546     # unique or a primary key
 547     #
 548     if ( $data_type eq 'clob' && $field->is_primary_key ) {
 549         $data_type = 'varchar2';
 550         $size[0]   = 4000;
 551         warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 552           if $WARN;
 553     }
 554
 555     if ( $data_type eq 'clob' && $field->is_unique ) {
 556         $data_type = 'varchar2';
 557         $size[0]   = 4000;
 558         warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
 559           if $WARN;
 560     }
 561
 562     #
 563     # Fixes ORA-00907: missing right parenthesis
 564     #
 565     if ( $data_type =~ /(date|clob)/i ) {
 566         undef @size;
 567     }
 568
 569     $field_def .= " $data_type";
 570     if ( defined $size[0] && $size[0] > 0 ) {
 571         $field_def .= '(' . join( ', ', @size ) . ')';
 572     }
 573
 574     #
 575     # Default value
 576     #
 577     my $default = $field->default_value;
 578     if ( defined $default ) {
 579         #
 580         # Wherein we try to catch a string being used as
 581         # a default value for a numerical field.  If "true/false,"
 582         # then sub "1/0," otherwise just test the truthity of the
 583         # argument and use that (naive?).
 584         #
 585         if (ref $default and defined $$default) {
 586           $default = $$default;
 587         } elsif (ref $default) {
 588           $default = 'NULL';
 589         } elsif (
 590             $data_type =~ /^number$/i &&
 591             $default   !~ /^-?\d+$/     &&
 592             $default   !~ m/null/i
 593            ) {
 594             if ( $default =~ /^true$/i ) {
 595                 $default = "'1'";
 596             } elsif ( $default =~ /^false$/i ) {
 597                 $default = "'0'";
 598             } else {
 599                 $default = $default ? "'1'" : "'0'";
 600             }
 601         } elsif (
 602                  $data_type =~ /date/ && (
 603                                           $default eq 'current_timestamp'
 604                                           ||
 605                                           $default eq 'now()'
 606                                          )
 607                 ) {
 608             $default = 'SYSDATE';
 609         } else {
 610             $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 611         }
 612
 613         $field_def .= " DEFAULT $default",
 614     }
 615
 616     #
 617     # Not null constraint
 618     #
 619     unless ( $field->is_nullable ) {
 620         $field_def .= ' NOT NULL';
 621     }
 622
 623     $field_def .= " $check" if $check;
 624
 625     #
 626     # Auto_increment
 627     #
 628     if ( $field->is_auto_increment ) {
 629         my $base_name    = $table_name_ur . "_". $field_name;
 630         my $seq_name     = mk_name( $base_name, 'sq' );
 631         my $trigger_name = mk_name( $base_name, 'ai' );
 632
 633         push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
 634         push @create, "CREATE SEQUENCE $seq_name";
 635         my $trigger =
 636           "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 637           "BEFORE INSERT ON $table_name_ur\n" .
 638           "FOR EACH ROW WHEN (\n" .
 639           " new.$field_name_ur IS NULL".
 640           " OR new.$field_name_ur = 0\n".
 641           ")\n".
 642           "BEGIN\n" .
 643           " SELECT $seq_name.nextval\n" .
 644           " INTO :new." . $field->name."\n" .
 645           " FROM dual;\n" .
 646           "END;\n";
 647
 648         #
 649         # If wantarray is set we have to omit the last "/" in this statement so it
 650         # can be executed by DBI->do() directly.
 651         #
 652         $trigger .= "/" unless $options->{wantarray};
 653
 654         push @trigger_defs, $trigger;
 655     }
 656
 657     if ( lc $field->data_type eq 'timestamp' ) {
 658         my $base_name = $table_name_ur . "_". $field_name_ur;
 659         my $trig_name = mk_name( $base_name, 'ts' );
 660         my $trigger =
 661           "CREATE OR REPLACE TRIGGER $trig_name\n".
 662           "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 663           "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 664           "BEGIN \n".
 665           " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 666           "END;\n";
 667
 668           #
 669           # If wantarray is set we have to omit the last "/" in this statement so it
 670           # can be executed by DBI->do() directly.
 671           #
 672           $trigger .= "/" unless $options->{wantarray};
 673
 674           push @trigger_defs, $trigger;
 675     }
 676
 677     push @field_defs, $field_def;
 678
 679     if ( my $comment = $field->comments ) {
 680         $comment =~ s/'/''/g;
 681         push @field_comments,
 682           "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
 683             $comment . "';" unless $options->{no_comments};
 684     }
 685
 686     return \@create, \@field_defs, \@trigger_defs, \@field_comments;
 687
 688 }
 689
 690
 691 sub create_view {
 692     my ($view) = @_;
 693
 694     my $out = sprintf("CREATE VIEW %s AS\n%s;",
 695                       $view->name,
 696                       $view->sql);
 697
 698     return $out;
 699 }
 700
 701 # -------------------------------------------------------------------
 702 sub mk_name {
 703     my $basename      = shift || '';
 704     my $type          = shift || '';
 705        $type          = '' if $type =~ /^\d/;
 706     my $scope         = shift || '';
 707     my $critical      = shift || '';
 708     my $basename_orig = $basename;
 709     my $max_name      = $type
 710                         ? $max_id_length - (length($type) + 1)
 711                         : $max_id_length;
 712     $basename         = substr( $basename, 0, $max_name )
 713                         if length( $basename ) > $max_name;
 714     my $name          = $type ? "${type}_$basename" : $basename;
 715
 716     if ( $basename ne $basename_orig and $critical ) {
 717         my $show_type = $type ? "+'$type'" : "";
 718         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 719             "character limit to make '$name'\n" if $WARN;
 720         $truncated{ $basename_orig } = $name;
 721     }
 722
 723     $scope ||= \%global_names;
 724     if ( my $prev = $scope->{ $name } ) {
 725         my $name_orig = $name;
 726         substr($name, $max_id_length - 2) = ""
 727             if length( $name ) >= $max_id_length - 1;
 728         $name        .= sprintf( "%02d", $prev++ );
 729
 730         warn "The name '$name_orig' has been changed to ",
 731              "'$name' to make it unique.\n" if $WARN;
 732
 733         $scope->{ $name_orig }++;
 734     }
 735
 736     $scope->{ $name }++;
 737     return $name;
 738 }
 739
 740 # -------------------------------------------------------------------
 741 sub unreserve {
 742     my $name            = shift || '';
 743     my $schema_obj_name = shift || '';
 744
 745     my ( $suffix ) = ( $name =~ s/(\W.*)$// ) ? $1 : '';
 746
 747     # also trap fields that don't begin with a letter
 748     return $name if !$ora_reserved{ uc $name } && $name =~ /^[a-z]/i;
 749
 750     if ( $schema_obj_name ) {
 751         ++$unreserve{"$schema_obj_name.$name"};
 752     }
 753     else {
 754         ++$unreserve{"$name (table name)"};
 755     }
 756
 757     my $unreserve = sprintf '%s_', $name;
 758     return $unreserve.$suffix;
 759 }
 760
 761 1;
 762
 763 # -------------------------------------------------------------------
 764 # All bad art is the result of good intentions.
 765 # Oscar Wilde
 766 # -------------------------------------------------------------------
 767
 768 =pod
 769
 770 =head1 CREDITS
 771
 772 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 773 script.
 774
 775 =head1 AUTHOR
 776
 777 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
 778
 779 =head1 SEE ALSO
 780
 781 SQL::Translator, DDL::Oracle, mysql2ora.
 782
 783 =cut