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