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