lib/SQL/Translator/Producer/Oracle.pm

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