lib/SQL/Translator/Producer/Oracle.pm

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