lib/SQL/Translator/Producer/Oracle.pm

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