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 base 'SQL::Translator::Producer';
  97 use SQL::Translator::Schema::Constants;
  98 use SQL::Translator::Utils qw(header_comment);
  99
 100 my %translate  = (
 101     #
 102     # MySQL types
 103     #
 104     bigint     => 'number',
 105     double     => 'float',
 106     decimal    => 'number',
 107     float      => 'float',
 108     int        => 'number',
 109     integer    => 'number',
 110     mediumint  => 'number',
 111     smallint   => 'number',
 112     tinyint    => 'number',
 113     char       => 'char',
 114     varchar    => 'varchar2',
 115     tinyblob   => 'blob',
 116     blob       => 'blob',
 117     mediumblob => 'blob',
 118     longblob   => 'blob',
 119     tinytext   => 'varchar2',
 120     text       => 'clob',
 121     longtext   => 'clob',
 122     mediumtext => 'clob',
 123     enum       => 'varchar2',
 124     set        => 'varchar2',
 125     date       => 'date',
 126     datetime   => 'date',
 127     time       => 'date',
 128     timestamp  => 'date',
 129     year       => 'date',
 130
 131     #
 132     # PostgreSQL types
 133     #
 134     numeric             => 'number',
 135     'double precision'  => 'number',
 136     serial              => 'number',
 137     bigserial           => 'number',
 138     money               => 'number',
 139     character           => 'char',
 140     'character varying' => 'varchar2',
 141     bytea               => 'BLOB',
 142     interval            => 'number',
 143     boolean             => 'number',
 144     point               => 'number',
 145     line                => 'number',
 146     lseg                => 'number',
 147     box                 => 'number',
 148     path                => 'number',
 149     polygon             => 'number',
 150     circle              => 'number',
 151     cidr                => 'number',
 152     inet                => 'varchar2',
 153     macaddr             => 'varchar2',
 154     bit                 => 'number',
 155     'bit varying'       => 'number',
 156
 157     #
 158     # Oracle types
 159     #
 160     number              => 'number',
 161     varchar2            => 'varchar2',
 162     long                => 'clob',
 163 );
 164
 165 #
 166 # Oracle 8/9 max size of data types from:
 167 # http://www.ss64.com/orasyntax/datatypes.html
 168 #
 169 my %max_size = (
 170     char      => 2000,
 171     float     => 126,
 172     nchar     => 2000,
 173     nvarchar2 => 4000,
 174     number    => [ 38, 127 ],
 175     raw       => 2000,
 176     varchar   => 4000,          # only synonym for varchar2
 177     varchar2  => 4000,
 178 );
 179
 180 my $max_id_length    = 30;
 181 my %used_identifiers = ();
 182 my %global_names;
 183 my %truncated;
 184
 185 # Quote used to escape table, field, sequence and trigger names
 186 my $quote_char  = '"';
 187
 188 sub produce {
 189     my $translator     = shift;
 190     $DEBUG             = $translator->debug;
 191     $WARN              = $translator->show_warnings || 0;
 192     my $no_comments    = $translator->no_comments;
 193     my $add_drop_table = $translator->add_drop_table;
 194     my $schema         = $translator->schema;
 195     my $oracle_version  = $translator->producer_args->{oracle_version} || 0;
 196     my $delay_constraints = $translator->producer_args->{delay_constraints};
 197     my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
 198
 199     $create .= header_comment unless ($no_comments);
 200     my $qt = 1 if $translator->quote_table_names;
 201     my $qf = 1 if $translator->quote_field_names;
 202
 203     if ( $translator->parser_type =~ /mysql/i ) {
 204         $create .=
 205             "-- We assume that default NLS_DATE_FORMAT has been changed\n".
 206             "-- but we set it here anyway to be self-consistent.\n"
 207             unless $no_comments;
 208
 209         $create .=
 210         "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
 211     }
 212
 213     for my $table ( $schema->get_tables ) {
 214         my ( $table_def, $fk_def, $trigger_def, $index_def, $constraint_def ) = create_table(
 215             $table,
 216             {
 217                 add_drop_table    => $add_drop_table,
 218                 show_warnings     => $WARN,
 219                 no_comments       => $no_comments,
 220                 delay_constraints => $delay_constraints,
 221                 quote_table_names => $qt,
 222                 quote_field_names => $qf,
 223             }
 224         );
 225         push @table_defs, @$table_def;
 226         push @fk_defs, @$fk_def;
 227         push @trigger_defs, @$trigger_def;
 228         push @index_defs, @$index_def;
 229         push @constraint_defs, @$constraint_def;
 230     }
 231
 232     my (@view_defs);
 233     foreach my $view ( $schema->get_views ) {
 234         my ( $view_def ) = create_view(
 235             $view,
 236             {
 237                 add_drop_view     => $add_drop_table,
 238                 quote_table_names => $qt,
 239             }
 240         );
 241         push @view_defs, @$view_def;
 242     }
 243
 244     if (wantarray) {
 245         return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
 246     }
 247     else {
 248         $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
 249         $create .= ";\n\n";
 250         # If wantarray is not set we have to add "/" in this statement
 251         # DBI->do() needs them omitted
 252         # triggers may NOT end with a semicolon but a "/" instead
 253         $create .= "$_/\n\n"
 254             for @trigger_defs;
 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 = __PACKAGE__->_quote_string($comment);
 466                 push @field_comments, "COMMENT ON TABLE $table_name_q is\n $comment"
 467                     unless $options->{no_comments};
 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     my $commalist = join( ', ', map { __PACKAGE__->_quote_string($_) } @$list );
 554
 555     if ( $data_type eq 'enum' ) {
 556         $check = "CHECK ($field_name_q IN ($commalist))";
 557         $data_type = 'varchar2';
 558     }
 559     elsif ( $data_type eq 'set' ) {
 560         # XXX add a CHECK constraint maybe
 561         # (trickier and slower, than enum :)
 562         $data_type = 'varchar2';
 563     }
 564     else {
 565       if (defined $translate{ $data_type }) {
 566         if (ref $translate{ $data_type } eq "ARRAY") {
 567           ($data_type,$size[0])  = @{$translate{ $data_type }};
 568         } else {
 569           $data_type  = $translate{ $data_type };
 570         }
 571       }
 572       $data_type ||= 'varchar2';
 573     }
 574
 575     # ensure size is not bigger than max size oracle allows for data type
 576     if ( defined $max_size{$data_type} ) {
 577         for ( my $i = 0 ; $i < scalar @size ; $i++ ) {
 578             my $max =
 579               ref( $max_size{$data_type} ) eq 'ARRAY'
 580               ? $max_size{$data_type}->[$i]
 581               : $max_size{$data_type};
 582             $size[$i] = $max if $size[$i] > $max;
 583         }
 584     }
 585
 586     #
 587     # Fixes ORA-02329: column of datatype LOB cannot be
 588     # unique or a primary key
 589     #
 590     if ( $data_type eq 'clob' && $field->is_primary_key ) {
 591         $data_type = 'varchar2';
 592         $size[0]   = 4000;
 593         warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
 594           if $WARN;
 595     }
 596
 597     if ( $data_type eq 'clob' && $field->is_unique ) {
 598         $data_type = 'varchar2';
 599         $size[0]   = 4000;
 600         warn "CLOB cannot be a unique key, changing to VARCHAR2\n"
 601           if $WARN;
 602     }
 603
 604     #
 605     # Fixes ORA-00907: missing right parenthesis
 606     #
 607     if ( $data_type =~ /(date|clob)/i ) {
 608         undef @size;
 609     }
 610
 611     #
 612     # Fixes ORA-00906: missing right parenthesis
 613       # if size is 0 or undefined
 614     #
 615     for (qw/varchar2/) {
 616         if ( $data_type =~ /^($_)$/i ) {
 617             $size[0] ||= $max_size{$_};
 618         }
 619     }
 620
 621     $field_def .= " $data_type";
 622     if ( defined $size[0] && $size[0] > 0 ) {
 623         $field_def .= '(' . join( ',', @size ) . ')';
 624     }
 625
 626     #
 627     # Default value
 628     #
 629     my $default = $field->default_value;
 630     if ( defined $default ) {
 631         #
 632         # Wherein we try to catch a string being used as
 633         # a default value for a numerical field.  If "true/false,"
 634         # then sub "1/0," otherwise just test the truthity of the
 635         # argument and use that (naive?).
 636         #
 637         if (ref $default and defined $$default) {
 638           $default = $$default;
 639         } elsif (ref $default) {
 640           $default = 'NULL';
 641         } elsif (
 642             $data_type =~ /^number$/i &&
 643             $default   !~ /^-?\d+$/     &&
 644             $default   !~ m/null/i
 645            ) {
 646             if ( $default =~ /^true$/i ) {
 647                 $default = "'1'";
 648             } elsif ( $default =~ /^false$/i ) {
 649                 $default = "'0'";
 650             } else {
 651                 $default = $default ? "'1'" : "'0'";
 652             }
 653         } elsif (
 654                  $data_type =~ /date/ && (
 655                                           $default eq 'current_timestamp'
 656                                           ||
 657                                           $default eq 'now()'
 658                                          )
 659                 ) {
 660             $default = 'SYSDATE';
 661         } else {
 662             $default = $default =~ m/null/i ? 'NULL' : __PACKAGE__->_quote_string($default);
 663         }
 664
 665         $field_def .= " DEFAULT $default",
 666     }
 667
 668     #
 669     # Not null constraint
 670     #
 671     unless ( $field->is_nullable ) {
 672         $field_def .= ' NOT NULL';
 673     }
 674
 675     $field_def .= " $check" if $check;
 676
 677     #
 678     # Auto_increment
 679     #
 680     if ( $field->is_auto_increment ) {
 681         my $base_name    = $table_name . "_". $field_name;
 682         my $seq_name     = quote(mk_name( $base_name, 'sq' ),$qt);
 683         my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
 684
 685         push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
 686         push @create, "CREATE SEQUENCE $seq_name";
 687         my $trigger =
 688           "CREATE OR REPLACE TRIGGER $trigger_name\n" .
 689           "BEFORE INSERT ON $table_name_q\n" .
 690           "FOR EACH ROW WHEN (\n" .
 691           " new.$field_name_q IS NULL".
 692           " OR new.$field_name_q = 0\n".
 693           ")\n".
 694           "BEGIN\n" .
 695           " SELECT $seq_name.nextval\n" .
 696           " INTO :new." . $field_name_q."\n" .
 697           " FROM dual;\n" .
 698           "END;\n";
 699
 700         push @trigger_defs, $trigger;
 701     }
 702
 703     if ( lc $field->data_type eq 'timestamp' ) {
 704         my $base_name = $table_name . "_". $field_name;
 705         my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
 706         my $trigger =
 707           "CREATE OR REPLACE TRIGGER $trig_name\n".
 708           "BEFORE INSERT OR UPDATE ON $table_name_q\n".
 709           "FOR EACH ROW WHEN (new.$field_name_q IS NULL)\n".
 710           "BEGIN\n".
 711           " SELECT sysdate INTO :new.$field_name_q FROM dual;\n".
 712           "END;\n";
 713
 714           push @trigger_defs, $trigger;
 715     }
 716
 717     push @field_defs, $field_def;
 718
 719     if ( my $comment = $field->comments ) {
 720         $comment =~ __PACKAGE__->_quote_string($comment);
 721         push @field_comments,
 722           "COMMENT ON COLUMN $table_name_q.$field_name_q is\n $comment;"
 723               unless $options->{no_comments};
 724     }
 725
 726     return \@create, \@field_defs, \@trigger_defs, \@field_comments;
 727
 728 }
 729
 730
 731 sub create_view {
 732     my ($view, $options) = @_;
 733     my $qt = $options->{quote_table_names};
 734     my $view_name = quote($view->name,$qt);
 735
 736     my @create;
 737     push @create, qq[DROP VIEW $view_name]
 738         if $options->{add_drop_view};
 739
 740     push @create, sprintf("CREATE VIEW %s AS\n%s",
 741                       $view_name,
 742                       $view->sql);
 743
 744     return \@create;
 745 }
 746
 747 sub mk_name {
 748     my $basename      = shift || '';
 749     my $type          = shift || '';
 750        $type          = '' if $type =~ /^\d/;
 751     my $scope         = shift || '';
 752     my $critical      = shift || '';
 753     my $basename_orig = $basename;
 754     my $max_name      = $type
 755                         ? $max_id_length - (length($type) + 1)
 756                         : $max_id_length;
 757     $basename         = substr( $basename, 0, $max_name )
 758                         if length( $basename ) > $max_name;
 759     my $name          = $type ? "${type}_$basename" : $basename;
 760
 761     if ( $basename ne $basename_orig and $critical ) {
 762         my $show_type = $type ? "+'$type'" : "";
 763         warn "Truncating '$basename_orig'$show_type to $max_id_length ",
 764             "character limit to make '$name'\n" if $WARN;
 765         $truncated{ $basename_orig } = $name;
 766     }
 767
 768     $scope ||= \%global_names;
 769     if ( my $prev = $scope->{ $name } ) {
 770         my $name_orig = $name;
 771         substr($name, $max_id_length - 2) = ""
 772             if length( $name ) >= $max_id_length - 1;
 773         $name        .= sprintf( "%02d", $prev++ );
 774
 775         warn "The name '$name_orig' has been changed to ",
 776              "'$name' to make it unique.\n" if $WARN;
 777
 778         $scope->{ $name_orig }++;
 779     }
 780
 781     $scope->{ $name }++;
 782     return $name;
 783 }
 784
 785 1;
 786
 787 sub quote {
 788   my ($name, $q) = @_;
 789   return $name unless $q && $name;
 790   $name =~ s/\Q$quote_char/$quote_char$quote_char/g;
 791   return "$quote_char$name$quote_char";
 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