3dbc6e5bcaa148364264e169c765cfb39c423bb4
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / Oracle.pm
1 package SQL::Translator::Parser::Oracle;
2
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.22 2006-05-03 21:25:07 duality72 Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2002-4 SQLFairy Authors
7 #
8 # This program is free software; you can redistribute it and/or
9 # modify it under the terms of the GNU General Public License as
10 # published by the Free Software Foundation; version 2.
11 #
12 # This program is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15 # General Public License for more details.
16 #
17 # You should have received a copy of the GNU General Public License
18 # along with this program; if not, write to the Free Software
19 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
20 # 02111-1307  USA
21 # -------------------------------------------------------------------
22
23 =head1 NAME
24
25 SQL::Translator::Parser::Oracle - parser for Oracle
26
27 =head1 SYNOPSIS
28
29   use SQL::Translator;
30   use SQL::Translator::Parser::Oracle;
31
32   my $translator = SQL::Translator->new;
33   $translator->parser("SQL::Translator::Parser::Oracle");
34
35 =head1 DESCRIPTION
36
37 From http://www.ss64.com/ora/table_c.html:
38
39  CREATE [GLOBAL TEMPORARY] TABLE [schema.]table (tbl_defs,...)
40      [ON COMMIT {DELETE|PRESERVE} ROWS]
41          [storage_options | CLUSTER cluster_name (col1, col2,... )
42             | ORGANIZATION {HEAP [storage_options] 
43             | INDEX idx_organized_tbl_clause}]
44                [LOB_storage_clause][varray_clause][nested_storage_clause]
45                    partitioning_options
46                       [[NO]CACHE] [[NO]MONITORING] [PARALLEL parallel_clause]
47                          [ENABLE enable_clause | DISABLE disable_clause]
48                              [AS subquery]
49
50 tbl_defs:
51    column datatype [DEFAULT expr] [column_constraint(s)]
52    table_ref_constraint
53
54 storage_options:
55    PCTFREE int
56    PCTUSED int
57    INITTRANS int
58    MAXTRANS int
59    STORAGE storage_clause
60    TABLESPACE tablespace
61    [LOGGING|NOLOGGING]
62
63 idx_organized_tbl_clause:
64    storage_option(s) [PCTTHRESHOLD int]
65      [COMPRESS int|NOCOMPRESS]
66          [ [INCLUDING column_name] OVERFLOW [storage_option(s)] ]
67
68 nested_storage_clause:
69    NESTED TABLE nested_item STORE AS storage_table
70       [RETURN AS {LOCATOR|VALUE} ]
71
72 partitioning_options:
73    Partition_clause {ENABLE|DISABLE} ROW MOVEMENT
74
75 Column Constraints
76 (http://www.ss64.com/ora/clause_constraint_col.html)
77
78    CONSTRAINT constrnt_name {UNIQUE|PRIMARY KEY} constrnt_state
79
80    CONSTRAINT constrnt_name CHECK(condition) constrnt_state
81
82    CONSTRAINT constrnt_name [NOT] NULL constrnt_state
83
84    CONSTRAINT constrnt_name REFERENCES [schema.]table[(column)]
85       [ON DELETE {CASCADE|SET NULL}] constrnt_state
86
87 constrnt_state   
88     [[NOT] DEFERRABLE] [INITIALLY {IMMEDIATE|DEFERRED}]
89        [RELY | NORELY] [USING INDEX using_index_clause]
90           [ENABLE|DISABLE] [VALIDATE|NOVALIDATE]
91               [EXCEPTIONS INTO [schema.]table]
92
93 Note that probably not all of the above syntax is supported, but the grammar 
94 was altered to better handle the syntax created by DDL::Oracle.
95
96 =cut
97
98 use strict;
99 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
100 $VERSION = sprintf "%d.%02d", q$Revision: 1.22 $ =~ /(\d+)\.(\d+)/;
101 $DEBUG   = 0 unless defined $DEBUG;
102
103 use Data::Dumper;
104 use Parse::RecDescent;
105 use Exporter;
106 use base qw(Exporter);
107
108 @EXPORT_OK = qw(parse);
109
110 # Enable warnings within the Parse::RecDescent module.
111 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
112 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
113 $::RD_HINT   = 1; # Give out hints to help fix problems.
114
115 my $parser; 
116
117 $GRAMMAR = q`
118
119 { my ( %tables, %indices, %constraints, $table_order, @table_comments ) }
120
121 #
122 # The "eofile" rule makes the parser fail if any "statement" rule
123 # fails.  Otherwise, the first successful match by a "statement" 
124 # won't cause the failure needed to know that the parse, as a whole,
125 # failed. -ky
126 #
127 startrule : statement(s) eofile 
128     { 
129         $return = {
130             tables      => \%tables,
131             indices     => \%indices,
132             constraints => \%constraints,
133         };
134     }
135
136 eofile : /^\Z/
137
138 statement : remark
139         | run
140     | prompt
141     | create
142     | table_comment
143     | comment_on_table
144     | comment_on_column
145     | alter
146     | drop
147     | <error>
148
149 alter : /alter/i WORD /[^;]+/ ';'
150     { @table_comments = () }
151
152 drop : /drop/i TABLE ';'
153
154 drop : /drop/i WORD(s) ';'
155     { @table_comments = () }
156
157 create : create_table table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
158     {
159         my $table_name                       = $item{'table_name'};
160         $tables{ $table_name }{'order'}      = ++$table_order;
161         $tables{ $table_name }{'table_name'} = $table_name;
162
163         if ( @table_comments ) {
164             $tables{ $table_name }{'comments'} = [ @table_comments ];
165             @table_comments = ();
166         }
167
168         my $i = 1;
169         my @constraints;
170         for my $definition ( @{ $item[4] } ) {
171             if ( $definition->{'type'} eq 'field' ) {
172                 my $field_name = $definition->{'name'};
173                 $tables{ $table_name }{'fields'}{ $field_name } = 
174                     { %$definition, order => $i };
175                 $i++;
176                                 
177                 for my $constraint ( @{ $definition->{'constraints'} || [] } ) {
178                     $constraint->{'fields'} = [ $field_name ];
179                     push @{ $tables{ $table_name }{'constraints'} }, 
180                         $constraint;
181                 }
182             }
183             elsif ( $definition->{'type'} eq 'constraint' ) {
184                 $definition->{'type'} = $definition->{'constraint_type'};
185                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
186             }
187             else {
188                 push @{ $tables{ $table_name }{'indices'} }, $definition;
189             }
190         }
191
192         for my $option ( @{ $item[6] } ) {
193             push @{ $tables{ $table_name }{'table_options'} }, $option;
194         }
195
196         1;
197     }
198
199 create : create_index index_name /on/i table_name index_expr table_option(?) ';'
200     {
201         my $table_name = $item[4];
202         if ( $item[1] ) {
203             push @{ $constraints{ $table_name } }, {
204                 name   => $item[2],
205                 type   => 'unique',
206                 fields => $item[5],
207             };
208         }
209         else {
210             push @{ $indices{ $table_name } }, {
211                 name   => $item[2],
212                 type   => 'normal',
213                 fields => $item[5],
214             };
215         }
216     }
217
218 index_expr: parens_word_list
219         { $item[1] }
220         | '(' WORD parens_word_list ')'
221         { $item[2].$item[3] }
222
223 # Create anything else (e.g., domain, function, etc.)
224 create : ...!create_table ...!create_index /create/i WORD /[^;]+/ ';'
225     { @table_comments = () }
226
227 create_index : /create/i UNIQUE(?) /index/i
228         { $return = $item[2] }
229
230 index_name : NAME '.' NAME
231     { $item[3] }
232     | NAME 
233     { $item[1] }
234
235 global_temporary: /global/i /temporary/i
236
237 table_name : NAME '.' NAME
238     { $item[3] }
239     | NAME 
240     { $item[1] }
241
242 create_definition : field
243     | table_constraint
244     | <error>
245
246 table_comment : comment
247     {
248         my $comment = $item[1];
249         $return     = $comment;
250         push @table_comments, $comment;
251     }
252
253 comment : /^\s*(?:#|-{2}).*\n/
254     {
255         my $comment =  $item[1];
256         $comment    =~ s/^\s*(#|-{2})\s*//;
257         $comment    =~ s/\s*$//;
258         $return     = $comment;
259     }
260
261 comment : /\/\*/ /[^\*]+/ /\*\// 
262     {
263         my $comment = $item[2];
264         $comment    =~ s/^\s*|\s*$//g;
265         $return = $comment;
266     }
267
268 remark : /^REM\s+.*\n/
269
270 run : /^(RUN|\/)\s+.*\n/
271
272 prompt : /prompt/i /(table|index|sequence|trigger)/i ';'
273
274 prompt : /prompt\s+create\s+.*\n/i
275
276 comment_on_table : /comment/i /on/i /table/i table_name /is/i comment_phrase ';'
277     {
278         push @{ $tables{ $item{'table_name'} }{'comments'} }, $item{'comment_phrase'};
279     }
280
281 comment_on_column : /comment/i /on/i /column/i column_name /is/i comment_phrase ';'
282     {
283         my $table_name = $item[4]->{'table'};
284         my $field_name = $item[4]->{'field'};
285         push @{ $tables{ $table_name }{'fields'}{ $field_name }{'comments'} }, 
286             $item{'comment_phrase'};
287     }
288
289 column_name : NAME '.' NAME
290     { $return = { table => $item[1], field => $item[3] } }
291
292 comment_phrase : /'.*?'/ 
293     { 
294         my $val = $item[1];
295         $val =~ s/^'|'$//g;
296         $return = $val;
297     }
298
299 field : comment(s?) field_name data_type field_meta(s?) comment(s?)
300     {
301         my ( $is_pk, $default, @constraints );
302         my $null = 1;
303         for my $meta ( @{ $item[4] } ) {
304             if ( $meta->{'type'} eq 'default' ) {
305                 $default = $meta;
306                 next;
307             }
308             elsif ( $meta->{'type'} eq 'not_null' ) {
309                 $null = 0;
310                 next;
311             }
312             elsif ( $meta->{'type'} eq 'primary_key' ) {
313                 $is_pk = 1;
314             }
315
316             push @constraints, $meta if $meta->{'supertype'} eq 'constraint';
317         }
318
319         my @comments = ( @{ $item[1] }, @{ $item[5] } );
320
321         $return = { 
322             type           => 'field',
323             name           => $item{'field_name'}, 
324             data_type      => $item{'data_type'}{'type'},
325             size           => $item{'data_type'}{'size'},
326             null           => $null,
327             default        => $default->{'value'},
328             is_primary_key => $is_pk,
329             constraints    => [ @constraints ],
330             comments       => [ @comments ],
331         } 
332     }
333     | <error>
334
335 field_name : NAME
336
337 data_type : ora_data_type data_size(?)
338     { 
339         $return  = { 
340             type => $item[1],
341             size => $item[2][0] || '',
342         } 
343     }
344     
345 data_size : '(' VALUE(s /,/) data_size_modifier(?) ')'
346     { $item[2] } 
347
348 data_size_modifier: /byte/i
349         | /char/i
350
351 column_constraint : constraint_name(?) column_constraint_type constraint_state(s?)
352     {
353         my $desc       = $item{'column_constraint_type'};
354         my $type       = $desc->{'type'};
355         my $fields     = $desc->{'fields'}     || [];
356         my $expression = $desc->{'expression'} || '';
357
358         $return              =  {
359             supertype        => 'constraint',
360             name             => $item{'constraint_name(?)'}[0] || '',
361             type             => $type,
362             expression       => $type eq 'check' ? $expression : '',
363             deferrable       => $item{'deferrable'},
364             deferred         => $item{'deferred'},
365             reference_table  => $desc->{'reference_table'},
366             reference_fields => $desc->{'reference_fields'},
367 #            match_type       => $desc->{'match_type'},
368 #            on_update        => $desc->{'on_update'},
369         } 
370     }
371
372 constraint_name : /constraint/i NAME { $item[2] }
373
374 column_constraint_type : /not\s+null/i { $return = { type => 'not_null' } }
375     | /null/ 
376         { $return = { type => 'null' } }
377     | /unique/ 
378         { $return = { type => 'unique' } }
379     | /primary\s+key/i 
380         { $return = { type => 'primary_key' } }
381     | /check/i '(' /[^)]+/ ')' 
382         { $return = { type => 'check', expression => $item[3] } }
383     | /references/i table_name parens_word_list(?) on_delete(?) 
384     {
385         $return              =  {
386             type             => 'foreign_key',
387             reference_table  => $item[2],
388             reference_fields => $item[3][0],
389 #            match_type       => $item[4][0],
390             on_delete     => $item[5][0],
391         }
392     }
393
394 constraint_state : deferrable { $return = { type => $item[1] } }
395     | deferred { $return = { type => $item[1] } }
396     | /(no)?rely/i { $return = { type => $item[1] } }
397 #    | /using/i /index/i using_index_clause 
398 #        { $return = { type => 'using_index', index => $item[3] } }
399     | /(dis|en)able/i { $return = { type => $item[1] } }
400     | /(no)?validate/i { $return = { type => $item[1] } }
401     | /exceptions/i /into/i table_name 
402         { $return = { type => 'exceptions_into', table => $item[3] } }
403
404 deferrable : /not/i /deferrable/i 
405     { $return = 'not_deferrable' }
406     | /deferrable/i 
407     { $return = 'deferrable' }
408
409 deferred : /initially/i /(deferred|immediate)/i { $item[2] }
410
411 ora_data_type :
412     /(n?varchar2|varchar)/i { $return = 'varchar2' }
413     |
414     /n?char/i { $return = 'character' }
415     |
416         /n?dec/i { $return = 'decimal' }
417         |
418     /number/i { $return = 'number' }
419     |
420     /integer/i { $return = 'integer' }
421     |
422     /(pls_integer|binary_integer)/i { $return = 'integer' }
423     |
424     /interval\s+day/i { $return = 'interval day' }
425     |
426     /interval\s+year/i { $return = 'interval year' }
427     |
428     /long\s+raw/i { $return = 'long raw' }
429     |
430     /(long|date|timestamp|raw|rowid|urowid|mlslabel|clob|nclob|blob|bfile|float)/i { $item[1] }
431
432 parens_value_list : '(' VALUE(s /,/) ')'
433     { $item[2] }
434
435 parens_word_list : '(' WORD(s /,/) ')'
436     { $item[2] }
437
438 field_meta : default_val
439     | column_constraint
440
441 default_val  : /default/i /(?:')?[\w\d.-]*(?:')?/ 
442     { 
443         my $val =  $item[2];
444         $val    =~ s/'//g if defined $val; 
445         $return =  {
446             supertype => 'constraint',
447             type      => 'default',
448             value     => $val,
449         }
450     }
451
452 create_table : /create/i global_temporary(?) /table/i
453
454 table_option : /organization/i WORD
455     {
456         $return = { 'ORGANIZATION' => $item[2] }
457     }
458
459 table_option : /nomonitoring/i
460     {
461         $return = { 'NOMONITORING' => undef }
462     }
463
464 table_option : /parallel/i '(' key_value(s) ')'
465     {
466         $return = { 'PARALLEL' => $item[3] }
467     }
468
469 key_value : WORD VALUE
470     {
471         $return = { $item[1], $item[2] }
472     }
473
474 table_option : /[^;]+/
475
476 table_constraint : comment(s?) constraint_name(?) table_constraint_type deferrable(?) deferred(?) constraint_state(s?) comment(s?)
477     {
478         my $desc       = $item{'table_constraint_type'};
479         my $type       = $desc->{'type'};
480         my $fields     = $desc->{'fields'};
481         my $expression = $desc->{'expression'};
482         my @comments   = ( @{ $item[1] }, @{ $item[-1] } );
483
484         $return              =  {
485             name             => $item{'constraint_name(?)'}[0] || '',
486             type             => 'constraint',
487             constraint_type  => $type,
488             fields           => $type ne 'check' ? $fields : [],
489             expression       => $type eq 'check' ? $expression : '',
490             deferrable       => $item{'deferrable(?)'},
491             deferred         => $item{'deferred(?)'},
492             reference_table  => $desc->{'reference_table'},
493             reference_fields => $desc->{'reference_fields'},
494 #            match_type       => $desc->{'match_type'}[0],
495             on_delete        => $desc->{'on_delete'} || $desc->{'on_delete_do'},
496             on_update        => $desc->{'on_update'} || $desc->{'on_update_do'},
497             comments         => [ @comments ],
498         } 
499     }
500
501 table_constraint_type : /primary key/i '(' NAME(s /,/) ')'
502     { 
503         $return = {
504             type   => 'primary_key',
505             fields => $item[3],
506         }
507     }
508     |
509     /unique/i '(' NAME(s /,/) ')' 
510     { 
511         $return    =  {
512             type   => 'unique',
513             fields => $item[3],
514         }
515     }
516     |
517     /check/ '(' /(.+)/ ')'
518     {
519         $return        =  {
520             type       => 'check',
521             expression => $item[3],
522         }
523     }
524     |
525     /foreign key/i '(' NAME(s /,/) ')' /references/i table_name parens_word_list(?) on_delete(?)
526     {
527         $return              =  {
528             type             => 'foreign_key',
529             fields           => $item[3],
530             reference_table  => $item[6],
531             reference_fields => $item[7][0],
532             match_type       => $item[8][0],
533             on_delete     => $item[9][0],
534             on_update     => $item[10][0],
535         }
536     }
537
538 on_delete : /on delete/i WORD(s)
539     { $item[2] }
540
541 UNIQUE : /unique/i { $return = 1 }
542
543 WORD : /\w+/
544
545 NAME : /\w+/ { $item[1] }
546
547 TABLE : /table/i
548
549 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
550     { $item[1] }
551     | /'.*?'/   # XXX doesn't handle embedded quotes
552     { $item[1] }
553     | /NULL/
554     { 'NULL' }
555
556 `;
557
558 # -------------------------------------------------------------------
559 sub parse {
560     my ( $translator, $data ) = @_;
561     $parser ||= Parse::RecDescent->new($GRAMMAR);
562
563     local $::RD_TRACE = $translator->trace ? 1 : undef;
564     local $DEBUG      = $translator->debug;
565
566     unless (defined $parser) {
567         return $translator->error("Error instantiating Parse::RecDescent ".
568             "instance: Bad grammer");
569     }
570
571     my $result = $parser->startrule( $data );
572     die "Parse failed.\n" unless defined $result;
573     if ( $DEBUG ) {
574         warn "Parser results =\n", Dumper($result), "\n";
575     }
576
577     my $schema      = $translator->schema;
578     my $indices     = $result->{'indices'};
579     my $constraints = $result->{'constraints'};
580     my @tables      = sort { 
581         $result->{'tables'}{ $a }{'order'} 
582         <=> 
583         $result->{'tables'}{ $b }{'order'}
584     } keys %{ $result->{'tables'} };
585
586     for my $table_name ( @tables ) {
587         my $tdata    =  $result->{'tables'}{ $table_name };
588         next unless $tdata->{'table_name'};
589         my $table    =  $schema->add_table( 
590             name     => $tdata->{'table_name'},
591             comments => $tdata->{'comments'},
592         ) or die $schema->error;
593
594         $table->options( $tdata->{'table_options'} );
595
596         my @fields = sort { 
597             $tdata->{'fields'}->{$a}->{'order'} 
598             <=>
599             $tdata->{'fields'}->{$b}->{'order'}
600         } keys %{ $tdata->{'fields'} };
601
602         for my $fname ( @fields ) {
603             my $fdata = $tdata->{'fields'}{ $fname };
604             my $field = $table->add_field(
605                 name              => $fdata->{'name'},
606                 data_type         => $fdata->{'data_type'},
607                 size              => $fdata->{'size'},
608                 default_value     => $fdata->{'default'},
609                 is_auto_increment => $fdata->{'is_auto_inc'},
610                 is_nullable       => $fdata->{'null'},
611                 comments          => $fdata->{'comments'},
612             ) or die $table->error;
613         }
614
615         push @{ $tdata->{'indices'} }, @{ $indices->{ $table_name } || [] };
616         push @{ $tdata->{'constraints'} }, 
617              @{ $constraints->{ $table_name } || [] };
618
619         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
620             my $index  =  $table->add_index(
621                 name   => $idata->{'name'},
622                 type   => uc $idata->{'type'},
623                 fields => $idata->{'fields'},
624             ) or die $table->error;
625         }
626
627         for my $cdata ( @{ $tdata->{'constraints'} || [] } ) {
628             my $constraint       =  $table->add_constraint(
629                 name             => $cdata->{'name'},
630                 type             => $cdata->{'type'},
631                 fields           => $cdata->{'fields'},
632                 reference_table  => $cdata->{'reference_table'},
633                 reference_fields => $cdata->{'reference_fields'},
634                 match_type       => $cdata->{'match_type'} || '',
635                 on_delete        => $cdata->{'on_delete'} || $cdata->{'on_delete_do'},
636                 on_update        => $cdata->{'on_update'} || $cdata->{'on_update_do'},
637             ) or die $table->error;
638         }
639     }
640
641     return 1;
642 }
643
644 1;
645
646 # -------------------------------------------------------------------
647 # Something there is that doesn't love a wall.
648 # Robert Frost
649 # -------------------------------------------------------------------
650
651 =pod
652
653 =head1 AUTHOR
654
655 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
656
657 =head1 SEE ALSO
658
659 SQL::Translator, Parse::RecDescent, DDL::Oracle.
660
661 =cut