Added rules to catch common (but useless) statements.
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / Oracle.pm
1 package SQL::Translator::Parser::Oracle;
2
3 # -------------------------------------------------------------------
4 # $Id: Oracle.pm,v 1.1 2003-04-10 03:09:28 kycl4rk Exp $
5 # -------------------------------------------------------------------
6 # Copyright (C) 2003 Ken Y. Clark <kclark@cpan.org>
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_constraint
53    table_ref_constraint
54
55 storage_options:
56    PCTFREE int
57    PCTUSED int
58    INITTRANS int
59    MAXTRANS int
60    STORAGE storage_clause
61    TABLESPACE tablespace
62    [LOGGING|NOLOGGING]
63
64 idx_organized_tbl_clause:
65    storage_option(s) [PCTTHRESHOLD int]
66      [COMPRESS int|NOCOMPRESS]
67          [ [INCLUDING column_name] OVERFLOW [storage_option(s)] ]
68
69 nested_storage_clause:
70    NESTED TABLE nested_item STORE AS storage_table
71       [RETURN AS {LOCATOR|VALUE} ]
72
73 partitioning_options:
74    Partition_clause {ENABLE|DISABLE} ROW MOVEMENT
75
76 Column Constraints
77 (http://www.ss64.com/ora/clause_constraint_col.html)
78
79    CONSTRAINT constrnt_name {UNIQUE|PRIMARY KEY} constrnt_state
80
81    CONSTRAINT constrnt_name CHECK(condition) constrnt_state
82
83    CONSTRAINT constrnt_name [NOT] NULL constrnt_state
84
85    CONSTRAINT constrnt_name REFERENCES [schema.]table[(column)]
86       [ON DELETE {CASCADE|SET NULL}] constrnt_state
87
88 constrnt_state   
89     [[NOT] DEFERRABLE] [INITIALLY {IMMEDIATE|DEFERRED}]
90        [RELY | NORELY] [USING INDEX using_index_clause]
91           [ENABLE|DISABLE] [VALIDATE|NOVALIDATE]
92               [EXCEPTIONS INTO [schema.]table]
93
94 =cut
95
96 use strict;
97 use vars qw[ $DEBUG $VERSION $GRAMMAR @EXPORT_OK ];
98 $VERSION = sprintf "%d.%02d", q$Revision: 1.1 $ =~ /(\d+)\.(\d+)/;
99 $DEBUG   = 0 unless defined $DEBUG;
100
101 use Data::Dumper;
102 use Parse::RecDescent;
103 use Exporter;
104 use base qw(Exporter);
105
106 @EXPORT_OK = qw(parse);
107
108 # Enable warnings within the Parse::RecDescent module.
109 $::RD_ERRORS = 1; # Make sure the parser dies when it encounters an error
110 $::RD_WARN   = 1; # Enable warnings. This will warn on unused rules &c.
111 $::RD_HINT   = 1; # Give out hints to help fix problems.
112
113 my $parser; 
114
115 $GRAMMAR = q!
116
117 { our ( %tables, $table_order ) }
118
119 #
120 # The "eofile" rule makes the parser fail if any "statement" rule
121 # fails.  Otherwise, the first successful match by a "statement" 
122 # won't cause the failure needed to know that the parse, as a whole,
123 # failed. -ky
124 #
125 startrule : statement(s) eofile { \%tables }
126
127 eofile : /^\Z/
128
129 statement : create
130   | comment
131   | comment_on_table
132   | comment_on_column
133   | <error>
134
135 create : create_table table_name '(' create_definition(s /,/) ')' table_option(s?) ';'
136     {
137         my $table_name                       = $item{'table_name'};
138         $tables{ $table_name }{'order'}      = ++$table_order;
139         $tables{ $table_name }{'table_name'} = $table_name;
140
141         my $i = 1;
142         my @constraints;
143         for my $definition ( @{ $item[4] } ) {
144             if ( $definition->{'type'} eq 'field' ) {
145                 my $field_name = $definition->{'name'};
146                 $tables{ $table_name }{'fields'}{ $field_name } = 
147                     { %$definition, order => $i };
148                 $i++;
149                                 
150                 if ( $definition->{'is_primary_key'} ) {
151                     push @{ $tables{ $table_name }{'indices'} }, {
152                         type   => 'primary_key',
153                         fields => [ $field_name ],
154                     };
155                 }
156
157                 for my $constraint ( @{ $definition->{'constraints'} || [] } ) {
158                     $constraint->{'fields'} = [ $field_name ];
159                     push @{ $tables{ $table_name }{'constraints'} }, 
160                         $constraint;
161                 }
162             }
163             elsif ( $definition->{'type'} eq 'constraint' ) {
164                 $definition->{'type'} = $definition->{'constraint_type'};
165                 # group FKs at the field level
166                 if ( $definition->{'type'} eq 'foreign_key' ) {
167                     for my $fld ( @{ $definition->{'fields'} || [] } ) {
168                         push @{ 
169                             $tables{$table_name}{'fields'}{$fld}{'constraints'}
170                         }, $definition;
171                     }
172                 }
173                 else {
174                     push @{ $tables{ $table_name }{'constraints'} }, 
175                         $definition;
176                 }
177             }
178             else {
179                 push @{ $tables{ $table_name }{'indices'} }, $definition;
180             }
181         }
182
183         for my $option ( @{ $item[6] } ) {
184             $tables{ $table_name }{'table_options'}{ $option->{'type'} } = 
185                 $option;
186         }
187
188         1;
189     }
190
191 # Create anything else (e.g., domain, function, etc.)
192 create : /create/i WORD /[^;]+/ ';'
193
194 global_temporary: /global/i /temporary/i
195
196 table_name : NAME '.' NAME
197     { $item[3] }
198     | NAME 
199     { $item[1] }
200
201 create_definition : field
202     | table_constraint
203     | <error>
204
205 comment : /^\s*(?:#|-{2}).*\n/
206
207 comment_on_table : /comment/i /on/i /table/i table_name /is/i phrase ';'
208     {
209         push @{ $tables{ $item{'table_name'} }{'comments'} }, $item[7];
210     }
211
212 comment_on_column : /comment/i /on/i /column/i column_name /is/i phrase ';'
213     {
214         my $table_name = $item[4]->{'table'};
215         my $field_name = $item[4]->{'field'};
216         push @{ $tables{ $table_name }{'fields'}{ $field_name }{'comments'} }, 
217             $item[7];
218     }
219
220 column_name : NAME '.' NAME
221     { $return = { table => $item[1], field => $item[3] } }
222
223 phrase : /'.*?'/ { $item[1] }
224
225 field : comment(s?) field_name data_type field_meta(s?) comment(s?)
226     {
227         my ( $default, @constraints );
228         for my $meta ( @{ $item[4] } ) {
229             $default = $meta if $meta->{'meta_type'} eq 'default';
230             push @constraints, $meta if $meta->{'meta_type'} eq 'constraint';
231         }
232
233         my $null = ( grep { $_->{'type'} eq 'not_null' } @constraints ) ? 0 : 1;
234
235         $return = { 
236             type           => 'field',
237             name           => $item{'field_name'}, 
238             data_type      => $item{'data_type'}{'type'},
239             size           => $item{'data_type'}{'size'},
240             list           => $item{'data_type'}{'list'},
241             null           => $null,
242             default        => $default->{'value'},
243             constraints    => [ @constraints ],
244         } 
245     }
246     | <error>
247
248 field_name : NAME
249
250 data_type : ora_data_type parens_value_list(?)
251     { 
252         $return  = { 
253             type => $item[1],
254             size => $item[2][0] || '',
255         } 
256     }
257
258 column_constraint : constraint_name(?) column_constraint_type 
259 #constraint_state(s /,/)
260     {
261         my $desc       = $item{'column_constraint_type'};
262         my $type       = $desc->{'type'};
263         my $fields     = $desc->{'fields'}     || [];
264         my $expression = $desc->{'expression'} || '';
265
266         $return              =  {
267             meta_type        => 'constraint',
268             name             => $item{'constraint_name'}[0] || '',
269             type             => $type,
270             expression       => $type eq 'check' ? $expression : '',
271             deferreable      => $item{'deferrable'},
272             deferred         => $item{'deferred'},
273             reference_table  => $desc->{'reference_table'},
274             reference_fields => $desc->{'reference_fields'},
275 #            match_type       => $desc->{'match_type'},
276 #            on_update_do     => $desc->{'on_update_do'},
277         } 
278     }
279
280 constraint_name : /constraint/i NAME { $item[2] }
281
282 column_constraint_type : /not null/i { $return = { type => 'not_null' } }
283     |
284     /null/ 
285         { $return = { type => 'null' } }
286     |
287     /unique/ 
288         { $return = { type => 'unique' } }
289     |
290     /primary key/i 
291         { $return = { type => 'primary_key' } }
292     |
293     /check/i '(' /[^)]+/ ')' 
294         { $return = { type => 'check', expression => $item[2] } }
295     |
296     /references/i table_name parens_word_list(?) on_delete_do(?) 
297     {
298         $return              =  {
299             type             => 'foreign_key',
300             reference_table  => $item[2],
301             reference_fields => $item[3][0],
302 #            match_type       => $item[4][0],
303             on_delete_do     => $item[5][0],
304         }
305     }
306
307 #constraint_state : deferrable { $return = { type => $item[1] } }
308 #    | deferred { $return = { type => $item[1] } }
309 #    | /(no)?rely/ { $return = { type => $item[1] } }
310 #    | /using/i /index/i using_index_clause 
311 #        { $return = { type => 'using_index', index => $item[3] }
312 #    | (dis)?enable { $return = { type => $item[1] } }
313 #    | (no)?validate { $return = { type => $item[1] } }
314 #    | /exceptions/i /into/i table_name 
315 #        { $return = { type => 'exceptions_into', table => $item[3] } }
316
317 deferrable : /not/i /deferrable/i 
318     { $return = 'not_deferrable' }
319     | /deferrable/i 
320     { $return = 'deferrable' }
321
322 deferred : /initially/i /(deferred|immediate)/i { $item[2] }
323
324 ora_data_type :
325     /(n?varchar2|varchar)/i { $return = 'varchar' }
326     |
327     /n?char/i { $return = 'character' }
328     |
329     /number/i { $return = 'number' }
330     |
331     /(pls_integer|binary_integer)/i { $return = 'integer' }
332     |
333     /interval\s+day/i { $return = 'interval_day' }
334     |
335     /interval\s+year/i { $return = 'interval_year' }
336     |
337     /long\s+raw/i { $return = 'long_raw' }
338     |
339     /(long|date|timestamp|raw|rowid|urowid|mlslabel|clob|nclob|blob|bfile)/i { $item[1] }
340
341 parens_value_list : '(' VALUE(s /,/) ')'
342     { $item[2] }
343
344 parens_word_list : '(' WORD(s /,/) ')'
345     { $item[2] }
346
347 field_meta : default_val
348     |
349     column_constraint
350
351 default_val  : /default/i /(?:')?[\w\d.-]*(?:')?/ 
352     { 
353         my $val =  $item[2] || '';
354         $val    =~ s/'//g; 
355         $return =  {
356             meta_type => 'default',
357             value     => $val,
358         }
359     }
360
361 create_table : /create/i global_temporary(?) /table/i
362
363 table_option : /[^;]+/
364
365 table_constraint : comment(s?) constraint_name(?) table_constraint_type deferrable(?) deferred(?) comment(s?)
366     {
367         my $desc       = $item{'table_constraint_type'};
368         my $type       = $desc->{'type'};
369         my $fields     = $desc->{'fields'};
370         my $expression = $desc->{'expression'};
371         my @comments   = ( @{ $item[1] }, @{ $item[-1] } );
372
373         $return              =  {
374             name             => $item{'constraint_name'}[0] || '',
375             type             => 'constraint',
376             constraint_type  => $type,
377             fields           => $type ne 'check' ? $fields : [],
378             expression       => $type eq 'check' ? $expression : '',
379             deferreable      => $item{'deferrable'},
380             deferred         => $item{'deferred'},
381             reference_table  => $desc->{'reference_table'},
382             reference_fields => $desc->{'reference_fields'},
383 #            match_type       => $desc->{'match_type'}[0],
384             on_delete_do     => $desc->{'on_delete_do'},
385             on_update_do     => $desc->{'on_update_do'},
386             comments         => [ @comments ],
387         } 
388     }
389
390 table_constraint_type : /primary key/i '(' NAME(s /,/) ')' 
391     { 
392         $return = {
393             type   => 'primary_key',
394             fields => $item[3],
395         }
396     }
397     |
398     /unique/i '(' NAME(s /,/) ')' 
399     { 
400         $return    =  {
401             type   => 'unique',
402             fields => $item[3],
403         }
404     }
405     |
406     /check/ '(' /(.+)/ ')'
407     {
408         $return        =  {
409             type       => 'check',
410             expression => $item[3],
411         }
412     }
413     |
414     /foreign key/i '(' NAME(s /,/) ')' /references/i table_name parens_word_list(?) on_delete_do(?)
415     {
416         $return              =  {
417             type             => 'foreign_key',
418             fields           => $item[3],
419             reference_table  => $item[6],
420             reference_fields => $item[7][0],
421             match_type       => $item[8][0],
422             on_delete_do     => $item[9][0],
423             on_update_do     => $item[10][0],
424         }
425     }
426
427 on_delete_do : /on delete/i WORD(s)
428     { $item[2] }
429
430 WORD : /\w+/
431
432 NAME : /\w+/ { $item[1] }
433
434 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
435     { $item[1] }
436     | /'.*?'/   # XXX doesn't handle embedded quotes
437     { $item[1] }
438     | /NULL/
439     { 'NULL' }
440
441 !;
442
443 # -------------------------------------------------------------------
444 sub parse {
445     my ( $translator, $data ) = @_;
446     $parser ||= Parse::RecDescent->new($GRAMMAR);
447
448     local $::RD_TRACE = $translator->trace ? 1 : undef;
449     local $DEBUG      = $translator->debug;
450
451     unless (defined $parser) {
452         return $translator->error("Error instantiating Parse::RecDescent ".
453             "instance: Bad grammer");
454     }
455
456     my $result = $parser->startrule($data);
457     die "Parse failed.\n" unless defined $result;
458     warn Dumper($result) if $DEBUG;
459     return $result;
460 }
461
462 1;
463
464 =pod
465
466 =head1 AUTHOR
467
468 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
469
470 =head1 SEE ALSO
471
472 perl(1), Parse::RecDescent.
473
474 =cut