Allow passing an arrayref to SQLT->filename
[dbsrgits/SQL-Translator.git] / lib / SQL / Translator / Parser / Access.pm
CommitLineData
7c44825c 1package SQL::Translator::Parser::Access;
2
7c44825c 3=head1 NAME
4
5SQL::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
ea93df61 17The grammar derived from the MySQL grammar. The input is expected to be
7c44825c 18something similar to the output of mdbtools (http://mdbtools.sourceforge.net/).
19
20=cut
21
22use strict;
f27f9229 23use warnings;
bdf60588 24
0c04c5a2 25our $VERSION = '1.59';
7c44825c 26
bdf60588 27our $DEBUG;
28$DEBUG = 0 unless defined $DEBUG;
7c44825c 29
bdf60588 30use Data::Dumper;
31use SQL::Translator::Utils qw/ddl_parser_instance/;
7c44825c 32
bdf60588 33use base qw(Exporter);
34our @EXPORT_OK = qw(parse);
7c44825c 35
bdf60588 36our $GRAMMAR = <<'END_OF_GRAMMAR';
7c44825c 37
ea93df61 38{
7c44825c 39 my ( %tables, $table_order, @table_comments );
40}
41
42#
43# The "eofile" rule makes the parser fail if any "statement" rule
ea93df61 44# fails. Otherwise, the first successful match by a "statement"
7c44825c 45# won't cause the failure needed to know that the parse, as a whole,
46# failed. -ky
47#
48startrule : statement(s) eofile { \%tables }
49
50eofile : /^\Z/
51
52statement : comment
53 | use
54 | set
55 | drop
56 | create
57 | <error>
58
59use : /use/i WORD ';'
60 { @table_comments = () }
61
62set : /set/i /[^;]+/ ';'
63 { @table_comments = () }
64
65drop : /drop/i TABLE /[^;]+/ ';'
66
67drop : /drop/i WORD(s) ';'
68 { @table_comments = () }
69
70create : CREATE /database/i WORD ';'
71 { @table_comments = () }
72
73create : CREATE TABLE table_name '(' create_definition(s /,/) ')' ';'
ea93df61 74 {
7c44825c 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'};
ea93df61 88 $tables{ $table_name }{'fields'}{ $field_name } =
7c44825c 89 { %$definition, order => $i };
90 $i++;
ea93df61 91
7c44825c 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
112create : 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
ea93df61 124create_definition : constraint
7c44825c 125 | index
126 | field
127 | comment
128 | <error>
129
ea93df61 130comment : /^\s*--(.*)\n/
131 {
7c44825c 132 my $comment = $1;
133 $return = $comment;
134 push @table_comments, $comment;
135 }
136
137field : field_name data_type field_qualifier(s?) reference_definition(?)
ea93df61 138 {
139 $return = {
7c44825c 140 supertype => 'field',
ea93df61 141 name => $item{'field_name'},
7c44825c 142 data_type => $item{'data_type'}{'type'},
143 size => $item{'data_type'}{'size'},
7c44825c 144 constraints => $item{'reference_definition(?)'},
ea93df61 145 }
7c44825c 146 }
147 | <error>
148
149field_qualifier : not_null
ea93df61 150 {
151 $return = {
7c44825c 152 null => $item{'not_null'},
ea93df61 153 }
7c44825c 154 }
155
156field_qualifier : default_val
ea93df61 157 {
158 $return = {
7c44825c 159 default => $item{'default_val'},
ea93df61 160 }
7c44825c 161 }
162
163field_qualifier : auto_inc
ea93df61 164 {
165 $return = {
7c44825c 166 is_auto_inc => $item{'auto_inc'},
ea93df61 167 }
7c44825c 168 }
169
170field_qualifier : primary_key
ea93df61 171 {
172 $return = {
7c44825c 173 is_primary_key => $item{'primary_key'},
ea93df61 174 }
7c44825c 175 }
176
177field_qualifier : unsigned
ea93df61 178 {
179 $return = {
7c44825c 180 is_unsigned => $item{'unsigned'},
ea93df61 181 }
7c44825c 182 }
183
184field_qualifier : /character set/i WORD
185 {
186 $return = {
187 character_set => $item[2],
188 }
189 }
190
100684f3 191reference_definition : /references/i table_name parens_field_list(?) match_type(?) on_delete(?) on_update(?)
7c44825c 192 {
193 $return = {
194 type => 'foreign_key',
195 reference_table => $item[2],
196 reference_fields => $item[3][0],
197 match_type => $item[4][0],
100684f3 198 on_delete => $item[5][0],
199 on_update => $item[6][0],
7c44825c 200 }
201 }
202
203match_type : /match full/i { 'full' }
204 |
205 /match partial/i { 'partial' }
206
100684f3 207on_delete : /on delete/i reference_option
7c44825c 208 { $item[2] }
209
100684f3 210on_update : /on update/i reference_option
7c44825c 211 { $item[2] }
212
ea93df61 213reference_option: /restrict/i |
214 /cascade/i |
215 /set null/i |
216 /no action/i |
7c44825c 217 /set default/i
ea93df61 218 { $item[1] }
7c44825c 219
220index : normal_index
221 | fulltext_index
222 | <error>
223
224table_name : NAME
225
226field_name : NAME
227
228index_name : NAME
229
230data_type : access_data_type parens_value_list(s?) type_qualifier(s?)
ea93df61 231 {
232 $return = {
7c44825c 233 type => $item[1],
234 size => $item[2][0],
235 qualifiers => $item[3],
ea93df61 236 }
7c44825c 237 }
238
239access_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
245parens_field_list : '(' field_name(s /,/) ')'
246 { $item[2] }
247
248parens_value_list : '(' VALUE(s /,/) ')'
249 { $item[2] }
250
251type_qualifier : /(BINARY|UNSIGNED|ZEROFILL)/i
252 { lc $item[1] }
253
254field_type : WORD
255
256create_index : /create/i /index/i
257
258not_null : /not/i /null/i { $return = 0 }
259
260unsigned : /unsigned/i { $return = 0 }
261
bdf60588 262default_val : /default/i /'(?:.*?\')*.*?'|(?:')?[\w\d:.-]*(?:')?/
7c44825c 263 {
264 $item[2] =~ s/^\s*'|'\s*$//g;
265 $return = $item[2];
266 }
267
268auto_inc : /auto_increment/i { 1 }
269
270primary_key : /primary/i /key/i { 1 }
271
272constraint : primary_key_def
273 | unique_key_def
274 | foreign_key_def
275 | <error>
276
277foreign_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
ea93df61 288foreign_key_def_begin : /constraint/i /foreign key/i
7c44825c 289 { $return = '' }
290 |
291 /constraint/i WORD /foreign key/i
292 { $return = $item[2] }
293 |
294 /foreign key/i
295 { $return = '' }
296
297primary_key_def : primary_key index_name(?) '(' name_with_opt_paren(s /,/) ')'
ea93df61 298 {
299 $return = {
7c44825c 300 supertype => 'constraint',
301 name => $item{'index_name(?)'}[0],
302 type => 'primary_key',
303 fields => $item[4],
304 };
305 }
306
307unique_key_def : UNIQUE KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
ea93df61 308 {
309 $return = {
7c44825c 310 supertype => 'constraint',
311 name => $item{'index_name(?)'}[0],
312 type => 'unique',
313 fields => $item[5],
ea93df61 314 }
7c44825c 315 }
316
317normal_index : KEY index_name(?) '(' name_with_opt_paren(s /,/) ')'
ea93df61 318 {
319 $return = {
7c44825c 320 supertype => 'index',
321 type => 'normal',
322 name => $item{'index_name(?)'}[0],
323 fields => $item[4],
ea93df61 324 }
7c44825c 325 }
326
327fulltext_index : /fulltext/i KEY(?) index_name(?) '(' name_with_opt_paren(s /,/) ')'
ea93df61 328 {
329 $return = {
7c44825c 330 supertype => 'index',
331 type => 'fulltext',
332 name => $item{'index_name(?)'}[0],
333 fields => $item[5],
ea93df61 334 }
7c44825c 335 }
336
337name_with_opt_paren : NAME parens_value_list(s?)
338 { $item[2][0] ? "$item[1]($item[2][0][0])" : $item[1] }
339
340UNIQUE : /unique/i { 1 }
341
342KEY : /key/i | /index/i
343
344table_option : WORD /\s*=\s*/ WORD
ea93df61 345 {
7c44825c 346 $return = { $item[1] => $item[3] };
347 }
348
349CREATE : /create/i
350
351TEMPORARY : /temporary/i
352
353TABLE : /table/i
354
355WORD : /\w+/
356
357DIGITS : /\d+/
358
359COMMA : ','
360
361NAME : "`" /\w+/ "`"
362 { $item[2] }
363 | /\w+/
364 { $item[1] }
365
366VALUE : /[-+]?\.?\d+(?:[eE]\d+)?/
367 { $item[1] }
ea93df61 368 | /'.*?'/
369 {
370 # remove leading/trailing quotes
7c44825c 371 my $val = $item[1];
372 $val =~ s/^['"]|['"]$//g;
373 $return = $val;
374 }
375 | /NULL/
376 { 'NULL' }
377
bdf60588 378END_OF_GRAMMAR
7c44825c 379
7c44825c 380sub parse {
381 my ( $translator, $data ) = @_;
bdf60588 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.
7c44825c 387
388 local $::RD_TRACE = $translator->trace ? 1 : undef;
389 local $DEBUG = $translator->debug;
390
bdf60588 391 my $parser = ddl_parser_instance('Access');
7c44825c 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;
ea93df61 398 my @tables = sort {
7c44825c 399 $result->{ $a }->{'order'} <=> $result->{ $b }->{'order'}
400 } keys %{ $result };
401
402 for my $table_name ( @tables ) {
403 my $tdata = $result->{ $table_name };
ea93df61 404 my $table = $schema->add_table(
7c44825c 405 name => $tdata->{'table_name'},
406 ) or die $schema->error;
407
408 $table->comments( $tdata->{'comments'} );
409
ea93df61 410 my @fields = sort {
411 $tdata->{'fields'}->{$a}->{'order'}
7c44825c 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'};
7c44825c 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 }
7c44825c 438 }
439
440 return 1;
441}
442
4431;
444
445# -------------------------------------------------------------------
446# Where man is not nature is barren.
447# William Blake
448# -------------------------------------------------------------------
449
450=pod
451
452=head1 AUTHOR
453
11ad2df9 454Ken Y. Clark E<lt>kclark@cpan.orgE<gt>.
7c44825c 455
456=head1 SEE ALSO
457
458perl(1), Parse::RecDescent, SQL::Translator::Schema.
459
460=cut