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 vars qw[ $VERSION $DEBUG $WARN ];
  92 $VERSION = '1.59';
  93 $DEBUG   = 0 unless defined $DEBUG;
  94
  95 use SQL::Translator::Schema::Constants;
  96 use SQL::Translator::Utils qw(header_comment);
  97
  98 my %translate  = (
  99     #
 100     # MySQL types
 101     #
 102     bigint     => 'number',
 103     double     => 'float',
 104     decimal    => 'number',
 105     float      => 'float',
 106     int        => 'number',
 107     integer    => 'number',
 108     mediumint  => 'number',
 109     smallint   => 'number',
 110     tinyint    => 'number',
 111     char       => 'char',
 112     varchar    => 'varchar2',
 113     tinyblob   => 'blob',
 114     blob       => 'blob',
 115     mediumblob => 'blob',
 116     longblob   => 'blob',
 117     tinytext   => 'varchar2',
 118     text       => 'clob',
 119     longtext   => 'clob',
 120     mediumtext => 'clob',
 121     enum       => 'varchar2',
 122     set        => 'varchar2',
 123     date       => 'date',
 124     datetime   => 'date',
 125     time       => 'date',
 126     timestamp  => 'date',
 127     year       => 'date',
 128
 129     #
 130     # PostgreSQL types
 131     #
 132     numeric             => 'number',
 133     'double precision'  => 'number',
 134     serial              => 'number',
 135     bigserial           => 'number',
 136     money               => 'number',
 137     character           => 'char',
 138     'character varying' => 'varchar2',
 139     bytea               => 'BLOB',
 140     interval            => 'number',
 141     boolean             => 'number',
 142     point               => 'number',
 143     line                => 'number',
 144     lseg                => 'number',
 145     box                 => 'number',
 146     path                => 'number',
 147     polygon             => 'number',
 148     circle              => 'number',
 149     cidr                => 'number',
 150     inet                => 'varchar2',
 151     macaddr             => 'varchar2',
 152     bit                 => 'number',
 153     'bit varying'       => 'number',
 154
 155     #
 156     # Oracle types
 157     #
 158     number              => 'number',
 159     varchar2            => 'varchar2',
 160     long                => 'clob',
 161 );
 162
 163 #
 164 # Oracle 8/9 max size of data types from:
 165 # http://www.ss64.com/orasyntax/datatypes.html
 166 #
 167 my %max_size = (
 168     char      => 2000,
 169     float     => 126,
 170     nchar     => 2000,
 171     nvarchar2 => 4000,
 172     number    => [ 38, 127 ],
 173     raw       => 2000,
 174     varchar   => 4000,          # only synonym for varchar2
 175     varchar2  => 4000,
 176 );
 177
 178 my $max_id_length    = 30;
 179 my %used_identifiers = ();
 180 my %global_names;
 181 my %truncated;
 182
 183 # Quote used to escape table, field, sequence and trigger names
 184 my $quote_char  = '"';
 185
 186 sub produce {
 187     my $translator     = shift;
 188     $DEBUG             = $translator->debug;
 189     $WARN              = $translator->show_warnings || 0;
 190     my $no_comments    = $translator->no_comments;
 191     my $add_drop_table = $translator->add_drop_table;
 192     my $schema         = $translator->schema;
 193     my $oracle_version  = $translator->producer_args->{oracle_version} || 0;
 194     my $delay_constraints = $translator->producer_args->{delay_constraints};
 195     my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
 196
 197     $create .= header_comment unless ($no_comments);
 198     my $qt = 1 if $translator->quote_table_names;
 199     my $qf = 1 if $translator->quote_field_names;
 200
 201     if ( $translator->parser_type =~ /mysql/i ) {
 202         $create .=
 203             "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 204             "-- but we set it here anyway to be self-consistent.\n"
 205             unless $no_comments;
 206
 207         $create .=
 208         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 209     }
 210
 211     for my $table ( $schema->get_tables ) {
 212         my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
 213             $table,
 214             {
 215                 add_drop_table    => $add_drop_table,
 216                 show_warnings     => $WARN,
 217                 no_comments       => $no_comments,
 218                 delay_constraints => $delay_constraints,
 219                 quote_table_names => $qt,
 220                 quote_field_names => $qf,
 221             }
 222         );
 223         push @table_defs, @$table_def;
 224         push @fk_defs, @$fk_def;
 225         push @trigger_defs, @$trigger_def;
 226         push @index_defs, @$index_def;
 227         push @constraint_defs, @$constraint_def;
 228     }
 229
 230     my (@view_defs);
 231     foreach my $view ( $schema->get_views ) {
 232         my ( $view_def ) = create_view(
 233             $view,
 234             {
 235                 add_drop_view     => $add_drop_table,
 236                 quote_table_names => $qt,
 237             }
 238         );
 239         push @view_defs, @$view_def;
 240     }
 241
 242     if (wantarray) {
 243         return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
 244     }
 245     else {
 246         $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
 247         $create .= ";\n\n";
 248         # If wantarray is not set we have to add "/" in this statement
 249         # DBI->do() needs them omitted
 250         # triggers may NOT end with a semicolon
 251         $create .= join "/\n\n", @trigger_defs;
 252         # for last trigger
 253         $create .= "/\n\n";
 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   $q && $name ? "$quote_char$name$quote_char" : $name;
 791 }
 792
 793
 794 # -------------------------------------------------------------------
 795 # All bad art is the result of good intentions.
 796 # Oscar Wilde
 797 # -------------------------------------------------------------------
 798
 799 =pod
 800
 801 =head1 CREDITS
 802
 803 Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
 804 script.
 805
 806 =head1 AUTHORS
 807
 808 Ken Youens-Clark E<lt>kclark@cpan.orgE<gt>,
 809 Alexander Hartmaier E<lt>abraxxa@cpan.orgE<gt>,
 810 Fabien Wernli E<lt>faxmodem@cpan.orgE<gt>.
 811
 812 =head1 SEE ALSO
 813
 814 SQL::Translator, DDL::Oracle, mysql2ora.
 815
 816 =cut