File Coverage

lib/Config/Grammar.pm
Criterion Covered Total %
statement 271 382 70.9
branch 120 212 56.6
condition 3 21 14.2
subroutine 21 24 87.5
pod 0 6 0.0
total 415 645 64.3


line stmt bran cond sub pod time code
1             package Config::Grammar;
2 4     4   60555 use strict;
  4         24  
  4         14456  
3              
4             $Config::Grammar::VERSION = '1.13';
5              
6             sub new($$)
7             {
8 4     4 0 585 my $proto = shift;
9 4         7 my $grammar = shift;
10 4   33     31 my $class = ref($proto) || $proto;
11              
12 4         12 my $self = {grammar => $grammar};
13 4         9 bless($self, $class);
14 4         11 return $self;
15             }
16              
17             sub err($)
18             {
19 0     0 0 0 my $self = shift;
20 0         0 return $self->{'err'};
21             }
22              
23             sub _make_error($$)
24             {
25 3     3   4 my $self = shift;
26 3         4 my $text = shift;
27 3         13 $self->{'err'} = "$self->{file}, line $self->{line}: $text";
28             }
29              
30             sub _peek($)
31             {
32 0     0   0 my $a = shift;
33 0         0 return $a->[$#$a];
34             }
35              
36             sub _quotesplit($)
37             {
38 4     4   7 my $line = shift;
39 4         4 my @items;
40 4         10 while ($line ne "") {
41 10 50       82 if ($line =~ s/^"((?:\\.|[^"])*)"\s*//) {
    50          
    50          
42 0         0 my $frag = $1;
43 0         0 $frag =~ s/\\(.)/$1/g;
44 0         0 push @items, $frag;
45             } elsif ($line =~ s/^'((?:\\.|[^'])*)'\s*//) {
46 0         0 my $frag = $1;
47 0         0 $frag =~ s/\\(.)/$1/g;
48 0         0 push @items, $frag;
49             }
50             elsif ($line =~ s/^((?:\\.|[^\s])*)(?:\s+|$)//) {
51 10         18 my $frag = $1;
52 10         13 $frag =~ s/\\(.)/$1/g;
53 10         21 push @items, $frag;
54             }
55             else {
56 0         0 die "Internal parser error for '$line'";
57             }
58             }
59 4         12 return @items;
60             }
61              
62             sub _check_mandatory($$$$)
63             {
64 14     14   18 my $self = shift;
65 14         16 my $g = shift;
66 14         16 my $c = shift;
67 14         16 my $section = shift;
68              
69             # check _mandatory sections, variables and tables
70 14 50       24 if (defined $g->{_mandatory}) {
71 0         0 for (@{$g->{_mandatory}}) {
  0         0  
72 0 0       0 if (not defined $g->{$_}) {
73 0         0 $g->{$_} = {};
74             }
75 0 0       0 if (not defined $c->{$_}) {
76 0 0       0 if (defined $section) {
77 0         0 $self->{'err'} .= "$self->{file} ($section): ";
78             }
79             else {
80 0         0 $self->{'err'} = "$self->{file}: ";
81             }
82              
83 0 0       0 if (defined $g->{$_}{_is_section}) {
    0          
84 0         0 $self->{'err'} .= "mandatory (sub)section '$_' not defined";
85             }
86             elsif ($_ eq '_table') {
87 0         0 $self->{'err'} .= "mandatory table not defined";
88             }
89             else {
90 0         0 $self->{'err'} .= "mandatory variable '$_' not defined";
91             }
92 0         0 return 0;
93             }
94             }
95             }
96              
97 14         34 for (keys %$c) {
98              
99             # do some cleanup
100 64 100       93 ref $c->{$_} eq 'HASH' or next;
101 11 50       16 defined $c->{$_}{_is_section} or next;
102 11 100       64 $self->_check_mandatory($g->{$c->{$_}{_grammar}}, $c->{$_},
    50          
103             defined $section ? "$section/$_" : "$_") or return 0;
104 11         21 delete $c->{$_}{_is_section};
105 11         12 delete $c->{$_}{_grammar};
106 11 50       19 delete $c->{$_}{_order_count} if exists $c->{$_}{_order_count};
107             }
108              
109 14         31 return 1;
110             }
111              
112             ######### SECTIONS #########
113              
114             # search grammar definition of a section
115             sub _search_section($$)
116             {
117 12     12   16 my $self = shift;
118 12         14 my $name = shift;
119              
120 12 50       23 if (not defined $self->{grammar}{_sections}) {
121 0         0 $self->_make_error("no sections are allowed");
122 0         0 return undef;
123             }
124              
125             # search exact match
126 12         19 for (@{$self->{grammar}{_sections}}) {
  12         27  
127 17 100       29 if ($name eq $_) {
128 10         21 return $_;
129             }
130             }
131              
132             # search regular expression
133 2         5 for (@{$self->{grammar}{_sections}}) {
  2         5  
134 2 50       11 if (m|^/(.*)/$|) {
135 2 50       52 if ($name =~ /^$1$/) {
136 2         11 return $_;
137             }
138             }
139             }
140              
141             # no match
142 0         0 $self->_make_error("unknown section '$name'");
143 0         0 return undef;
144             }
145              
146             # fill in default values for this section
147             sub _fill_defaults ($) {
148 14     14   18 my $self = shift;
149 14         17 my $g = $self->{grammar};
150 14         14 my $c = $self->{cfg};
151 14 100       23 if ($g->{_vars}) {
152 10         9 for my $var (@{$g->{_vars}}) {
  10         25  
153 34 100       52 next if exists $c->{$var};
154             my $value = $g->{$var}{_default}
155 14 100       24 if exists $g->{$var}{_default};
156 14 100       20 next unless defined $value;
157 6         19 $c->{$var} = $value;
158             }
159             }
160              
161             }
162              
163             sub _next_level($$$)
164             {
165 5     5   7 my $self = shift;
166 5         7 my $name = shift;
167              
168             # section name
169 5 100       16 if (defined $self->{section}) {
170 1         2 $self->{section} .= "/$name";
171             }
172             else {
173 4         8 $self->{section} = $name;
174             }
175              
176             # grammar context
177 5         14 my $s = $self->_search_section($name);
178 5 50       11 return 0 unless defined $s;
179 5 50       11 if (not defined $self->{grammar}{$s}) {
180 0         0 $self->_make_error("Config::Grammar internal error (no grammar for $s)");
181 0         0 return 0;
182             }
183 5         5 push @{$self->{grammar_stack}}, $self->{grammar};
  5         11  
184 5         7 $self->{grammar} = $self->{grammar}{$s};
185              
186             # support for inherited values
187             # note that we have to do this on the way down
188             # and keep track of which values were inherited
189             # so that we can propagate the values even further
190             # down if needed
191 5         6 my %inherited;
192 5 50       11 if ($self->{grammar}{_inherited}) {
193 0         0 for my $var (@{$self->{grammar}{_inherited}}) {
  0         0  
194 0 0       0 next unless exists $self->{cfg}{$var};
195 0         0 my $value = $self->{cfg}{$var};
196 0 0       0 next unless defined $value;
197 0 0       0 next if ref $value; # it's a section
198 0         0 $inherited{$var} = $value;
199             }
200             }
201              
202             # config context
203 5         4 my $order;
204 5 50       10 if (defined $self->{grammar}{_order}) {
205 0 0       0 if (defined $self->{cfg}{_order_count}) {
206 0         0 $order = ++$self->{cfg}{_order_count};
207             }
208             else {
209 0         0 $order = $self->{cfg}{_order_count} = 0;
210             }
211             }
212              
213 5 50       12 if (defined $self->{cfg}{$name}) {
214 0         0 $self->_make_error('section or variable already exists');
215 0         0 return 0;
216             }
217 5         14 $self->{cfg}{$name} = { %inherited }; # inherit the values
218 5         5 push @{$self->{cfg_stack}}, $self->{cfg};
  5         16  
219 5         7 $self->{cfg} = $self->{cfg}{$name};
220              
221             # keep track of the inherited values here;
222             # we delete it on the way up in _prev_level()
223 5         8 $self->{cfg}{_inherited} = \%inherited;
224              
225             # list of already defined variables on this level
226 5 50       28 if (defined $self->{grammar}{_varlist}) {
227 0         0 $self->{cfg}{_varlist} = [];
228             }
229              
230             # meta data for _mandatory test
231 5         16 $self->{grammar}{_is_section} = 1;
232 5         8 $self->{cfg}{_is_section} = 1;
233 5         7 $self->{cfg}{_grammar} = $s;
234 5 50       14 $self->{cfg}{_order} = $order if defined $order;
235              
236             # increase level
237 5         8 $self->{level}++;
238              
239 5         15 return 1;
240             }
241              
242             sub _prev_level($)
243             {
244 11     11   12 my $self = shift;
245              
246             # fill in the values from _default keywords when going up
247 11         26 $self->_fill_defaults;
248              
249             # section name
250 11 100       19 if (defined $self->{section}) {
251 9 100       26 if ($self->{section} =~ /\//) {
252 4         20 $self->{section} =~ s/\/.*?$//;
253             }
254             else {
255 5         6 $self->{section} = undef;
256             }
257             }
258              
259             # clean up the _inherited hash, we won't need it anymore
260 11         25 delete $self->{cfg}{_inherited};
261              
262             # config context
263 11         36 $self->{cfg} = pop @{$self->{cfg_stack}};
  11         20  
264              
265             # grammar context
266 11         13 $self->{grammar} = pop @{$self->{grammar_stack}};
  11         15  
267              
268             # decrease level
269 11         20 $self->{level}--;
270             }
271              
272             sub _goto_level($$$)
273             {
274 15     15   20 my $self = shift;
275 15         13 my $level = shift;
276 15         17 my $name = shift;
277              
278             # _text is multi-line. Check when changing level
279 15 50       35 $self->_check_text($self->{section}) or return 0;
280              
281 15 100       70 if ($level > $self->{level}) {
282 9 50       22 if ($level > $self->{level} + 1) {
283 0         0 $self->_make_error("section nesting error");
284 0         0 return 0;
285             }
286 9 50       26 $self->_next_level($name) or return 0;
287             }
288             else {
289              
290 6         23 while ($self->{level} > $level) {
291 8         19 $self->_prev_level;
292             }
293 6 100       22 if ($level != 0) {
294 3         12 $self->_prev_level;
295 3 50       12 $self->_next_level($name) or return 0;
296             }
297             }
298              
299 15         34 return 1;
300             }
301              
302             ######### VARIABLES #########
303              
304             # search grammar definition of a variable
305             sub _search_variable($$)
306             {
307 19     19   22 my $self = shift;
308 19         19 my $name = shift;
309              
310 19 50       34 if (not defined $self->{grammar}{_vars}) {
311 0         0 $self->_make_error("no variables are allowed");
312 0         0 return undef;
313             }
314              
315             # search exact match
316 19         40 for (@{$self->{grammar}{_vars}}) {
  19         40  
317 38 100       59 if ($name eq $_) {
318 18         39 return $_;
319             }
320             }
321              
322             # search regular expression
323 1         2 for (@{$self->{grammar}{_vars}}) {
  1         10  
324 1 50       3 if (m|^/(.*)/$|) {
325 0 0       0 if ($name =~ /^$1$/) {
326 0         0 return $_;
327             }
328             }
329             }
330              
331             # no match
332 1         15 $self->_make_error("unknown variable '$name'");
333 1         2 return undef;
334             }
335              
336             sub _set_variable($$$)
337             {
338 5     5   6 my $self = shift;
339 5         9 my $key = shift;
340 5         13 my $value = shift;
341            
342 5         13 my $gn = $self->_search_variable($key);
343 5 50       10 defined $gn or return 0;
344              
345 5         6 my $varlistref;
346 5 50       10 if (defined $self->{grammar}{_varlist}) {
347 0         0 $varlistref = $self->{cfg}{_varlist};
348             }
349              
350 5 50       9 if (defined $self->{grammar}{$gn}) {
351 5         7 my $g = $self->{grammar}{$gn};
352              
353             # check regular expression
354 5 100       10 if (defined $g->{_re}) {
355 3 50       63 $value =~ /^$g->{_re}$/ or do {
356 0 0       0 if (defined $g->{_re_error}) {
357 0         0 $self->_make_error($g->{_re_error});
358             }
359             else {
360 0         0 $self->_make_error("syntax error in value of '$key'");
361             }
362 0         0 return 0;
363             }
364             }
365 5 100       22 if (defined $g->{_sub}){
366 2         3 my $error = &{$g->{_sub}}($value, $varlistref);
  2         5  
367 2 100       11 if (defined $error){
368 1         4 $self->_make_error($error);
369 1         5 return 0;
370             }
371             }
372             }
373 4         8 $self->{cfg}{$key} = $value;
374 4 50       15 push @{$varlistref}, $key if ref $varlistref;
  0         0  
375              
376 4         9 return 1;
377             }
378              
379             ######### PARSER #########
380              
381             sub _parse_table($$)
382             {
383 4     4   6 my $self = shift;
384 4         5 local $_ = shift;
385              
386 4         5 my $g = $self->{grammar}{_table};
387 4 50       8 defined $g or do {
388 0         0 $self->_make_error("table syntax error");
389 0         0 return 0;
390             };
391              
392 4         15 my @l = _quotesplit $_;
393              
394             # check number of columns
395 4         6 my $columns = $g->{_columns};
396 4 50 33     18 if (defined $columns and $#l + 1 != $columns) {
397 0         0 $self->_make_error("row must have $columns columns (has " . ($#l + 1)
398             . ")");
399 0         0 return 0;
400             }
401              
402             # check columns
403 4         7 my $n = 0;
404 4         7 for my $c (@l) {
405 10         14 my $gc = $g->{$n};
406 10 100       15 defined $gc or next;
407              
408             # regular expression
409 7 100       13 if (defined $gc->{_re}) {
410 6 50       113 $c =~ /^$gc->{_re}$/ or do {
411 0 0       0 if (defined $gc->{_re_error}) {
412 0         0 $self->_make_error("column ".($n+1).": $gc->{_re_error}");
413             }
414             else {
415 0         0 $self->_make_error("syntax error in column ".($n+1));
416             }
417 0         0 return 0;
418             };
419             }
420 7 100       16 if (defined $gc->{_sub}){
421 1         2 my $error = &{$gc->{_sub}}($c);
  1         9  
422 1 50       32 if (defined $error) {
423 1         5 $self->_make_error($error);
424 1         5 return 0;
425             }
426             }
427 6         9 $n++;
428             }
429              
430             # hash (keyed table)
431 3 50       6 if (defined $g->{_key}) {
432 3         3 my $kn = $g->{_key};
433 3 50 33     19 if ($kn < 0 or $kn > $#l) {
434 0         0 $self->_make_error("grammar error: key out of bounds");
435             }
436 3         5 my $k = $l[$kn];
437              
438 3 50       6 if (defined $self->{cfg}{$k}) {
439 0         0 $self->_make_error("table row $k already defined");
440 0         0 return 0;
441             }
442 3         6 $self->{cfg}{$k} = \@l;
443             }
444              
445             # list (unkeyed table)
446             else {
447 0         0 push @{$self->{cfg}{_table}}, \@l;
  0         0  
448             }
449              
450 3         7 return 1;
451             }
452              
453             sub _parse_text($$)
454             {
455 3     3   5 my ($self, $line) = @_;
456              
457 3         4 $self->{cfg}{_text} .= $line;
458              
459 3         5 return 1;
460             }
461              
462             sub _check_text($$)
463             {
464 15     15   34 my ($self, $name) = @_;
465              
466 15         21 my $g = $self->{grammar}{_text};
467 15 100       43 defined $g or return 1;
468              
469             # chop empty lines at beginning and end
470 1 50       3 if(defined $self->{cfg}{_text}) {
471 1         7 $self->{cfg}{_text} =~ s/\A([ \t]*[\n\r]+)*//m;
472 1         6 $self->{cfg}{_text} =~ s/^([ \t]*[\n\r]+)*\Z//m;
473             }
474              
475 1 50       3 if (defined $g->{_re}) {
476 0 0       0 $self->{cfg}{_text} =~ /^$g->{_re}$/ or do {
477 0 0       0 if (defined $g->{_re_error}) {
478 0         0 $self->_make_error($g->{_re_error});
479             }
480             else {
481 0         0 $self->_make_error("syntax error");
482             }
483 0         0 return 0;
484             }
485             }
486 1 50       4 if (defined $g->{_sub}){
487 0         0 my $error = &{$g->{_sub}}($self->{cfg}{_text});
  0         0  
488 0 0       0 if (defined $error) {
489 0         0 $self->_make_error($error);
490 0         0 return 0;
491             }
492             }
493 1         3 return 1;
494             }
495              
496             sub _parse_file($$);
497              
498             sub _parse_line($$$)
499             {
500 39     39   36 my $self = shift;
501 39         54 local $_ = shift;
502 39         59 my $source = shift;
503              
504 39 50       65 /^\@include\s+["']?(.*)["']?$/ and do {
505 0         0 my $inc = $1;
506 0 0 0     0 if ( ( $^O eq 'win32' and $inc !~ m|^(?:[a-z]:)?[/\\]|i and $self->{file} =~ m|^(.+)[\\/][^/]+$| ) or
      0        
      0        
      0        
507             ( $inc !~ m|^/| and $self->{file} =~ m|^(.+)/[^/]+$| ) ){
508 0         0 $inc = "$1/$inc";
509             }
510 0         0 push @{$self->{file_stack}}, $self->{file};
  0         0  
511 0         0 push @{$self->{line_stack}}, $self->{line};
  0         0  
512 0 0       0 $self->_parse_file($inc) or return 0;
513 0         0 $self->{file} = pop @{$self->{file_stack}};
  0         0  
514 0         0 $self->{line} = pop @{$self->{line_stack}};
  0         0  
515 0         0 return 1;
516             };
517 39 100       52 /^\@define\s+(\S+)\s+(.*)$/ and do {
518 1         5 $self->{defines}{$1}=$2;
519 1         4 return 1;
520             };
521              
522 38 100       60 if(defined $self->{defines}) {
523 13         13 for my $d (keys %{$self->{defines}}) {
  13         25  
524 13         76 s/$d/$self->{defines}{$d}/g;
525             }
526             }
527              
528 38 100       82 /^\*\*\*\s*(.*?)\s*\*\*\*$/ and do {
529 6         13 my $name = $1;
530 6 50       31 $self->_goto_level(1, $name) or return 0;
531 6 50       28 $self->_check_section_sub($name) or return 0;
532 6         15 return 1;
533             };
534 32 100       60 /^(\++)\s*(.*)$/ and do {
535 6         11 my $level = length $1;
536 6         9 my $name = $2;
537 6 50       15 $self->_goto_level($level + 1, $name) or return 0;
538 6 50       17 $self->_check_section_sub($name) or return 0;
539 6         13 return 1;
540             };
541              
542 26 100       42 if (defined $self->{grammar}{_text}) {
543 3 50       6 $self->_parse_text($source) or return 0;
544 3         5 return 1;
545             }
546 23 100       78 /^(\S+)\s*=\s*(.*)$/ and do {
547 19 100       45 if (defined $self->{cfg}{$1}) {
548 1 50       10 if (exists $self->{cfg}{_inherited}{$1}) {
549             # it's OK to override any inherited values
550 1         3 delete $self->{cfg}{_inherited}{$1};
551 1         2 delete $self->{cfg}{$1};
552             } else {
553 0         0 $self->_make_error('variable already defined');
554 0         0 return 0;
555             }
556             }
557 19 100       53 $self->_set_variable($1, $2) or return 0;
558 17         30 return 1;
559             };
560              
561 4 100       11 $self->_parse_table($_) or return 0;
562              
563 3         6 return 1;
564             }
565              
566             sub _check_section_sub($$) {
567 12     12   15 my $self = shift;
568 12         15 my $name = shift;
569 12         16 my $g = $self->{grammar};
570 12 100       35 if (defined $g->{_sub}){
571 2         8 my $error = &{$g->{_sub}}($name);
  2         6  
572 2 50       19 if (defined $error){
573 0         0 $self->_make_error($error);
574 0         0 return 0;
575             }
576             }
577 12         24 return 1;
578             }
579              
580             sub _parse_file($$)
581             {
582 6     6   8 my $self = shift;
583 6         9 my $file = shift;
584              
585 6 50       16 unless ($file) { $self->{'err'} = "no filename given" ;
  0         0  
586 0         0 return undef;};
587              
588 6         17 my $fh;
589 6         8 my $mode = "<";
590 6 50       22 $mode .= ":encoding($self->{encoding})" if $self->{encoding};
591 6 50       202 open($fh, $mode, "$file") or do {
592 0         0 $self->{'err'} = "can't open $file: $!";
593 0         0 return undef;
594             };
595 6         26 $self->{file} = $file;
596              
597 6         7 local $_;
598 6         11 my $source = '';
599 6         113 while (<$fh>) {
600 51         64 $source .= $_;
601 51         55 chomp;
602 51         100 s/^\s+//;
603 51         99 s/\s+$//; # trim
604 51         96 s/\s*#.*$//; # comments
605 51 100       103 next if $_ eq ''; # empty lines
606 39         63 while (/\\$/) {# continuation
607 0         0 s/\\$//;
608 0         0 my $n = <$fh>;
609 0 0       0 last if not defined $n;
610 0         0 chomp $n;
611 0         0 $n =~ s/^\s+//;
612 0         0 $n =~ s/\s+$//; # trim
613 0         0 $_ .= ' ' . $n;
614             }
615              
616 39         70 $self->{line} = $.;
617 39 100       75 $self->_parse_line($_, $source) or do{ close $fh; return 0; };
  3         32  
  3         28  
618 36         104 $source = '';
619             }
620 3         28 close $fh;
621 3         21 return 1;
622             }
623              
624             sub makepod($) {
625 1     1 0 572 my $pod = eval {
626 1         2194 require Config::Grammar::Document;
627 1         5 return Config::Grammar::Document::makepod(@_);
628             };
629 1 50       4 defined $pod or die "ERROR: install Config::Grammar::Document in order to use makepod(): $@\n";
630 1         3 return $pod;
631             }
632              
633             sub maketmpl ($@) {
634 3     3 0 477 my $pod = eval {
635 3         3967 require Config::Grammar::Document;
636 3         17 return Config::Grammar::Document::maketmpl(@_);
637             };
638 3 50       10 defined $pod or die "ERROR: install Config::Grammar::Document in order to use maketmpl()\n";
639 3         8 return $pod;
640             }
641              
642             sub makemintmpl ($@) {
643 0     0 0 0 my $pod = eval {
644 0         0 require Config::Grammar::Document;
645 0         0 return Config::Grammar::Document::makemintmpl(@_);
646             };
647 0 0       0 defined $pod or die "ERROR: install Config::Grammar::Document in order to use makemintmpl()\n";
648 0         0 return $pod;
649             }
650              
651             sub parse($$$)
652             {
653 3     3 0 765 my $self = shift;
654 3         5 my $file = shift;
655 3         4 my $args = shift;
656              
657 3 50       9 $self->{encoding} = $args->{encoding} if ref $args eq 'HASH';
658              
659 3         11 $self->{cfg} = {};
660 3         8 $self->{level} = 0;
661 3         7 $self->{cfg_stack} = [];
662 3         6 $self->{grammar_stack} = [];
663 3         6 $self->{file_stack} = [];
664 3         5 $self->{line_stack} = [];
665              
666 3 100       9 $self->_parse_file($file) or return undef;
667              
668 1 50       4 $self->_goto_level(0, undef) or return undef;
669              
670             # fill in the top level values from _default keywords
671 1         2 $self->_fill_defaults;
672              
673             $self->_check_mandatory($self->{grammar}, $self->{cfg}, undef)
674 1 50       4 or return undef;
675              
676 1         3 return $self->{cfg};
677              
678             }
679              
680             1;
681              
682             __END__