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   3755 use strict;
  10         29  
  10         343  
91 10     10   65 use warnings;
  10         34  
  10         775  
92             our ( $DEBUG, $WARN );
93             our $VERSION = '1.62';
94             $DEBUG = 0 unless defined $DEBUG;
95              
96 10     10   92 use base 'SQL::Translator::Producer';
  10         52  
  10         1815  
97 10     10   83 use SQL::Translator::Schema::Constants;
  10         35  
  10         804  
98 10     10   76 use SQL::Translator::Utils qw(header_comment);
  10         24  
  10         44772  
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 28 my $translator = shift;
190 10         59 $DEBUG = $translator->debug;
191 10   50     311 $WARN = $translator->show_warnings || 0;
192 10         491 my $no_comments = $translator->no_comments;
193 10         290 my $add_drop_table = $translator->add_drop_table;
194 10         292 my $schema = $translator->schema;
195 10   50     293 my $oracle_version = $translator->producer_args->{oracle_version} || 0;
196 10         209 my $delay_constraints = $translator->producer_args->{delay_constraints};
197 10         35 my ($output, $create, @table_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs);
198              
199 10 100       104 $create .= header_comment unless ($no_comments);
200 10 100       57 my $qt = 1 if $translator->quote_table_names;
201 10 100       140 my $qf = 1 if $translator->quote_field_names;
202              
203 10 100       275 if ( $translator->parser_type =~ /mysql/i ) {
204 1 50       5 $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         3 $create .=
210             "ALTER SESSION SET NLS_DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';\n\n";
211             }
212              
213 10         73 for my $table ( $schema->get_tables ) {
214 20         211 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         112 push @table_defs, @$table_def;
226 20         50 push @fk_defs, @$fk_def;
227 20         58 push @trigger_defs, @$trigger_def;
228 20         79 push @index_defs, @$index_def;
229 20         79 push @constraint_defs, @$constraint_def;
230             }
231              
232 10         46 my (@view_defs);
233 10         84 foreach my $view ( $schema->get_views ) {
234 5         44 my ( $view_def ) = create_view(
235             $view,
236             {
237             add_drop_view => $add_drop_table,
238             quote_table_names => $qt,
239             }
240             );
241 5         28 push @view_defs, @$view_def;
242             }
243              
244 10 100       51 if (wantarray) {
245 2 50       28 return defined $create ? $create : (), @table_defs, @view_defs, @fk_defs, @trigger_defs, @index_defs, @constraint_defs;
246             }
247             else {
248 8         98 $create .= join (";\n\n", @table_defs, @view_defs, @fk_defs, @index_defs, @constraint_defs);
249 8         36 $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         53 for @trigger_defs;
255 8         555 return $create;
256             }
257             }
258              
259             sub create_table {
260 21     21 1 69 my ($table, $options) = @_;
261 21         66 my $qt = $options->{quote_table_names};
262 21         59 my $qf = $options->{quote_field_names};
263 21         549 my $table_name = $table->name;
264 21         542 my $table_name_q = quote($table_name,$qt);
265              
266 21         64 my $item = '';
267 21         45 my $drop;
268 21         57 my (@create, @field_defs, @constraint_defs, @fk_defs, @trigger_defs);
269              
270 21 100       110 push @create, "--\n-- Table: $table_name\n--" unless $options->{no_comments};
271 21 100       143 push @create, qq[DROP TABLE $table_name_q CASCADE CONSTRAINTS] if $options->{add_drop_table};
272              
273 21         56 my ( %field_name_scope, @field_comments );
274 21         112 for my $field ( $table->get_fields ) {
275 84         361 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
276             create_field($field, $options, \%field_name_scope);
277 84 50       326 push @create, @$field_create if ref $field_create;
278 84 50       286 push @field_defs, @$field_defs if ref $field_defs;
279 84 50       243 push @trigger_defs, @$trigger_defs if ref $trigger_defs;
280 84 50       330 push @field_comments, @$field_comments if ref $field_comments;
281             }
282              
283             #
284             # Table options
285             #
286 21         67 my @table_options;
287 21         490 for my $opt ( $table->options ) {
288 7 100       39 if ( ref $opt eq 'HASH' ) {
289 5         29 my ( $key, $value ) = each %$opt;
290 5 50       41 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         27 push @table_options, "$key $value";
302             }
303             }
304             }
305              
306             #
307             # Table constraints
308             #
309 21         123 for my $c ( $table->get_constraints ) {
310 35   100     1110 my $name = $c->name || '';
311 35         160 my @fields = map { quote($_,$qf) } $c->fields;
  36         144  
312 35         1192 my @rfields = map { quote($_,$qf) } $c->reference_fields;
  8         28  
313              
314 35 50 33     182 next if !@fields && $c->type ne CHECK_C;
315              
316 35 100       767 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     452 if $options->{delay_constraints};
320 18         72 $name = quote($name,$qf);
321 18 100       156 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       222 if ( my $pk = $table->primary_key ) {
327 10         266 my $u_fields = join(":", @fields);
328 10         119 my $pk_fields = join(":", $pk->fields);
329 10 50       233 next if $u_fields eq $pk_fields;
330             }
331              
332 10 50       33 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       161 $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         36 $name = quote($name, $qf);
342              
343 10         49 for my $f ( $c->fields ) {
344 10 50       59 my $field_def = $table->get_field( $f ) or next;
345 10 50       308 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     54 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         75 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         194 $name = mk_name( join('_', $table_name, $c->fields). '_fk' );
364 7         29 $name = quote($name, $qf);
365 7   50     175 my $on_delete = uc ($c->on_delete || '');
366              
367 7         38 my $def = "CONSTRAINT $name FOREIGN KEY ";
368              
369 7 50       28 if ( @fields ) {
370 7         37 $def .= '(' . join( ', ', @fields ) . ')';
371             }
372              
373 7         102 my $ref_table = quote($c->reference_table,$qt);
374              
375 7         26 $def .= " REFERENCES $ref_table";
376              
377 7 50       45 if ( @rfields ) {
378 7         34 $def .= ' (' . join( ', ', @rfields ) . ')';
379             }
380              
381 7 50       212 if ( $c->match_type ) {
382 0 0       0 $def .= ' MATCH ' .
383             ( $c->match_type =~ /full/i ) ? 'FULL' : 'PARTIAL';
384             }
385              
386 7 50 33     198 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         80 push @fk_defs, sprintf("ALTER TABLE %s ADD %s", $table_name_q, $def);
396             }
397             }
398              
399             #
400             # Index Declarations
401             #
402 21         181 my @index_defs = ();
403 21         112 for my $index ( $table->get_indices ) {
404 11   50     375 my $index_name = $index->name || '';
405 11   50     357 my $index_type = $index->type || NORMAL;
406 11         596 my @fields = map { quote($_, $qf) } $index->fields;
  12         48  
407 11 50       74 next unless @fields;
408              
409 11         38 my @index_options;
410 11         268 for my $opt ( $index->options ) {
411 3 50       28 if ( ref $opt eq 'HASH' ) {
412 3         17 my ( $key, $value ) = each %$opt;
413 3 50       19 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         16 push @index_options, "$key $value";
425             }
426             }
427             }
428 11 100       102 my $index_options = @index_options
429             ? "\n".join("\n", @index_options) : '';
430              
431 11 50       73 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     59 $index_name = $index_name ? mk_name( $index_name )
440             : mk_name( $table_name, $index_name || 'i' );
441 10         46 $index_name = quote($index_name, $qf);
442 10         119 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         4 $index_name = quote($index_name, $qf);
451 1         11 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       526 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       121 my $table_options = @table_options
472             ? "\n".join("\n", @table_options) : '';
473             push @create, "CREATE TABLE $table_name_q (\n" .
474 110         366 join( ",\n", map { " $_" } @field_defs,
475 21 100       155 ($options->{delay_constraints} ? () : @constraint_defs) ) .
476             "\n)$table_options";
477              
478 21         70 @constraint_defs = map { "ALTER TABLE $table_name_q ADD $_" }
  28         118  
