Allow passing an arrayref to SQLT->filename
[dbsrgits/SQL-Translator.git] / 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