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.59';
 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             }
 254         );
 255         push @table_defs, @$table_def;
 256         push @fk_defs, @$fk_def;
 257         push @trigger_defs, @$trigger_def;
 258         push @index_defs, @$index_def;
 259         push @constraint_defs, @$constraint_def;
 260     }
 261
 262     my (@view_defs);
 263     foreach my $view ( $schema->get_views ) {
 264         my ( $view_def ) = create_view(
 265             $view,
 266             {
 267                 add_drop_view     => $add_drop_table,
 268             }
 269         );
 270         push @view_defs, @$view_def;
 271     }
 272
 273     if (wantarray) {
 274         return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
 275     }
 276     else {
 277         $create .= join ('', map { $_ ? "$_;\n\n" : () } @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
 278         # If wantarray is not set we have to add "/" in this statement
 279         # DBI->do() needs them omitted
 280         # triggers may NOT end with a semicolon
 281         $create .= join "/\n\n", @trigger_defs;
 282         # for last trigger
 283         $create .= "/\n\n";
 284         return $create;
 285     }
 286 }
 287
 288 sub create_table {
 289     my ($table, $options) = @_;
 290     my $table_name = $table->name;
 291
 292     my $item = '';
 293     my $drop;
 294     my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
 295
 296     my $table_name_ur = unreserve($table_name) or next;
 297
 298     push @create, "--\n-- Table: $table_name_ur\n--" unless $options->{no_comments};
 299     push @create, qq[DROP TABLE $table_name_ur CASCADE CONSTRAINTS] if $options->{add_drop_table};
 300
 301         my ( %field_name_scope, @field_comments );
 302         for my $field ( $table->get_fields ) {
 303             my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 304               create_field($field, $options, \%field_name_scope);
 305             push @create, @$field_create if ref $field_create;
 306             push @field_defs, @$field_defs if ref $field_defs;
 307             push @trigger_defs, @$trigger_defs if ref $trigger_defs;
 308             push @field_comments, @$field_comments if ref $field_comments;
 309         }
 310
 311         #
 312         # Table options
 313         #
 314         my @table_options;
 315         for my $opt ( $table->options ) {
 316             if ( ref $opt eq 'HASH' ) {
 317                 my ( $key, $value ) = each %$opt;
 318                 if ( ref $value eq 'ARRAY' ) {
 319                     push @table_options, "$key\n(\n".  join ("\n",
 320                         map { "  $_->[0]\t$_->[1]" }
 321                         map { [ each %$_ ] }
 322                         @$value
 323                     )."\n)";
 324                 }
 325                 elsif ( !defined $value ) {
 326                     push @table_options, $key;
 327                 }
 328                 else {
 329                     push @table_options, "$key    $value";
 330                 }
 331             }
 332         }
 333
 334         #
 335         # Table constraints
 336         #
 337         for my $c ( $table->get_constraints ) {
 338             my $name    = $c->name || '';
 339             my @fields  = map { unreserve( $_, $table_name ) } $c->fields;
 340             my @rfields = map { unreserve( $_, $table_name ) }
 341                 $c->reference_fields;
 342             next if !@fields && $c->type ne CHECK_C;
 343
 344             if ( $c->type eq PRIMARY_KEY ) {
 345                 # create a name if delay_constraints
 346                 $name ||= mk_name( $table_name, 'pk' )
 347                   if $options->{delay_constraints};
 348                 push @constraint_defs, ($name ? "CONSTRAINT $name " : '') .
 349                         'PRIMARY KEY (' . join( ', ', @fields ) . ')';
 350             }
 351             elsif ( $c->type eq UNIQUE ) {
 352                 # Don't create UNIQUE constraints identical to the primary key
 353                 if ( my $pk = $table->primary_key ) {
 354                                         my $u_fields = join(":", @fields);
 355                                         my $pk_fields = join(":", $pk->fields);
 356                                         next if $u_fields eq $pk_fields;
 357                 }
 358
 359                 $name ||= mk_name( $name || $table_name, 'u' );
 360
 361                 for my $f ( $c->fields ) {
 362                     my $field_def = $table->get_field( $f ) or next;
 363                     my $dtype     = $translate{ $field_def->data_type } or next;
 364                     if ( $WARN && $dtype =~ /clob/i ) {
 365                         warn "Oracle will not allow UNIQUE constraints on " .
 366                              "CLOB field '" . $field_def->table->name . '.' .
 367                              $field_def->name . ".'\n"
 368                     }
 369                 }
 370
 371                 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
 372                     '(' . join( ', ', @fields ) . ')';
 373             }
 374             elsif ( $c->type eq CHECK_C ) {
 375                 $name ||= mk_name( $name || $table_name, 'ck' );
 376                 my $expression = $c->expression || '';
 377                 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
 378             }
 379             elsif ( $c->type eq FOREIGN_KEY ) {
 380                 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
 381                 my $def = "CONSTRAINT $name FOREIGN KEY ";
 382
 383                 if ( @fields ) {
 384                     $def .= '(' . join( ', ', @fields ) . ')';
 385                 }
 386
 387                 my $ref_table = unreserve($c->reference_table);
 388
 389                 $def .= " REFERENCES $ref_table";
 390
 391                 if ( @rfields ) {
 392                     $def .= ' (' . join( ', ', @rfields ) . ')';
 393                 }
 394
 395                 if ( $c->match_type ) {
 396                     $def .= ' MATCH ' .
 397                         ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
 398                 }
 399
 400                 if ( $c->on_delete ) {
 401                     $def .= ' ON DELETE '.join( ' ', $c->on_delete );
 402                 }
 403
 404                 # disabled by plu 2007-12-29 - doesn't exist for oracle
 405                 #if ( $c->on_update ) {
 406                 #    $def .= ' ON UPDATE '.join( ' ', $c->on_update );
 407                 #}
 408
 409                 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_ur, $def);
 410             }
 411         }
 412
 413         #
 414         # Index Declarations
 415         #
 416         my @index_defs = ();
 417         for my $index ( $table->get_indices ) {
 418             my $index_name = $index->name || '';
 419             my $index_type = $index->type || NORMAL;
 420             my @fields     = map { unreserve( $_, $table_name ) }
 421                              $index->fields;
 422             next unless @fields;
 423
 424             my @index_options;
 425             for my $opt ( $index->options ) {
 426                 if ( ref $opt eq 'HASH' ) {
 427                     my ( $key, $value ) = each %$opt;
 428                     if ( ref $value eq 'ARRAY' ) {
 429                         push @table_options, "$key\n(\n".  join ("\n",
 430                             map { "  $_->[0]\t$_->[1]" }
 431                             map { [ each %$_ ] }
 432                            @$value
 433                         )."\n)";
 434                     }
 435                     elsif ( !defined $value ) {
 436                         push @index_options, $key;
 437                     }
 438                     else {
 439                         push @index_options, "$key    $value";
 440                     }
 441                 }
 442             }
 443             my $index_options = @index_options
 444               ? "\n".join("\n", @index_options) : '';
 445
 446             if ( $index_type eq PRIMARY_KEY ) {
 447                 $index_name = $index_name ? mk_name( $index_name )
 448                     : mk_name( $table_name, 'pk' );
 449                 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
 450                     '(' . join( ', ', @fields ) . ')';
 451             }
 452             elsif ( $index_type eq NORMAL ) {
 453                 $index_name = $index_name ? mk_name( $index_name )
 454                     : mk_name( $table_name, $index_name || 'i' );
 455                 push @index_defs,
 456                     "CREATE INDEX $index_name on $table_name_ur (".
 457                         join( ', ', @fields ).
 458                     ")$index_options";
 459             }
 460             elsif ( $index_type eq UNIQUE ) {
 461                 $index_name = $index_name ? mk_name( $index_name )
 462                     : mk_name( $table_name, $index_name || 'i' );
 463                 push @index_defs,
 464                     "CREATE UNIQUE INDEX $index_name on $table_name_ur (".
 465                         join( ', ', @fields ).
 466                     ")$index_options";
 467             }
 468             else {
 469                 warn "Unknown index type ($index_type) on table $table_name.\n"
 470                     if $WARN;
 471             }
 472         }
 473
 474         if ( my @table_comments = $table->comments ) {
 475             for my $comment ( @table_comments ) {
 476                 next unless $comment;
 477                 $comment =~ s/'/''/g;
 478                 push @field_comments, "COMMENT ON TABLE $table_name_ur is\n '".
 479                 $comment . "'" unless $options->{no_comments}
 480                 ;
 481             }
 482         }
 483
 484         my $table_options = @table_options
 485             ? "\n".join("\n", @table_options) : '';
 486     push @create, "CREATE TABLE $table_name_ur (\n" .
 487             join( ",\n", map { "  $_" } @field_defs,
 488             ($options->{delay_constraints} ? () : @constraint_defs) ) .
 489             "\n)$table_options";
 490
 491     @constraint_defs = map { 'ALTER TABLE '.$table_name_ur.' ADD '.$_  }
 492       @constraint_defs;
 493
 494     if ( $WARN ) {
 495         if ( %truncated ) {
 496             warn "Truncated " . keys( %truncated ) . " names:\n";
 497             warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
 498         }
 499
 500         if ( %unreserve ) {
 501             warn "Encounted " . keys( %unreserve ) .
 502                 " unsafe names in schema (reserved or invalid):\n";
 503             warn "\t" . join( "\n\t", sort keys %unreserve ) . "\n";
 504         }
 505     }
 506
 507     return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
 508 }
 509
 510 sub alter_field {
 511     my ($from_field, $to_field, $options) = @_;
 512
 513     my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 514       create_field($to_field, $options, {});
 515
 516     # Fix ORA-01442
 517     if ($to_field->is_nullable && !$from_field->is_nullable) {
 518         die 'Cannot remove NOT NULL from table field';
 519     } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
 520         @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
 521     }
 522
 523     my $table_name = $to_field->table->name;
 524     my $table_name_ur = unreserve( $table_name );
 525
 526     return 'ALTER TABLE '.$table_name_ur.' MODIFY ( '.join('', @$field_defs).' )';
 527 }
 528
 529 sub add_field {
 530     my ($new_field, $options) = @_;
 531
 532     my ($field_create, $field_defs, $trigger_defs, $field_comments) =
 533       create_field($new_field, $options, {});
 534
 535     my $table_name = $new_field->table->name;
 536     my $table_name_ur = unreserve( $table_name );
 537
 538     my $out = sprintf('ALTER TABLE %s ADD ( %s )',
 539                       $table_name_ur,
 540                       join('', @$field_defs));
 541     return $out;
 542 }
 543
 544 sub create_field {
 545     my ($field, $options, $field_name_scope) = @_;
 546
 547     my (@create, @field_defs, @trigger_defs, @field_comments);
 548
 549     my $table_name = $field->table->name;
 550     my $table_name_ur = unreserve( $table_name );
 551
 552     #
 553     # Field name
 554     #
 555     my $field_name    = mk_name(
 556                                 $field->name, '', $field_name_scope, 1
 557                                );
 558
 559     my $field_name_ur = unreserve( $field_name, $table_name );
 560     my $field_def     = $field_name_ur;
 561     $field->name( $field_name_ur );
 562
 563     #
 564     # Datatype
 565     #
 566     my $check;
 567     my $data_type = lc $field->data_type;
 568     my @size      = $field->size;
 569     my %extra     = $field->extra;
 570     my $list      = $extra{'list'} || [];
 571     # \todo deal with embedded quotes
 572     my $commalist = join( ', ', map { qq['$_'] } @$list );
 573
 574     if ( $data_type eq 'enum' ) {
 575         $check = "CHECK ($field_name_ur IN ($commalist))";
 576         $data_type = 'varchar2';
 577     }
 578     elsif ( $data_type eq 'set' ) {
 579         # XXX add a CHECK constraint maybe
 580         # (trickier and slower, than enum :)
 581         $data_type = 'varchar2';
 582     }
 583     else {
 584         $data_type  = defined $translate{ $data_type } ?
 585           $translate{ $data_type } :
 586             $data_type;
 587         $data_type ||= 'varchar2';
 588     }
 589
 590     # ensure size is not bigger than max size oracle allows for data type
 591     if ( defined $max_size{$data_type} ) {
 592         for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
 593             my $max =
 594               ref( $max_size{$data_type} ) eq 'ARRAY'
 595               ? $max_size{$data_type}->[$i]
 596               : $max_size{$data_type};
 597             $size[$i] = $max if $size[$i] > $max;
 598         }
 599     }
 600
 601     #
 602     # Fixes ORA-02329: column of datatype LOB cannot be
 603     # unique or a primary key
 604     #
 605     if ( $data_type eq 'clob' && $field->is_primary_key ) {
 606         $data_type = 'varchar2';
 607         $size[0]   = 4000;
 608         warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 609           if $WARN;
 610     }
 611
 612     if ( $data_type eq 'clob' && $field->is_unique ) {
 613         $data_type = 'varchar2';
 614         $size[0]   = 4000;
 615         warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
 616           if $WARN;
 617     }
 618
 619     #
 620     # Fixes ORA-00907: missing right parenthesis
 621     #
 622     if ( $data_type =~ /(date|clob)/i ) {
 623         undef @size;
 624     }
 625
 626     $field_def .= " $data_type";
 627     if ( defined $size[0] && $size[0] > 0 ) {
 628         $field_def .= '(' . join( ',', @size ) . ')';
 629     }
 630
 631     #
 632     # Default value
 633     #
 634     my $default = $field->default_value;
 635     if ( defined $default ) {
 636         #
 637         # Wherein we try to catch a string being used as
 638         # a default value for a numerical field.  If "true/false,"
 639         # then sub "1/0," otherwise just test the truthity of the
 640         # argument and use that (naive?).
 641         #
 642         if (ref $default and defined $$default) {
 643           $default = $$default;
 644         } elsif (ref $default) {
 645           $default = 'NULL';
 646         } elsif (
 647             $data_type =~ /^number$/i &&
 648             $default   !~ /^-?\d+$/     &&
 649             $default   !~ m/null/i
 650            ) {
 651             if ( $default =~ /^true$/i ) {
 652                 $default = "'1'";
 653             } elsif ( $default =~ /^false$/i ) {
 654                 $default = "'0'";
 655             } else {
 656                 $default = $default ? "'1'" : "'0'";
 657             }
 658         } elsif (
 659                  $data_type =~ /date/ && (
 660                                           $default eq 'current_timestamp'
 661                                           ||
 662                                           $default eq 'now()'
 663                                          )
 664                 ) {
 665             $default = 'SYSDATE';
 666         } else {
 667             $default = $default =~ m/null/i ? 'NULL' : "'$default'"
 668         }
 669
 670         $field_def .= " DEFAULT $default",
 671     }
 672
 673     #
 674     # Not null constraint
 675     #
 676     unless ( $field->is_nullable ) {
 677         $field_def .= ' NOT NULL';
 678     }
 679
 680     $field_def .= " $check" if $check;
 681
 682     #
 683     # Auto_increment
 684     #
 685     if ( $field->is_auto_increment ) {
 686         my $base_name    = $table_name_ur . "_". $field_name;
 687         my $seq_name     = mk_name( $base_name, 'sq' );
 688         my $trigger_name = mk_name( $base_name, 'ai' );
 689
 690         push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
 691         push @create, "CREATE SEQUENCE $seq_name";
 692         my $trigger =
 693           "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 694           "BEFORE INSERT ON $table_name_ur\n" .
 695           "FOR EACH ROW WHEN (\n" .
 696           " new.$field_name_ur IS NULL".
 697           " OR new.$field_name_ur = 0\n".
 698           ")\n".
 699           "BEGIN\n" .
 700           " SELECT $seq_name.nextval\n" .
 701           " INTO :new." . $field->name."\n" .
 702           " FROM dual;\n" .
 703           "END;\n";
 704
 705         push @trigger_defs, $trigger;
 706     }
 707
 708     if ( lc $field->data_type eq 'timestamp' ) {
 709         my $base_name = $table_name_ur . "_". $field_name_ur;
 710         my $trig_name = mk_name( $base_name, 'ts' );
 711         my $trigger =
 712           "CREATE OR REPLACE TRIGGER $trig_name\n".
 713           "BEFORE INSERT OR UPDATE ON $table_name_ur\n".
 714           "FOR EACH ROW WHEN (new.$field_name_ur IS NULL)\n".
 715           "BEGIN \n".
 716           " SELECT sysdate INTO :new.$field_name_ur FROM dual;\n".
 717           "END;\n";
 718
 719           push @trigger_defs, $trigger;
 720     }
 721
 722     push @field_defs, $field_def;
 723
 724     if ( my $comment = $field->comments ) {
 725         $comment =~ s/'/''/g;
 726         push @field_comments,
 727           "COMMENT ON COLUMN $table_name_ur.$field_name_ur is\n '" .
 728             $comment . "';" unless $options->{no_comments};
 729     }
 730
 731     return \@create, \@field_defs, \@trigger_defs, \@field_comments;
 732
 733 }
 734
 735
 736 sub create_view {
 737     my ($view, $options) = @_;
 738     my $view_name = $view->name;
 739
 740     my @create;
 741     push @create, qq[DROP VIEW $view_name]
 742         if $options->{add_drop_view};
 743
 744     push @create, sprintf("CREATE VIEW %s AS\n%s",
 745                       $view_name,
 746                       $view->sql);
 747
 748     return \@create;
 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 Youens-Clark E<lt>kclark@cpan.orgE<gt>.
 828
 829 =head1 SEE ALSO
 830
 831 SQL::Translator, DDL::Oracle, mysql2ora.
 832
 833 =cut