lib/SQL/Translator/Producer/Oracle.pm

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