File Coverage

blib/lib/SQL/Translator/Producer/Oracle.pm
Criterion Covered Total %
statement 255 297 85.8
branch 134 202 66.3
condition 48 89 53.9
subroutine 13 13 100.0
pod 6 8 75.0
total 456 609 74.8


line stmt bran cond sub pod time code
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, 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 like
82             L does.
83              
84             To get this working we removed the slash in those statements in version
85             0.09002 of L 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 10     10   3517 use strict;
  10         22  
  10         271  
91 10     10   50 use warnings;
  10         21  
  10         586  
92             our ( $DEBUG, $WARN );
93             our $VERSION = '1.6_3';
94             $DEBUG = 0 unless defined $DEBUG;
95              
96 10     10   63 use base 'SQL::Translator::Producer';
  10         22  
  10         1564  
97 10     10   76 use SQL::Translator::Schema::Constants;
  10         21  
  10         719  
98 10     10   55 use SQL::Translator::Utils qw(header_comment);
  10         20  
  10         36381  
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 10     10 1 21 my $translator = shift;
190 10         38 $DEBUG = $translator->debug;
191 10   50     242 $WARN = $translator->show_warnings || 0;
192 10         391 my $no_comments = $translator->no_comments;
193 10         198 my $add_drop_table = $translator->add_drop_table;
194 10         213 my $schema = $translator->schema;
195 10   50     243 my $oracle_version = $translator->producer_args->{oracle_version} || 0;
196 10         162 my $delay_constraints = $translator->producer_args->{delay_constraints};
197 10         25 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
198              
199 10 100       57 $create .= header_comment unless ($no_comments);
200 10 100       43 my $qt = 1 if $translator->quote_table_names;
201 10 100       111 my $qf = 1 if $translator->quote_field_names;
202              
203 10 100       211 if ( $translator->parser_type =~ /mysql/i ) {
204 1 50       4 $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 1         2 $create .=
210             "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
211             }
212              
213 10         58 for my $table ( $schema->get_tables ) {
214 20         146 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 20         85 push @table_defs, @$table_def;
226 20         39 push @fk_defs, @$fk_def;
227 20         41 push @trigger_defs, @$trigger_def;
228 20         39 push @index_defs, @$index_def;
229 20         58 push @constraint_defs, @$constraint_def;
230             }
231              
232 10         22 my (@view_defs);
233 10         53 foreach my $view ( $schema->get_views ) {
234 5         36 my ( $view_def ) = create_view(
235             $view,
236             {
237             add_drop_view => $add_drop_table,
238             quote_table_names => $qt,
239             }
240             );
241 5         20 push @view_defs, @$view_def;
242             }
243              
244 10 100       41 if (wantarray) {
245 2 50       18 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
246             }
247             else {
248 8         81 $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
249 8         22 $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 8         52 for @trigger_defs;
255 8         409 return $create;
256             }
257             }
258              
259             sub create_table {
260 21     21 1 59 my ($table, $options) = @_;
261 21         55 my $qt = $options->{quote_table_names};
262 21         43 my $qf = $options->{quote_field_names};
263 21         385 my $table_name = $table->name;
264 21         434 my $table_name_q = quote($table_name,$qt);
265              
266 21         52 my $item = '';
267 21         35 my $drop;
268 21         44 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
269              
270 21 100       74 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
271 21 100       101 push @create, qq[DROP TABLE $table_name_q CASCADE CONSTRAINTS] if $options->{add_drop_table};
272              
273 21         44 my ( %field_name_scope, @field_comments );
274 21         82 for my $field ( $table->get_fields ) {
275 84         227 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
276             create_field($field, $options, \%field_name_scope);
277 84 50       291 push @create, @$field_create if ref $field_create;
278 84 50       227 push @field_defs, @$field_defs if ref $field_defs;
279 84 50       200 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
280 84 50       252 push @field_comments, @$field_comments if ref $field_comments;
281             }
282              
283             #
284             # Table options
285             #
286 21         47 my @table_options;
287 21         380 for my $opt ( $table->options ) {
288 7 100       27 if ( ref $opt eq 'HASH' ) {
289 5         20 my ( $key, $value ) = each %$opt;
290 5 50       32 if ( ref $value eq 'ARRAY' ) {
    50          
291             push @table_options, "$key\n(\n". join ("\n",
292 0         0 map { " $_->[0]\t$_->[1]" }
293 0         0 map { [ each %$_ ] }
  0         0  
294             @$value
295             )."\n)";
296             }
297             elsif ( !defined $value ) {
298 0         0 push @table_options, $key;
299             }
300             else {
301 5         33 push @table_options, "$key $value";
302             }
303             }
304             }
305              
306             #
307             # Table constraints
308             #
309 21         87 for my $c ( $table->get_constraints ) {
310 35   100     818 my $name = $c->name || '';
311 35         121 my @fields = map { quote($_,$qf) } $c->fields;
  36         106  
312 35         983 my @rfields = map { quote($_,$qf) } $c->reference_fields;
  8         22  
313              
314 35 50 33     159 next if !@fields && $c->type ne CHECK_C;
315              
316 35 100       627 if ( $c->type eq PRIMARY_KEY ) {
    100          
    50          
    50          
317             # create a name if delay_constraints
318             $name ||= mk_name( $table_name, 'pk' )
319 18 100 33     369 if $options->{delay_constraints};
320 18         56 $name = quote($name,$qf);
321 18 100       117 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 10 50       174 if ( my $pk = $table->primary_key ) {
327 10         202 my $u_fields = join(":", @fields);
328 10         96 my $pk_fields = join(":", $pk->fields);
329 10 50       177 next if $u_fields eq $pk_fields;
330             }
331              
332 10 50       37 if ($name) {
333             # Force prepend of table_name as ORACLE doesn't allow duplicate
334             # CONSTRAINT names even for different tables (ORA-02264)
335 10 50       102 $name = mk_name( "${table_name}_$name", 'u' ) unless $name =~ /^$table_name/;
336             }
337             else {
338 0         0 $name = mk_name( $table_name, 'u' );
339             }
340              
341 10         28 $name = quote($name, $qf);
342              
343 10         36 for my $f ( $c->fields ) {
344 10 50       34 my $field_def = $table->get_field( $f ) or next;
345 10 50       252 my $dtype = $translate{ ref $field_def->data_type eq "ARRAY" ? $field_def->data_type->[0] : $field_def->data_type} or next;
    50          
346 10 50 33     38 if ( $WARN && $dtype =~ /clob/i ) {
347 0         0 warn "Oracle will not allow UNIQUE constraints on " .
348             "CLOB field '" . $field_def->table->name . '.' .
349             $field_def->name . ".'\n"
350             }
351             }
352              
353 10         61 push @constraint_defs, "CONSTRAINT $name UNIQUE " .
354             '(' . join( ', ', @fields ) . ')';
355             }
356             elsif ( $c->type eq CHECK_C ) {
357 0   0     0 $name ||= mk_name( $name || $table_name, 'ck' );
      0        
358 0         0 $name = quote($name, $qf);
359 0   0     0 my $expression = $c->expression || '';
360 0         0 push @constraint_defs, "CONSTRAINT $name CHECK ($expression)";
361             }
362             elsif ( $c->type eq FOREIGN_KEY ) {
363 7         138 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
364 7         23 $name = quote($name, $qf);
365 7   50     141 my $on_delete = uc ($c->on_delete || '');
366              
367 7         27 my $def = "CONSTRAINT $name FOREIGN KEY ";
368              
369 7 50       23 if ( @fields ) {
370 7         31 $def .= '(' . join( ', ', @fields ) . ')';
371             }
372              
373 7         85 my $ref_table = quote($c->reference_table,$qt);
374              
375 7         30 $def .= " REFERENCES $ref_table";
376              
377 7 50       24 if ( @rfields ) {
378 7         51 $def .= ' (' . join( ', ', @rfields ) . ')';
379             }
380              
381 7 50       170 if ( $c->match_type ) {
382 0 0       0 $def .= ' MATCH ' .
383             ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
384             }
385              
386 7 50 33     146 if ( $on_delete && $on_delete ne "RESTRICT") {
387 0         0 $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 7         63 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
396             }
397             }
398              
399             #
400             # Index Declarations
401             #
402 21         135 my @index_defs = ();
403 21         78 for my $index ( $table->get_indices ) {
404 11   50     258 my $index_name = $index->name || '';
405 11   50     276 my $index_type = $index->type || NORMAL;
406 11         445 my @fields = map { quote($_, $qf) } $index->fields;
  12         34  
407 11 50       36 next unless @fields;
408              
409 11         25 my @index_options;
410 11         210 for my $opt ( $index->options ) {
411 3 50       13 if ( ref $opt eq 'HASH' ) {
412 3         14 my ( $key, $value ) = each %$opt;
413 3 50       25 if ( ref $value eq 'ARRAY' ) {
    50          
414             push @table_options, "$key\n(\n". join ("\n",
415 0         0 map { " $_->[0]\t$_->[1]" }
416 0         0 map { [ each %$_ ] }
  0         0  
417             @$value
418             )."\n)";
419             }
420             elsif ( !defined $value ) {
421 0         0 push @index_options, $key;
422             }
423             else {
424 3         21 push @index_options, "$key $value";
425             }
426             }
427             }
428 11 100       54 my $index_options = @index_options
429             ? "\n".join("\n", @index_options) : '';
430              
431 11 50       61 if ( $index_type eq PRIMARY_KEY ) {
    100          
    50          
432 0 0       0 $index_name = $index_name ? mk_name( $index_name )
433             : mk_name( $table_name, 'pk' );
434 0         0 $index_name = quote($index_name, $qf);
435 0         0 push @field_defs, 'CONSTRAINT '.$index_name.' PRIMARY KEY '.
436             '(' . join( ', ', @fields ) . ')';
437             }
438             elsif ( $index_type eq NORMAL ) {
439 10 50 0     49 $index_name = $index_name ? mk_name( $index_name )
440             : mk_name( $table_name, $index_name || 'i' );
441 10         31 $index_name = quote($index_name, $qf);
442 10         85 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 1 50 0     5 $index_name = $index_name ? mk_name( $index_name )
449             : mk_name( $table_name, $index_name || 'i' );
450 1         3 $index_name = quote($index_name, $qf);
451 1         9 push @index_defs,
452             "CREATE UNIQUE INDEX $index_name on $table_name_q (".
453             join( ', ', @fields ).
454             ")$index_options";
455             }
456             else {
457 0 0       0 warn "Unknown index type ($index_type) on table $table_name.\n"
458             if $WARN;
459             }
460             }
461              
462 21 50       414 if ( my @table_comments = $table->comments ) {
463 0         0 for my $comment ( @table_comments ) {
464 0 0       0 next unless $comment;
465 0         0 $comment = __PACKAGE__->_quote_string($comment);
466             push @field_comments, "COMMENT ON TABLE $table_name_q is\n $comment"
467 0 0       0 unless $options->{no_comments};
468             }
469             }
470              
471 21 100       86 my $table_options = @table_options
472             ? "\n".join("\n", @table_options) : '';
473             push @create, "CREATE TABLE $table_name_q (\n" .
474 110         301 join( ",\n", map { " $_" } @field_defs,
475 21 100       149 ($options->{delay_constraints} ? () : @constraint_defs) ) .
476             "\n)$table_options";
477              
478 21         58 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
  28         88  
479             @constraint_defs;
480              
481 21 50       63 if ( $WARN ) {
482 0 0       0 if ( %truncated ) {
483 0         0 warn "Truncated " . keys( %truncated ) . " names:\n";
484 0         0 warn "\t" . join( "\n\t", sort keys %truncated ) . "\n";
485             }
486             }
487              
488 21 100       173 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
489             }
490              
491             sub alter_field {
492 2     2 1 22 my ($from_field, $to_field, $options) = @_;
493              
494 2         5 my $qt = $options->{quote_table_names};
495 2         13 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
496             create_field($to_field, $options, {});
497              
498             # Fix ORA-01442
499 2 50 33     31 if ($to_field->is_nullable && !$from_field->is_nullable) {
    100 66        
500 0         0 die 'Cannot remove NOT NULL from table field';
501             } elsif (!$from_field->is_nullable && !$to_field->is_nullable) {
502 1         37 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
  1         6  
  1         6  
503             }
504              
505 2         51 my $table_name = quote($to_field->table->name,$qt);
506              
507 2         11 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
508             }
509              
510             sub add_field {
511 1     1 1 15 my ($new_field, $options) = @_;
512              
513 1         3 my $qt = $options->{quote_table_names};
514 1         4 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
515             create_field($new_field, $options, {});
516              
517 1         16 my $table_name = quote($new_field->table->name,$qt);
518              
519 1         6 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
520             $table_name,
521             join('', @$field_defs));
522 1         4 return $out;
523             }
524              
525             sub create_field {
526 87     87 1 172 my ($field, $options, $field_name_scope) = @_;
527 87         169 my $qf = $options->{quote_field_names};
528 87         166 my $qt = $options->{quote_table_names};
529              
530 87         207 my (@create, @field_defs, @trigger_defs, @field_comments);
531              
532 87         1476 my $table_name = $field->table->name;
533 87         1472 my $table_name_q = quote($table_name, $qt);
534              
535             #
536             # Field name
537             #
538 87         1462 my $field_name = mk_name(
539             $field->name, '', $field_name_scope, 1
540             );
541 87         206 my $field_name_q = quote($field_name, $qf);
542 87         173 my $field_def = quote($field_name, $qf);
543 87         1591 $field->name( $field_name );
544              
545             #
546             # Datatype
547             #
548 87         216 my $check;
549 87         301 my $data_type = lc $field->data_type;
550 87         1396 my @size = $field->size;
551 87         2132 my %extra = $field->extra;
552 87   100     409 my $list = $extra{'list'} || [];
553 87         237 my $commalist = join( ', ', map { __PACKAGE__->_quote_string($_) } @$list );
  2         9  
554              
555 87 100       271 if ( $data_type eq 'enum' ) {
    50          
556 1         3 $check = "CHECK ($field_name_q IN ($commalist))";
557 1         3 $data_type = 'varchar2';
558             }
559             elsif ( $data_type eq 'set' ) {
560             # XXX add a CHECK constraint maybe
561             # (trickier and slower, than enum :)
562 0         0 $data_type = 'varchar2';
563             }
564             else {
565 86 100       262 if (defined $translate{ $data_type }) {
566 82 50       183 if (ref $translate{ $data_type } eq "ARRAY") {
567 0         0 ($data_type,$size[0]) = @{$translate{ $data_type }};
  0         0  
568             } else {
569 82         160 $data_type = $translate{ $data_type };
570             }
571             }
572 86   50     194 $data_type ||= 'varchar2';
573             }
574              
575             # ensure size is not bigger than max size oracle allows for data type
576 87 100       228 if ( defined $max_size{$data_type} ) {
577 73         225 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 81 100       283 : $max_size{$data_type};
582 81 50       351 $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 87 100 100     372 if ( $data_type eq 'clob' && $field->is_primary_key ) {
591 1         11 $data_type = 'varchar2';
592 1         4 $size[0] = 4000;
593 1 50       5 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
594             if $WARN;
595             }
596              
597 87 50 66     516 if ( $data_type eq 'clob' && $field->is_unique ) {
598 0         0 $data_type = 'varchar2';
599 0         0 $size[0] = 4000;
600 0 0       0 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 87 100       459 if ( $data_type =~ /(date|clob)/i ) {
608 13         29 undef @size;
609             }
610              
611             #
612             # Fixes ORA-00906: missing right parenthesis
613             # if size is 0 or undefined
614             #
615 87         177 for (qw/varchar2/) {
616 87 100       538 if ( $data_type =~ /^($_)$/i ) {
617 38   66     135 $size[0] ||= $max_size{$_};
618             }
619             }
620              
621 87         230 $field_def .= " $data_type";
622 87 100 100     342 if ( defined $size[0] && $size[0] > 0 ) {
623 71         229 $field_def .= '(' . join( ',', @size ) . ')';
624             }
625              
626             #
627             # Default value
628             #
629 87         247 my $default = $field->default_value;
630 87 100       209 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 35 50 33     349 if (ref $default and defined $$default) {
    50 100        
    100 66        
    50 0        
      33        
638 0         0 $default = $$default;
639             } elsif (ref $default) {
640 0         0 $default = 'NULL';
641             } elsif (
642             $data_type =~ /^number$/i &&
643             $default !~ /^-?\d+$/ &&
644             $default !~ m/null/i
645             ) {
646 1 50       11 if ( $default =~ /^true$/i ) {
    50          
647 0         0 $default = "'1'";
648             } elsif ( $default =~ /^false$/i ) {
649 0         0 $default = "'0'";
650             } else {
651 1 50       4 $default = $default ? "'1'" : "'0'";
652             }
653             } elsif (
654             $data_type =~ /date/ && (
655             $default eq 'current_timestamp'
656             ||
657             $default eq 'now()'
658             )
659             ) {
660 0         0 $default = 'SYSDATE';
661             } else {
662 34 50       225 $default = $default =~ m/null/i ? 'NULL' : __PACKAGE__->_quote_string($default);
663             }
664              
665 35         88 $field_def .= " DEFAULT $default",
666             }
667              
668             #
669             # Not null constraint
670             #
671 87 100       1689 unless ( $field->is_nullable ) {
672 35         1342 $field_def .= ' NOT NULL';
673             }
674              
675 87 100       2176 $field_def .= " $check" if $check;
676              
677             #
678             # Auto_increment
679             #
680 87 100       1209 if ( $field->is_auto_increment ) {
681 15         123 my $base_name = $table_name . "_". $field_name;
682 15         41 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
683 15         41 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
684              
685 15 100       62 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
686 15         43 push @create, "CREATE SEQUENCE $seq_name";
687 15         139 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 15         38 push @trigger_defs, $trigger;
701             }
702              
703 87 100       919 if ( lc $field->data_type eq 'timestamp' ) {
704 6         21 my $base_name = $table_name . "_". $field_name;
705 6         21 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
706 6         55 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 6         15 push @trigger_defs, $trigger;
715             }
716              
717 87         202 push @field_defs, $field_def;
718              
719 87 100       1459 if ( my $comment = $field->comments ) {
720 5         52 $comment =~ __PACKAGE__->_quote_string($comment);
721             push @field_comments,
722             "COMMENT ON COLUMN $table_name_q.$field_name_q is\n $comment;"
723 5 50       19 unless $options->{no_comments};
724             }
725              
726 87         1018 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
727              
728             }
729              
730              
731             sub create_view {
732 6     6 1 43 my ($view, $options) = @_;
733 6         15 my $qt = $options->{quote_table_names};
734 6         24 my $view_name = quote($view->name,$qt);
735 6         125 my $extra = $view->extra;
736              
737 6         15 my $view_type = 'VIEW';
738 6         11 my $view_options = '';
739 6 100       23 if ( my $materialized = $extra->{materialized} ) {
740 1         2 $view_type = 'MATERIALIZED VIEW';
741 1         3 $view_options .= ' '.$materialized;
742             }
743              
744 6         12 my @create;
745             push @create, qq[DROP $view_type $view_name]
746 6 100       27 if $options->{add_drop_view};
747              
748 6         47 push @create, sprintf("CREATE %s %s%s AS\n%s",
749             $view_type,
750             $view_name,
751             $view_options,
752             $view->sql);
753              
754 6         20 return \@create;
755             }
756              
757             sub mk_name {
758 153   50 153 0 1887 my $basename = shift || '';
759 153   100     482 my $type = shift || '';
760 153 50       341 $type = '' if $type =~ /^\d/;
761 153   100     389 my $scope = shift || '';
762 153   100     383 my $critical = shift || '';
763 153         229 my $basename_orig = $basename;
764 153 100       358 my $max_name = $type
765             ? $max_id_length - (length($type) + 1)
766             : $max_id_length;
767 153 100       676 $basename = substr( $basename, 0, $max_name )
768             if length( $basename ) > $max_name;
769 153 100       335 my $name = $type ? "${type}_$basename" : $basename;
770              
771 153 50 66     382 if ( $basename ne $basename_orig and $critical ) {
772 0 0       0 my $show_type = $type ? "+'$type'" : "";
773 0 0       0 warn "Truncating '$basename_orig'$show_type to $max_id_length ",
774             "character limit to make '$name'\n" if $WARN;
775 0         0 $truncated{ $basename_orig } = $name;
776             }
777              
778 153   100     422 $scope ||= \%global_names;
779 153 100       382 if ( my $prev = $scope->{ $name } ) {
780 20         34 my $name_orig = $name;
781 20 100       47 substr($name, $max_id_length - 2) = ""
782             if length( $name ) >= $max_id_length - 1;
783 20         80 $name .= sprintf( "%02d", $prev++ );
784              
785 20 50       45 warn "The name '$name_orig' has been changed to ",
786             "'$name' to make it unique.\n" if $WARN;
787              
788 20         39 $scope->{ $name_orig }++;
789             }
790              
791 153         427 $scope->{ $name }++;
792 153         411 return $name;
793             }
794              
795             1;
796              
797             sub quote {
798 436     436 0 832 my ($name, $q) = @_;
799 436 100 100     1435 return $name unless $q && $name;
800 253         1033 $name =~ s/\Q$quote_char/$quote_char$quote_char/g;
801 253         1062 return "$quote_char$name$quote_char";
802             }
803              
804              
805             # -------------------------------------------------------------------
806             # All bad art is the result of good intentions.
807             # Oscar Wilde
808             # -------------------------------------------------------------------
809              
810             =pod
811              
812             =head1 CREDITS
813              
814             Mad props to Tim Bunce for much of the logic stolen from his "mysql2ora"
815             script.
816              
817             =head1 AUTHORS
818              
819             Ken Youens-Clark Ekclark@cpan.orgE,
820             Alexander Hartmaier Eabraxxa@cpan.orgE,
821             Fabien Wernli Efaxmodem@cpan.orgE.
822              
823             =head1 SEE ALSO
824              
825             SQL::Translator, DDL::Oracle, mysql2ora.
826              
827             =cut