479             @constraint_defs;
480              
481 21 50       86 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       235 return \@create, \@fk_defs, \@trigger_defs, \@index_defs, ($options->{delay_constraints} ? \@constraint_defs : []);
489             }
490              
491             sub alter_field {
492 2     2 1 24 my ($from_field, $to_field, $options) = @_;
493              
494 2         5 my $qt = $options->{quote_table_names};
495 2         9 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
496             create_field($to_field, $options, {});
497              
498             # Fix ORA-01442
499 2 50 33     38 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         36 @$field_defs = map { s/ NOT NULL//; $_} @$field_defs;
  1         7  
  1         5  
503             }
504              
505 2         59 my $table_name = quote($to_field->table->name,$qt);
506              
507 2         15 return 'ALTER TABLE '.$table_name.' MODIFY ( '.join('', @$field_defs).' )';
508             }
509              
510             sub add_field {
511 1     1 1 19 my ($new_field, $options) = @_;
512              
513 1         3 my $qt = $options->{quote_table_names};
514 1         5 my ($field_create, $field_defs, $trigger_defs, $field_comments) =
515             create_field($new_field, $options, {});
516              
517 1         19 my $table_name = quote($new_field->table->name,$qt);
518              
519 1         8 my $out = sprintf('ALTER TABLE %s ADD ( %s )',
520             $table_name,
521             join('', @$field_defs));
522 1         6 return $out;
523             }
524              
525             sub create_field {
526 87     87 1 222 my ($field, $options, $field_name_scope) = @_;
527 87         210 my $qf = $options->{quote_field_names};
528 87         175 my $qt = $options->{quote_table_names};
529              
530 87         250 my (@create, @field_defs, @trigger_defs, @field_comments);
531              
532 87         1935 my $table_name = $field->table->name;
533 87         1791 my $table_name_q = quote($table_name, $qt);
534              
535             #
536             # Field name
537             #
538 87         1755 my $field_name = mk_name(
539             $field->name, '', $field_name_scope, 1
540             );
541 87         251 my $field_name_q = quote($field_name, $qf);
542 87         205 my $field_def = quote($field_name, $qf);
543 87         1899 $field->name( $field_name );
544              
545             #
546             # Datatype
547             #
548 87         233 my $check;
549 87         356 my $data_type = lc $field->data_type;
550 87         1770 my @size = $field->size;
551 87         2395 my %extra = $field->extra;
552 87   100     713 my $list = $extra{'list'} || [];
553 87         288 my $commalist = join( ', ', map { __PACKAGE__->_quote_string($_) } @$list );
  2         9  
554              
555 87 100       365 if ( $data_type eq 'enum' ) {
    50          
556 1         6 $check = "CHECK ($field_name_q IN ($commalist))";
557 1         2 $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       341 if (defined $translate{ $data_type }) {
566 82 50       265 if (ref $translate{ $data_type } eq "ARRAY") {
567 0         0 ($data_type,$size[0]) = @{$translate{ $data_type }};
  0         0  
568             } else {
569 82         195 $data_type = $translate{ $data_type };
570             }
571             }
572 86   50     240 $data_type ||= 'varchar2';
573             }
574              
575             # ensure size is not bigger than max size oracle allows for data type
576 87 100       289 if ( defined $max_size{$data_type} ) {
577 73         282 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       365 : $max_size{$data_type};
582 81 50       420 $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     467 if ( $data_type eq 'clob' && $field->is_primary_key ) {
591 1         12 $data_type = 'varchar2';
592 1         4 $size[0] = 4000;
593 1 50       6 warn "CLOB cannot be a primary key, changing to VARCHAR2\n"
594             if $WARN;
595             }
596              
597 87 50 66     591 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       565 if ( $data_type =~ /(date|clob)/i ) {
608 13         45 undef @size;
609             }
610              
611             #
612             # Fixes ORA-00906: missing right parenthesis
613             # if size is 0 or undefined
614             #
615 87         219 for (qw/varchar2/) {
616 87 100       652 if ( $data_type =~ /^($_)$/i ) {
617 38   66     172 $size[0] ||= $max_size{$_};
618             }
619             }
620              
621 87         275 $field_def .= " $data_type";
622 87 100 100     429 if ( defined $size[0] && $size[0] > 0 ) {
623 71         296 $field_def .= '(' . join( ',', @size ) . ')';
624             }
625              
626             #
627             # Default value
628             #
629 87         321 my $default = $field->default_value;
630 87 100       265 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     450 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       10 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       7 $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       278 $default = $default =~ m/null/i ? 'NULL' : __PACKAGE__->_quote_string($default);
663             }
664              
665 35         102 $field_def .= " DEFAULT $default",
666             }
667              
668             #
669             # Not null constraint
670             #
671 87 100       2039 unless ( $field->is_nullable ) {
672 35         1661 $field_def .= ' NOT NULL';
673             }
674              
675 87 100       2598 $field_def .= " $check" if $check;
676              
677             #
678             # Auto_increment
679             #
680 87 100       1495 if ( $field->is_auto_increment ) {
681 15         241 my $base_name = $table_name . "_". $field_name;
682 15         54 my $seq_name = quote(mk_name( $base_name, 'sq' ),$qt);
683 15         79 my $trigger_name = quote(mk_name( $base_name, 'ai' ),$qt);
684              
685 15 100       98 push @create, qq[DROP SEQUENCE $seq_name] if $options->{add_drop_table};
686 15         66 push @create, "CREATE SEQUENCE $seq_name";
687 15         198 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         52 push @trigger_defs, $trigger;
701             }
702              
703 87 100       1115 if ( lc $field->data_type eq 'timestamp' ) {
704 6         34 my $base_name = $table_name . "_". $field_name;
705 6         29 my $trig_name = quote(mk_name( $base_name, 'ts' ), $qt);
706 6         101 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         27 push @trigger_defs, $trigger;
715             }
716              
717 87         320 push @field_defs, $field_def;
718              
719 87 100       1834 if ( my $comment = $field->comments ) {
720 5         68 $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       26 unless $options->{no_comments};
724             }
725              
726 87         1227 return \@create, \@field_defs, \@trigger_defs, \@field_comments;
727              
728             }
729              
730              
731             sub create_view {
732 6     6 1 51 my ($view, $options) = @_;
733 6         17 my $qt = $options->{quote_table_names};
734 6         54 my $view_name = quote($view->name,$qt);
735 6         162 my $extra = $view->extra;
736              
737 6         24 my $view_type = 'VIEW';
738 6         19 my $view_options = '';
739 6 100       28 if ( my $materialized = $extra->{materialized} ) {
740 1         2 $view_type = 'MATERIALIZED VIEW';
741 1         4 $view_options .= ' '.$materialized;
742             }
743              
744 6         14 my @create;
745             push @create, qq[DROP $view_type $view_name]
746 6 100       37 if $options->{add_drop_view};
747              
748 6         53 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         37 return \@create;
755             }
756              
757             sub mk_name {
758 153   50 153 0 2309 my $basename = shift || '';
759 153   100     656 my $type = shift || '';
760 153 50       468 $type = '' if $type =~ /^\d/;
761 153   100     559 my $scope = shift || '';
762 153   100     452 my $critical = shift || '';
763 153         336 my $basename_orig = $basename;
764 153 100       420 my $max_name = $type
765             ? $max_id_length - (length($type) + 1)
766             : $max_id_length;
767 153 100       469 $basename = substr( $basename, 0, $max_name )
768             if length( $basename ) > $max_name;
769 153 100       404 my $name = $type ? "${type}_$basename" : $basename;
770              
771 153 50 66     538 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     559 $scope ||= \%global_names;
779 153 100       531 if ( my $prev = $scope->{ $name } ) {
780 20         39 my $name_orig = $name;
781 20 100       65 substr($name, $max_id_length - 2) = ""
782             if length( $name ) >= $max_id_length - 1;
783 20         146 $name .= sprintf( "%02d", $prev++ );
784              
785 20 50       54 warn "The name '$name_orig' has been changed to ",
786             "'$name' to make it unique.\n" if $WARN;
787              
788 20         45 $scope->{ $name_orig }++;
789             }
790              
791 153         452 $scope->{ $name }++;
792 153         486 return $name;
793             }
794              
795             1;
796              
797             sub quote {
798 436     436 0 996 my ($name, $q) = @_;
799 436 100 100     1637 return $name unless $q && $name;
800 253         1380 $name =~ s/\Q$quote_char/$quote_char$quote_char/g;
801 253         1256 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