Allow passing an arrayref to SQLT->filename
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / Access.pm
1 package SQL::Translator::Parser::Access;
2
3 =head1 NAME
4
5 SQL::Translator::Parser::Access - parser for Access as produced by mdbtools
6
7 =head1 SYNOPSIS
8
9   use SQL::Translator;
10   use SQL::Translator::Parser::Access;
11
12   my $translator = SQL::Translator->new;
13   $translator->parser("SQL::Translator::Parser::Access");
14
15 =head1 DESCRIPTION
16
17 The grammar derived from the MySQL grammar.  The input is expected to be
18 something similar to the output of mdbtools (http://mdbtools.sourceforge.net/).
19
20 =cut
21
22 use strict;
23 use warnings;
24
25 our $VERSION = '1.59';
26
27 our $DEBUG;
28 $DEBUG = 0 unless defined $DEBUG;
29
30 use Data::Dumper;
31 use SQL::Translator::Utils qw/ddl_parser_instance/;
32
33 use base qw(Exporter);
34 our @EXPORT_OK = qw(parse);
35
36 our $GRAMMAR = <<'END_OF_GRAMMAR';
37
38 {
39     my ( %tables, $table_order, @table_comments );
40 }
41
42 #
43 # The "eofile" rule makes the parser fail if any "statement" rule
44 # fails.  Otherwise, the first successful match by a "statement"
45 # won't cause the failure needed to know that the parse, as a whole,
46 # failed. -ky
47 #
48 startrule : statement(s) eofile { \%tables }
49
50 eofile : /^\Z/
51
52 statement : comment
53     | use
54     | set
55     | drop
56     | create
57     | <error>
58
59 use : /use/i WORD ';'
60     { @table_comments = () }
61
62 set : /set/i /[^;]+/ ';'
63     { @table_comments = () }
64
65 drop : /drop/i TABLE /[^;]+/ ';'
66
67 drop : /drop/i WORD(s) ';'
68     { @table_comments = () }
69
70 create : CREATE /database/i WORD ';'
71     { @table_comments = () }
72
73 create : CREATE TABLE table_name '(' create_definition(s /,/) ')' ';'
74     {
75         my $table_name                       = $item{'table_name'};
76         $tables{ $table_name }{'order'}      = ++$table_order;
77         $tables{ $table_name }{'table_name'} = $table_name;
78
79         if ( @table_comments ) {
80             $tables{ $table_name }{'comments'} = [ @table_comments ];
81             @table_comments = ();
82         }
83
84         my $i = 1;
85         for my $definition ( @{ $item[5] } ) {
86             if ( $definition->{'supertype'} eq 'field' ) {
87                 my $field_name = $definition->{'name'};
88                 $tables{ $table_name }{'fields'}{ $field_name } =
89                     { %$definition, order => $i };
90                 $i++;
91
92                 if ( $definition->{'is_primary_key'} ) {
93                     push @{ $tables{ $table_name }{'constraints'} },
94                         {
95                             type   => 'primary_key',
96                             fields => [ $field_name ],
97                         }
98                     ;
99                 }
100             }
101             elsif ( $definition->{'supertype'} eq 'constraint' ) {
102                 push @{ $tables{ $table_name }{'constraints'} }, $definition;
103             }
104             elsif ( $definition->{'supertype'} eq 'index' ) {
105                 push @{ $tables{ $table_name }{'indices'} }, $definition;
106             }
107         }
108
109         1;
110     }
111
112 create : CREATE UNIQUE(?) /(index|key)/i index_name /on/i table_name '(' field_name(s /,/) ')' ';'
113     {
114         @table_comments = ();
115         push @{ $tables{ $item{'table_name'} }{'indices'} },
116             {
117                 name   => $item[4],
118                 type   => $item[2] ? 'unique' : 'normal',
119                 fields => $item[8],
120             }
121         ;
122     }
123
124 create_definition : constraint
125     | index
126     | field
127     | comment
128     | <error>
129
130 comment : /^\s*--(.*)\n/
131     {
132         my $comment =  $1;
133         $return     = $comment;
134         push @table_comments, $comment;
135     }
136
137 field : field_name data_type field_qualifier(s?) reference_definition(?)
138     {
139         $return = {
140             supertype   => 'field',
141             name        => $item{'field_name'},
142             data_type   => $item{'data_type'}{'type'},
143             size        => $item{'data_type'}{'size'},
144             constraints => $item{'reference_definition(?)'},
145         }
146     }
147     | <error>
148
149 field_qualifier : not_null
150     {
151         $return = {
152              null => $item{'not_null'},
153         }
154     }
155
156 field_qualifier : default_val
157     {
158         $return = {
159              default => $item{'default_val'},
160         }
161     }
162
163 field_qualifier : auto_inc
164     {
165         $return = {
166              is_auto_inc => $item{'auto_inc'},
167         }
168     }
169
170 field_qualifier : primary_key
171     {
172         $return = {
173              is_primary_key => $item{'primary_key'},
174         }
175     }
176
177 field_qualifier : unsigned
178     {
179         $return = {
180              is_unsigned => $item{'unsigned'},
181         }
182     }
183
184 field_qualifier : /character set/i WORD
185     {
186         $return = {
187             character_set => $item[2],
188         }
189     }
190
191 reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
192     {
193         $return = {
194             type             => 'foreign_key',
195             reference_table  => $item[2],
196             reference_fields => $item[3][0],
197             match_type       => $item[4][0],
198             on_delete        => $item[5][0],
199             on_update        => $item[6][0],
200         }
201     }
202
203 match_type : /match full/i { 'full' }
204     |
205     /match partial/i { 'partial' }
206
207 on_delete : /on delete/i reference_option
208     { $item[2] }
209
210 on_update : /on update/i reference_option
211     { $item[2] }
212
213 reference_option: /restrict/i |
214     /cascade/i   |
215     /set null/i  |
216     /no action/i |
217     /set default/i
218     { $item[1] }
219
220 index : normal_index
221     | fulltext_index
222     | <error>
223
224 table_name   : NAME
225
226 field_name   : NAME
227
228 index_name   : NAME
229
230 data_type    : access_data_type parens_value_list(s?) type_qualifier(s?)
231     {
232         $return        = {
233             type       => $item[1],
234             size       => $item[2][0],
235             qualifiers => $item[3],
236         }
237     }
238
239 access_data_type : /long integer/i { $return = 'Long Integer' }
240     | /text/i { $return = 'Text' }
241     | /datetime (\(short\))?/i { $return = 'DateTime' }
242     | /boolean/i { $return = 'Boolean' }
243     | WORD
244
245 parens_field_list : '(' field_name(s /,/) ')'
246     { $item[2] }
247
248 parens_value_list : '(' VALUE(s /,/) ')'
249     { $item[2] }
250
251 type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
252     { lc $item[1] }
253
254 field_type   : WORD
255
256 create_index : /create/i /index/i
257
258 not_null     : /not/i /null/i { $return = 0 }
259
260 unsigned     : /unsigned/i { $return = 0 }
261
262 default_val : /default/i /'(?:.*?\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
263     {
264         $item[2] =~ s/^\s*'|'\s*$//g;
265         $return  =  $item[2];
266     }
267
268 auto_inc : /auto_increment/i { 1 }
269
270 primary_key : /primary/i /key/i { 1 }
271
272 constraint : primary_key_def
273     | unique_key_def
274     | foreign_key_def
275     | <error>
276
277 foreign_key_def : foreign_key_def_begin parens_field_list reference_definition
278     {
279         $return              =  {
280             supertype        => 'constraint',
281             type             => 'foreign_key',
282             name             => $item[1],
283             fields           => $item[2],
284             %{ $item{'reference_definition'} },
285         }
286     }
287
288 foreign_key_def_begin : /constraint/i /foreign key/i
289     { $return = '' }
290     |
291     /constraint/i WORD /foreign key/i
292     { $return = $item[2] }
293     |
294     /foreign key/i
295     { $return = '' }
296
297 primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
298     {
299         $return       = {
300             supertype => 'constraint',
301             name      => $item{'index_name(?)'}[0],
302             type      => 'primary_key',
303             fields    => $item[4],
304         };
305     }
306
307 unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
308     {
309         $return       = {
310             supertype => 'constraint',
311             name      => $item{'index_name(?)'}[0],
312             type      => 'unique',
313             fields    => $item[5],
314         }
315     }
316
317 normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
318     {
319         $return       = {
320             supertype => 'index',
321             type      => 'normal',
322             name      => $item{'index_name(?)'}[0],
323             fields    => $item[4],
324         }
325     }
326
327 fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
328     {
329         $return       = {
330             supertype => 'index',
331             type      => 'fulltext',
332             name      => $item{'index_name(?)'}[0],
333             fields    => $item[5],
334         }
335     }
336
337 name_with_opt_paren : NAME parens_value_list(s?)
338     { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
339
340 UNIQUE : /unique/i { 1 }
341
342 KEY : /key/i | /index/i
343
344 table_option : WORD /\s*=\s*/ WORD
345     {
346         $return = { $item[1] => $item[3] };
347     }
348
349 CREATE : /create/i
350
351 TEMPORARY : /temporary/i
352
353 TABLE : /table/i
354
355 WORD : /\w+/
356
357 DIGITS : /\d+/
358
359 COMMA : ','
360
361 NAME    : "`" /\w+/ "`"
362     { $item[2] }
363     | /\w+/
364     { $item[1] }
365
366 VALUE   : /[-+]?\.?\d+(?:[eE]\d+)?/
367     { $item[1] }
368     | /'.*?'/
369     {
370         # remove leading/trailing quotes
371         my $val = $item[1];
372         $val    =~ s/^['"]|['"]$//g;
373         $return = $val;
374     }
375     | /NULL/
376     { 'NULL' }
377
378 END_OF_GRAMMAR
379
380 sub parse {
381     my ( $translator, $data ) = @_;
382
383     # Enable warnings within the Parse::RecDescent module.
384     local $::RD_ERRORS = 1 unless defined $::RD_ERRORS; # Make sure the parser dies when it encounters an error
385     local $::RD_WARN   = 1 unless defined $::RD_WARN; # Enable warnings. This will warn on unused rules &c.
386     local $::RD_HINT   = 1 unless defined $::RD_HINT; # Give out hints to help fix problems.
387
388     local $::RD_TRACE  = $translator->trace ? 1 : undef;
389     local $DEBUG       = $translator->debug;
390
391     my $parser = ddl_parser_instance('Access');
392
393     my $result = $parser->startrule($data);
394     return $translator->error( "Parse failed." ) unless defined $result;
395     warn Dumper( $result ) if $DEBUG;
396
397     my $schema = $translator->schema;
398     my @tables = sort {
399         $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
400     } keys %{ $result };
401
402     for my $table_name ( @tables ) {
403         my $tdata =  $result->{ $table_name };
404         my $table =  $schema->add_table(
405             name  => $tdata->{'table_name'},
406         ) or die $schema->error;
407
408         $table->comments( $tdata->{'comments'} );
409
410         my @fields = sort {
411             $tdata->{'fields'}->{$a}->{'order'}
412             <=>
413             $tdata->{'fields'}->{$b}->{'order'}
414         } keys %{ $tdata->{'fields'} };
415
416         for my $fname ( @fields ) {
417             my $fdata = $tdata->{'fields'}{ $fname };
418             my $field = $table->add_field(
419                 name              => $fdata->{'name'},
420                 data_type         => $fdata->{'data_type'},
421                 size              => $fdata->{'size'},
422                 default_value     => $fdata->{'default'},
423                 is_auto_increment => $fdata->{'is_auto_inc'},
424                 is_nullable       => $fdata->{'null'},
425                 comments          => $fdata->{'comments'},
426             ) or die $table->error;
427
428             $table->primary_key( $field->name ) if $fdata->{'is_primary_key'};
429         }
430
431         for my $idata ( @{ $tdata->{'indices'} || [] } ) {
432             my $index  =  $table->add_index(
433                 name   => $idata->{'name'},
434                 type   => uc $idata->{'type'},
435                 fields => $idata->{'fields'},
436             ) or die $table->error;
437         }
438     }
439
440     return 1;
441 }
442
443 1;
444
445 # -------------------------------------------------------------------
446 # Where man is not nature is barren.
447 # William Blake
448 # -------------------------------------------------------------------
449
450 =pod
451
452 =head1 AUTHOR
453
454 Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
455
456 =head1 SEE ALSO
457
458 perl(1), Parse::RecDescent, SQL::Translator::Schema.
459
460 =cut