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