File Coverage

lib/Config/AST.pm
Criterion Covered Total %
statement 303 365 83.0
branch 132 192 68.7
condition 35 56 62.5
subroutine 40 48 83.3
pod 27 31 87.1
total 537 692 77.6


line stmt bran cond sub pod time code
1             # This file is part of Config::AST -*- perl -*-
2             # Copyright (C) 2017-2021 Sergey Poznyakoff
3             #
4             # Config::AST is free software; you can redistribute it and/or modify
5             # it under the terms of the GNU General Public License as published by
6             # the Free Software Foundation; either version 3, or (at your option)
7             # any later version.
8             #
9             # Config::AST is distributed in the hope that it will be useful,
10             # but WITHOUT ANY WARRANTY; without even the implied warranty of
11             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12             # GNU General Public License for more details.
13             #
14             # You should have received a copy of the GNU General Public License
15             # along with Config::AST. If not, see .
16              
17             package Config::AST;
18              
19 19     19   559715 use strict;
  19         189  
  19         620  
20 19     19   94 use warnings;
  19         34  
  19         573  
21 19     19   86 use Carp;
  19         27  
  19         1021  
22 19     19   9305 use Text::Locus;
  19         97374  
  19         1001  
23 19     19   8304 use Config::AST::Node qw(:sort);
  19         52  
  19         2652  
24 19     19   8318 use Config::AST::Node::Section;
  19         47  
  19         892  
25 19     19   7535 use Config::AST::Node::Value;
  19         49  
  19         906  
26 19     19   10580 use Config::AST::Follow;
  19         43  
  19         608  
27 19     19   7446 use Config::AST::Root;
  19         48  
  19         530  
28 19     19   12058 use Data::Dumper;
  19         132078  
  19         44815  
29              
30             require Exporter;
31             our @ISA = qw(Exporter);
32             our %EXPORT_TAGS = ( 'sort' => [ qw(NO_SORT SORT_NATURAL SORT_PATH) ] );
33             our @EXPORT_OK = qw(NO_SORT SORT_NATURAL SORT_PATH);
34            
35             our $VERSION = "1.07";
36              
37             =head1 NAME
38              
39             Config::AST - abstract syntax tree for configuration files
40              
41             =head1 SYNOPSIS
42              
43             my $cfg = new Config::AST(%opts);
44             $cfg->parse() or die;
45             $cfg->commit() or die;
46              
47             if ($cfg->is_set('core', 'variable')) {
48             ...
49             }
50              
51             my $x = $cfg->get('file', 'locking');
52              
53             $cfg->set('file', 'locking', 'true');
54              
55             $cfg->unset('file', 'locking');
56              
57             =head1 DESCRIPTION
58              
59             This module aims to provide a generalized implementation of parse tree
60             for various configuration files. It does not implement parser for any existing
61             configuration file format. Instead, it provides an API that can be used by
62             parsers to build internal representation for the particular configuration file
63             format.
64              
65             See B module for an implementation of a parser based on
66             this module.
67              
68             A configuration file in general is supposed to consist of statements of two
69             kinds: simple statements and sections. A simple statement declares or sets
70             a configuration parameter. Examples of simple statements are:
71              
72             # Bind configuration file:
73             file "cache/named.root";
74              
75             # Apache configuration file:
76             ServerName example.com
77              
78             # Git configuration file:
79             logallrefupdates = true
80              
81             A section statement groups together a number of another statements. These
82             can be simple statements, as well as another sections. Examples of sections
83             are (with subordinate statements replaced with ellipsis):
84              
85             # Bind configuration file:
86             zone "." {
87             ...
88             };
89              
90             # Apache configuration file:
91            
92             ...
93            
94              
95             # Git configuration file:
96             [core]
97             ...
98              
99             The syntax of Git configuration file being one of the simplest, we will use
100             it in the discussion below to illustrate various concepts.
101              
102             The abstract syntax tree (AST) for a configuration file consists of nodes.
103             Each node represents a single statement and carries detailed information
104             about that statement, in particular:
105              
106             =over 4
107              
108             =item B
109              
110             Location of the statement in the configuration. It is represented by an
111             object of class B.
112              
113             =item order
114              
115             0-based number reflecting position of this node in the parent section
116             node.
117              
118             =item value
119              
120             For simple statements - the value of this statement.
121              
122             =item subtree
123              
124             For sections - the subtree below this section.
125              
126             =back
127              
128             The type of each node can be determined using the following node attributes:
129              
130             =over 4
131              
132             =item is_section
133              
134             True if node is a section node.
135              
136             =item is_value
137              
138             True if node is a simple statement.
139              
140             =back
141              
142             To retrieve a node, address it using its I, i.e. list of statement
143             names that lead to this node. For example, in this simple configuration file:
144              
145             [core]
146             filemode = true
147              
148             the path of the C statement is C.
149              
150             =head1 CONSTRUCTOR
151            
152             $cfg = new Config::AST(%opts);
153              
154             Creates new configuration parser object. Valid options are:
155              
156             =over 4
157              
158             =item B => I
159              
160             Sets debug verbosity level.
161              
162             =item B => B<0> | B<1>
163              
164             If B<1>, enables case-insensitive keyword matching. Default is B<0>,
165             i.e. the keywords are case-sensitive.
166              
167             =item B => \%hash
168              
169             Defines the I.
170            
171             =back
172              
173             =head3 Keyword lexicon
174              
175             The hash reference passed via the B keyword defines the keywords
176             and sections allowed within a configuration file. In a simplest case, a
177             keyword is described as
178              
179             name => 1
180              
181             This means that B is a valid keyword, but does not imply anything
182             about its properties. A more complex declaration is possible, in
183             which the value is a hash reference, containing one or more of the following
184             keywords:
185              
186             =over 4
187              
188             =item mandatory => 0 | 1
189              
190             Whether or not this setting is mandatory.
191              
192             =item default => I
193              
194             Default value for the setting. This value will be assigned if that particular
195             statement is not explicitly used in the configuration file. If I
196             is a CODE reference, it will be invoked as a method each time the value is
197             accessed.
198              
199             Default values must be pure Perl values (not the values that should appear
200             in the configuration file). They are not processed using the B
201             callbacks (see below).
202            
203             =item array => 0 | 1
204              
205             If B<1>, the value of the setting is an array. Each subsequent occurrence
206             of the statement appends its value to the end of the array.
207              
208             =item re => I
209              
210             Defines a regular expression which the value must match. If it does not,
211             a syntax error will be reported.
212              
213             =item select => I
214              
215             Reference to a method which will be called in order to decide whether to
216             apply this hash to a particular configuration setting. The method is
217             called as
218              
219             $self->$coderef($node, @path)
220              
221             where $node is the B object (use
222             B<$vref-Evalue>, to obtain the actual value), and B<@path> is its pathname.
223            
224             =item check => I
225              
226             Defines a method which will be called after parsing the statement in order to
227             verify its value. The I is called as
228              
229             $self->$coderef($valref, $prev_value, $locus)
230              
231             where B<$valref> is a reference to its value, and B<$prev_value> is the
232             value of the previous instance of this setting. The function must return
233             B, if the value is OK for that setting. In that case, it is allowed
234             to modify the value referenced by B<$valref>. If the value is erroneous,
235             the function must issue an appropriate error message using B<$cfg-Eerror>,
236             and return 0.
237            
238             =back
239              
240             In taint mode, any value that matched B expression or passed the B
241             function will be automatically untainted.
242            
243             To define a section, use the B
keyword, e.g.:
244              
245             core => {
246             section => {
247             pidfile => {
248             mandatory => 1
249             },
250             verbose => {
251             re => qr/^(?:on|off)/i
252             }
253             }
254             }
255              
256             This says that the section named B can have two variables: B,
257             which is mandatory, and B, whose value must be B, or B
258             (case-insensitive). E.g.:
259              
260             [core]
261             pidfile = /run/ast.pid
262             verbose = off
263              
264             To accept arbitrary keywords, use B<*>. For example, the following
265             declares B section, which must have the B setting
266             and is allowed to have any other settings as well.
267            
268             code => {
269             section => {
270             pidfile => { mandatory => 1 },
271             '*' => 1
272             }
273             }
274              
275             Everything said above applies to the B<'*'> as well. E.g. the following
276             example declares the B section, which must have the B
277             setting and is allowed to have I with arbitrary settings.
278              
279             code => {
280             section => {
281             pidfile = { mandatory => 1 },
282             '*' => {
283             section => {
284             '*' => 1
285             }
286             }
287             }
288             }
289              
290             The special entry
291              
292             '*' => '*'
293              
294             means "any settings and any subsections are allowed".
295              
296             =cut
297              
298             sub new {
299 22     22 0 10043 my $class = shift;
300 22         77 local %_ = @_;
301 22         83 my $self = bless { _order => 0 }, $class;
302 22         40 my $v;
303              
304 22   50     239 $self->{_debug} = delete $_{debug} || 0;
305 22   50     237 $self->{_root} = new Config::AST::Root(delete $_{ci} || 0);
306              
307 22 100       93 if (defined($v = delete $_{lexicon})) {
308 18         92 $self->lexicon($v);
309             }
310 22 50       107 croak "unrecognized parameters" if keys(%_);
311              
312 22         91 $self->reset;
313 22         79 return $self;
314             }
315              
316             =head2 $node = $cfg->root
317              
318             Returns the root node of the tree, initializing it if necessary.
319              
320             =cut
321              
322 520     520 1 1726 sub root { shift->{_root} }
323              
324             =head2 $s = $r->mangle_key($name)
325              
326             Converts the string I<$name> to a form suitable for lookups, in accordance
327             with the B parameter passed to the constructor.
328              
329             =cut
330              
331             sub mangle_key {
332 214     214 1 370 my ($self, $key) = @_;
333 214         342 return $self->root->mangle_key($key);
334             }
335              
336             =head2 $cfg->lexicon($hashref)
337              
338             Returns current lexicon. If B<$hashref> is supplied, installs it as a
339             new lexicon.
340              
341             =cut
342              
343             sub lexicon {
344 65     65 1 103 my $self = shift;
345 65 100       151 if (@_) {
346 18         32 my $lexicon = shift;
347 18 50       56 carp "too many arguments" if @_;
348 18 50       66 carp "lexicon must refer to a HASH" unless ref($lexicon) eq 'HASH';
349 18         103 $self->reset;
350 18         142 $self->_clone_lexicon($lexicon);
351             }
352 65         205 return $self->{_lexicon};
353             }
354              
355             sub _clone_lexicon {
356 18     18   53 my ($self, $source_lex) = @_;
357 18         30 my @stk;
358 18         46 $self->{_lexicon} = {};
359 18         74 push @stk, [ $source_lex, $self->{_lexicon}, \&mangle_key ];
360 18         80 while (my $elt = pop @stk) {
361 104         130 while (my ($k, $v) = each %{$elt->[0]}) {
  245         747  
362 141 100       238 if ($elt->[2]) {
363 85         96 $k = $self->${\$elt->[2]}($k);
  85         169  
364             }
365            
366 141         164 my $copy;
367 141 100       239 if (ref($v) eq 'HASH') {
368 86         103 $copy = {};
369 86 100 66     377 push @stk, [ $v, $copy,
370             (!$elt->[2] && $k eq 'section')
371             ? \&mangle_key : undef ];
372             } else {
373 55         66 $copy = $v;
374             }
375 141         297 $elt->[1]{$k} = $copy;
376             }
377             }
378             }
379              
380             =head2 $cfg->describe_keyword(@path)
381              
382             Returns a lexicon entry for the statement at I<@path>. If no such
383             statement is defined, returns undef.
384              
385             =cut
386              
387             sub describe_keyword {
388 7     7 1 215 my $self = shift;
389 7         15 my $lex = $self->lexicon;
390 7 50       14 return '*' unless $lex;
391 7         13 while (my $k = shift @_) {
392 19         32 $k = $self->mangle_key($k);
393 19 50 66     56 if (my $next = (ref($lex) eq 'HASH'
    100          
    50          
394             ? $lex->{$k} // $lex->{'*'}
395             : (($lex eq '*') ? $lex : undef))) {
396 19         23 $lex = $next;
397 19 100       35 if (ref($lex) eq 'HASH') {
    100          
398 12 100       19 if ($next = $lex->{section}) {
399 11 50       18 $lex = $next if @_;
400 11         82 next;
401             }
402             } elsif ($lex eq '*') {
403 2         6 next;
404             }
405 6         9 last;
406             } else {
407 0         0 return;
408             }
409             }
410 7 100       19 return if @_;
411 5         16 return $lex;
412             }
413              
414             =head1 PARSING
415              
416             This module provides a framework for parsing, but does not implement parsers
417             for any particular configuration formats. To implement a parser, the programmer
418             must write a class that inherits from B. This class should
419             implement the B method which, when called, will actually perform the
420             parsing and build the AST using methods described in section B
421             THE SYNTAX TREE> (see below).
422              
423             The caller must then perform the following operations
424              
425             =over 4
426              
427             =item B<1.> Create an instance of the derived class B<$cfg>.
428              
429             =item B<2.> Call the B<$cfg-Eparse> method.
430              
431             =item B<3.> On success, call the B<$cfg-Ecommit> method.
432              
433             =back
434            
435             =head2 $cfg->parse(...)
436              
437             Abstract method that is supposed to actually parse the configuration file
438             and build the parse tree from it. Derived classes must overload it.
439              
440             The must return true on success and false on failure. Eventual errors in
441             the configuration should be reported using B.
442              
443             =cut
444              
445             sub parse {
446 0     0 1 0 my ($self) = @_;
447 0         0 croak "call to abstract method"
448             }
449              
450             =head2 $cfg->commit([%hash])
451              
452             Must be called after B to finalize the parse tree. This function
453             applies default values on settings where such are defined.
454              
455             Optional arguments control what steps are performed.
456              
457             =over 4
458              
459             =item lint => 1
460              
461             Forse syntax checking. This can be necessary if new nodes were added to
462             the tree after parsing.
463              
464             =item lexicon => I<$hashref>
465              
466             Override the lexicon used for syntax checking and default value processing.
467              
468             =back
469              
470             Returns true on success.
471            
472             =cut
473              
474             sub commit {
475 23     23 1 232 my ($self, %opts) = @_;
476 23         49 my $lint = delete $opts{lint};
477 23   100     123 my $lexicon = delete $opts{lexicon} // $self->lexicon;
478 23 50       79 croak "unrecognized arguments" if keys(%opts);
479 23 100       104 if ($lexicon) {
480 19 100       65 $self->lint_subtree($lexicon, $self->tree) if $lint;
481 19         95 $self->fixup_tree($self->tree, $lexicon);
482             }
483 23         83 return $self->{_error_count} == 0;
484             }
485              
486             =head2 $cfg->error_count
487              
488             Returns total number of errors encountered during parsing.
489              
490             =cut
491              
492 0     0 1 0 sub error_count { shift->{_error_count} }
493              
494             =head2 $cfg->success
495              
496             Returns true if no errors were detected during parsing.
497              
498             =cut
499              
500 0     0 1 0 sub success { ! shift->error_count }
501              
502             # Auxiliary function used in commit and lint.
503             # Arguments:
504             # $section - A Config::AST::Node::Section to start fixup at
505             # $params - Lexicon.
506             # @path - Path to $section
507             sub fixup_tree {
508 54     54 0 153 my ($self, $section, $params, @path) = @_;
509              
510 54         85 while (my ($k, $d) = each %{$params}) {
  137         401  
511 83 100       226 next unless ref($d) eq 'HASH';
512              
513 51 100 100     165 if (exists($d->{default}) && !$section->has_key($k)) {
514 4         5 my $n;
515             my $dfl = ref($d->{default}) eq 'CODE'
516 1     1   1 ? sub { $self->${ \ $d->{default} } }
  1         18  
517 4 100       19 : $d->{default};
518 4 50       13 if (exists($d->{section})) {
519 0         0 $n = new Config::AST::Node::Section(
520             $self,
521             default => 1,
522             subtree => $dfl
523             );
524             } else {
525 4         31 $n = new Config::AST::Node::Value(
526             default => 1,
527             value => $dfl
528             );
529             }
530 4         12 $section->subtree($k => $n);
531             }
532            
533 51 100       105 if (exists($d->{section})) {
534 36 100       82 if ($k eq '*') {
535 6 100       8 if (keys(%{$section->subtree})) {
  6         16  
536 3         16 while (my ($name, $vref) = each %{$section->subtree}) {
  7         26  
537 4 100       22 if (my $sel = $d->{select}) {
    50          
538 2 50       6 if ($self->$sel($vref, @path, $name)) {
539 0         0 next;
540             }
541             } elsif ($vref->is_section) {
542             $self->fixup_tree($vref, $d->{section},
543 2         8 @path, $name);
544             }
545             }
546             } else {
547 3         10 my $node =
548             new Config::AST::Node::Section($self);
549 3         38 $self->fixup_tree($node, $d->{section}, @path, $k);
550 3 100       9 if ($node->keys > 0) {
551             # If the newly created node contains any subnodes
552             # after fixup, they were created because syntax
553             # contained mandatory variables with default values.
554             # Treat sections containing such variables as
555             # mandatory and report them.
556 1         3 my %h;
557 1         7 foreach my $p (map {
558 1         2 pop @{$_->[0]};
  1         2  
559 1         2 join(' ', (@path, $k, @{$_->[0]}))
  1         16  
560             } $node->flatten(sort => SORT_PATH)) {
561 1 50       5 unless ($h{$p}) {
562 1         8 $self->error("no section matches mandatory [$p]");
563 1         45 $self->{_error_count}++;
564 1         12 $h{$p} = 1;
565             }
566             }
567             }
568             }
569             } else {
570 30         41 my $node;
571            
572 30 100       78 unless ($node = $section->subtree($k)) {
573 9         50 $node = new Config::AST::Node::Section($self);
574             }
575 30 50 33     139 if ((!exists($d->{select})
576 0         0 || $self->${ \ $d->{select} }($node, @path, $k))) {
577 30         206 $self->fixup_tree($node, $d->{section}, @path, $k);
578             }
579 30 100       99 if ($node->keys > 0) {
580 21         52 $section->subtree($k => $node);
581             }
582             }
583             }
584              
585 51 100 100     219 if ($d->{mandatory} && !$section->has_key($k)) {
586             $self->error(exists($d->{section})
587 4 100       42 ? "mandatory section ["
588             . join(' ', @path, $k)
589             . "] not present"
590             : "mandatory variable \""
591             . join('.', @path, $k)
592             . "\" not set",
593             locus => $section->locus);
594 4         313 $self->{_error_count}++;
595             }
596             }
597             }
598              
599             =head2 $cfg->reset
600              
601             Destroys the parse tree and clears error count, thereby preparing the object
602             for parsing another file.
603              
604             =cut
605            
606             sub reset {
607 40     40 1 59 my $self = shift;
608 40         75 $self->{_error_count} = 0;
609 40 50       124 if ($self->root) {
610 40         104 $self->root->reset;
611             }
612             }
613              
614             =head1 METHODS
615              
616             =head2 $cfg->error($message)
617              
618             =head2 $cfg->error($message, locus => $loc)
619              
620             Prints the B<$message> on STDERR. If B is given, its value must
621             be a reference to a valid B(3) object. In that
622             case, the object will be formatted first, then followed by a ": " and the
623             B<$message>.
624            
625             =cut
626            
627             sub error {
628 0     0 1 0 my $self = shift;
629 0         0 my $err = shift;
630 0         0 local %_ = @_;
631 0 0       0 print STDERR "$_{locus}: " if $_{locus};
632 0         0 print STDERR "$err\n";
633             }
634              
635             =head2 $cfg->debug($lev, @msg)
636              
637             If B<$lev> is greater than or equal to the B value used when
638             creating B<$cfg>, outputs on standard error the strings from @msg,
639             separating them with a single space character.
640              
641             Otherwise, does nothing.
642              
643             =cut
644              
645             sub debug {
646 0     0 1 0 my $self = shift;
647 0         0 my $lev = shift;
648 0 0       0 return unless $self->{_debug} >= $lev;
649 0         0 $self->error("DEBUG: " . join(' ', @_));
650             }
651              
652             =head1 NODE RETRIEVAL
653              
654             A node is addressed by its path, i.e. a list of names of the configuration
655             sections leading to the statement plus the name of the statement itself.
656             For example, the statement:
657              
658             pidfile = /var/run/x.pid
659              
660             has the path
661              
662             ( 'pidfile' )
663              
664             The path of the B statement in section B, e.g.:
665              
666             [core]
667             pidfile = /var/run/x.pid
668              
669             is
670              
671             ( 'core', 'pidfile' )
672              
673             Similarly, the path of the B setting in the following configuration
674             file:
675              
676             [item foo]
677             file = bar
678            
679             is
680             ( 'item', 'foo', 'bar' )
681            
682             =head2 $node = $cfg->getnode(@path);
683              
684             Retrieves the AST node referred to by B<@path>. If no such node exists,
685             returns C.
686              
687             =cut
688            
689             sub getnode {
690 22     22 1 57 my $self = shift;
691              
692 22 50       37 return undef if $self->root->empty;
693 22         56 my $node = $self->root->tree;
694 22         56 for (@_) {
695 32 100       55 $node = $node->subtree($_)
696             or return undef;
697             }
698 19         44 return $node;
699             }
700              
701             =head2 $var = $cfg->get(@path);
702              
703             Returns the B(3) corresponding to the
704             configuration variable represented by its path, or C if the
705             variable is not set.
706              
707             =cut
708              
709             sub get {
710 5     5 1 41 my $self = shift;
711 5 50       17 croak "no variable to get" unless @_;
712 5 50       15 if (my $node = $self->getnode(@_)) {
713 5         13 return $node->value;
714             }
715             }
716              
717             =head2 $cfg->is_set(@path)
718              
719             Returns true if the configuration variable addressed by B<@path> is
720             set.
721            
722             =cut
723              
724             sub is_set {
725 3     3 1 20 my $self = shift;
726 3         20 return defined $self->getnode(@_);
727             }
728              
729             =head2 $cfg->is_section(@path)
730              
731             Returns true if the configuration section addressed by B<@path> is
732             defined.
733              
734             =cut
735              
736             sub is_section {
737 1     1 1 3 my $self = shift;
738 1         3 my $node = $self->getnode(@_);
739 1   33     7 return defined($node) && $node->is_section;
740             }
741              
742             =head2 $cfg->is_variable(@path)
743              
744             Returns true if the configuration setting addressed by B<@path>
745             is set and is a simple statement.
746              
747             =cut
748              
749             sub is_variable {
750 1     1 1 3 my $self = shift;
751 1         3 my $node = $self->getnode(@_);
752 1   33     20 return defined($node) && $node->is_value;
753             }
754              
755             =head2 $cfg->tree
756              
757             Returns the parse tree.
758              
759             =cut
760              
761 90     90 1 197 sub tree { shift->root->tree }
762              
763             =head2 $cfg->subtree(@path)
764              
765             Returns the configuration subtree associated with the statement indicated by
766             B<@path>.
767              
768             =cut
769              
770             sub subtree {
771 0     0 1 0 my $self = shift;
772 0         0 return $self->tree->subtree(@_);
773             }
774              
775             =head1 DIRECT ADDRESSING
776              
777             Direct addressing allows programmer to access configuration settings as if
778             they were methods of the configuration class. For example, to retrieve the
779             node at path
780              
781             qw(foo bar baz)
782              
783             one can write:
784              
785             $node = $cfg->foo->bar->baz
786              
787             This statement is equivalent to
788              
789             $node = $cfg->getnode(qw(foo bar baz))
790              
791             except that if the node in question does not exist, direct access returns
792             a I, and B returns C. Null node is a special node
793             representing a missing node. Its B method returns true and it can
794             be used in conditional context as a boolean value, e.g.:
795              
796             if (my $node = $cfg->foo->bar->baz) {
797             $val = $node->value;
798             }
799              
800             Direct addressing is enabled only if lexicon is provided (either during
801             creation of the object, or later, via the B method).
802              
803             Obviously, statements that have names coinciding with one of the methods of
804             the B class (or any of its subclasses) can't be used in direct
805             addressing. In other words, you can't have a top-level statement called
806             C and access it as
807              
808             $cfg->tree
809              
810             This statement will always refer to the method B of the B
811             class.
812              
813             Another possible problem when using direct access are keywords with dashes.
814             Currently a kludge is implemented to make it possible to access such
815             keywords: when looking for a matching keyword, double underscores compare
816             equal to a single dash. For example, to retrieve the C
817             node, use
818              
819             $cfg->files->temp__dir;
820              
821             =cut
822              
823             our $AUTOLOAD;
824             sub AUTOLOAD {
825 10     10   543 my $self = shift;
826 10         82 $AUTOLOAD =~ s/(?:(.*)::)?(.+)//;
827 10         42 my ($p, $m) = ($1, $2);
828 10 50 33     48 croak "Can't locate object method \"$m\" via package \"$p\""
829             if @_ || !$self->lexicon;
830 10         28 return Config::AST::Follow->new($self->tree, $self->lexicon)->${\$m};
  10         56  
831             }
832              
833             sub DESTROY {
834 21     21   2976 my $self = shift;
835 21 50       69 $self->root->reset if $self->root;
836             }
837              
838             =head1 CONSTRUCTING THE SYNTAX TREE
839              
840             The methods described in this section are intended for use by the parser
841             implementers. They should be called from the implementation of the B
842             method in order to construct the tree.
843            
844             =cut
845              
846             sub _section_lexicon {
847 63     63   115 my ($self, $kw, $name) = @_;
848              
849 63 50       199 if (defined($kw)) {
850 63 50       172 if (ref($kw) eq 'HASH') {
851 63         84 my $synt;
852 63 100       188 if (exists($kw->{$name})) {
    50          
853 28         51 $synt = $kw->{$name};
854             } elsif (exists($kw->{'*'})) {
855 35         49 $synt = $kw->{'*'};
856 35 100       82 if ($synt eq '*') {
857 33         94 return { '*' => '*' };
858             }
859             }
860 30 50 66     215 if (defined($synt)
      66        
861             && ref($synt) eq 'HASH'
862             && exists($synt->{section})) {
863 29         73 return $synt->{section};
864             }
865             }
866             }
867             return
868 1         2 }
869              
870 19     19   233 use constant TAINT => eval '${^TAINT}';
  19         65  
  19         1163  
871 19     19   139 use constant TESTS => TAINT && defined eval 'require Taint::Util';
  19         37  
  19         35221  
872              
873             =head2 $cfg->add_node($path, $node)
874              
875             Adds the node in the node corresponding to B<$path>. B<$path> can be
876             either a list of keyword names, or its string representation, where
877             names are separated by dots. I.e., the following two calls are equivalent:
878              
879             $cfg->add_node(qw(core pidfile), $node)
880            
881             $cfg->add_node('core.pidfile', $node)
882              
883             If the node already exists at B<$path>, new node is merged to it according
884             to the lexical rules. I.e., for scalar value, new node overwrites the old
885             one. For lists, it is appended to the list.
886              
887             =cut
888              
889             sub add_node {
890 48     48 1 121 my ($self, $path, $node) = @_;
891              
892 48 50       138 unless (ref($path) eq 'ARRAY') {
893 48         219 $path = [ split(/\./, $path) ]
894             }
895              
896 48   100     203 my $kw = $self->{_lexicon} // { '*' => '*' };
897 48         201 my $tree = $self->tree;
898 48         74 my $pn = $#{$path};
  48         89  
899 48         65 my $name;
900 48         109 my $locus = $node->locus;
901 48         804 for (my $i = 0; $i < $pn; $i++) {
902 63         80 $name = $self->mangle_key(${$path}[$i]);
  63         190  
903            
904 63 50       175 unless ($tree->is_section) {
905 0         0 $self->error(join('.', @{$path}[0..$i]) . ": not a section");
  0         0  
906 0         0 $self->{_error_count}++;
907 0         0 return;
908             }
909              
910 63         177 $kw = $self->_section_lexicon($kw, $name);
911 63 100       150 unless ($kw) {
912 1         3 $self->error(join('.', @{$path}[0..$i]) . ": unknown section");
  1         13  
913 1         25 $self->{_error_count}++;
914 1         5 return;
915             }
916              
917 62 100       143 if (my $subtree = $tree->subtree($name)) {
918 28         65 $tree = $subtree;
919             } else {
920             $tree = $tree->subtree(
921             $name => new Config::AST::Node::Section(
922             $self,
923 34         136 order => $self->{_order}++,
924             locus => $locus->clone)
925             );
926             }
927             }
928              
929 47         76 $name = $self->mangle_key(${$path}[-1]);
  47         144  
930              
931 47   100     202 my $x = $kw->{$name} // $kw->{'*'};
932 47 100       137 if (!defined($x)) {
933 1         6 $self->error("keyword \"$name\" is unknown", locus => $locus);
934 1         35 $self->{_error_count}++;
935 1         10 return;
936             }
937              
938 46 100       156 if ($node->is_section) {
939 2 100       4 if ($tree->has_key($name)) {
940 1         3 $tree->locus->union($locus);
941 1         69 $tree->subtree($name)->merge($node);
942             } else {
943 1         10 $tree->subtree($name => $node);
944             }
945 2         5 return $node;
946             }
947              
948 44         110 my $v = $node->value;
949              
950 44 100       260 if (ref($x) eq 'HASH') {
951 9 100       37 if (exists($x->{section})) {
952 1         2 $self->error('"'.join('.', @{$path})."\" must be a section",
  1         8  
953             locus => $locus);
954 1         29 $self->{_error_count}++;
955 1         10 return;
956             }
957              
958 8         16 my $errstr;
959             my $prev_val;
960 8 100       36 if ($tree->has_key($name)) {
961             # FIXME: is_value?
962 2         5 $prev_val = $tree->subtree($name)->value;
963             }
964 8         14 my $nchecks; # Number of checks passed
965 8 50       31 if (exists($x->{re})) {
966 0 0       0 if ($v !~ /$x->{re}/) {
967 0         0 $self->error("invalid value for $name",
968             locus => $locus);
969 0         0 $self->{_error_count}++;
970 0         0 return;
971             }
972 0         0 $nchecks++;
973             }
974              
975 8 100       27 if (my $ck = $x->{check}) {
976 1 50       5 unless ($self->$ck(\$v, $prev_val, $locus)) {
977 1         49 $self->{_error_count}++;
978 1         14 return;
979             }
980 0         0 $nchecks++;
981             }
982 7 50 50     29 if ($nchecks && TESTS) {
983 0         0 Taint::Util::untaint($v);
984             }
985              
986 7 100       30 if ($x->{array}) {
987 3 100       7 if (!defined($prev_val)) {
988 1         3 $v = [ $v ];
989             } else {
990 2         3 $v = [ @{$prev_val}, $v ];
  2         4  
991             }
992             }
993             }
994              
995 42         121 $tree->locus->union($locus->clone);
996              
997 42         3538 my $newnode;
998 42 100       108 if ($newnode = $tree->subtree($name)) {
999 3         8 $newnode->locus->union($locus);
1000             } else {
1001 39         110 $newnode = $tree->subtree($name => $node);
1002             }
1003 42         313 $newnode->order($self->{order}++);
1004 42         113 $newnode->value($v);
1005 42         237 return $newnode;
1006             }
1007              
1008             =head2 $cfg->add_value($path, $value, $locus)
1009              
1010             Adds a statement node with the given B<$value> and B<$locus> in position,
1011             indicated by $path.
1012              
1013             If the setting already exists at B<$path>, the new value is merged to it
1014             according to the lexical rules. I.e., for scalars, B<$value> overwrites
1015             prior setting. For lists, it is appended to the list.
1016              
1017             =cut
1018            
1019             sub add_value {
1020 46     46 1 2262 my ($self, $path, $value, $locus) = @_;
1021 46         360 $self->add_node($path, new Config::AST::Node::Value(value => $value,
1022             locus => $locus));
1023             }
1024              
1025             =head2 $cfg->set(@path, $value)
1026              
1027             Sets the configuration variable B<@path> to B<$value>.
1028              
1029             No syntax checking is performed. To enforce syntax checking use
1030             B.
1031              
1032             =cut
1033              
1034             sub set {
1035 1     1 1 4 my $self = shift;
1036 1         3 my $node = $self->tree;
1037            
1038 1         7 while ($#_ > 1) {
1039 1 50       4 croak "not a section" unless $node->is_section;
1040 1         3 my $arg = shift;
1041 1 50       4 if (my $n = $node->subtree($arg)) {
1042 1         14 $node = $n;
1043             } else {
1044 0         0 $node = $node->subtree(
1045             $arg => new Config::AST::Node::Section($self)
1046             );
1047             }
1048             }
1049            
1050             my $v = $node->subtree($_[0]) ||
1051             $node->subtree($_[0] => new Config::AST::Node::Value(
1052 1   33     6 order => $self->{_order}++
1053             ));
1054            
1055 1         4 $v->value($_[1]);
1056 1         7 $v->default(0);
1057 1         2 return $v;
1058             }
1059              
1060             =head2 cfg->unset(@path)
1061              
1062             Unsets the configuration variable.
1063            
1064             =cut
1065              
1066             sub unset {
1067 1     1 1 2 my $self = shift;
1068              
1069 1 50       3 return if $self->root->empty;
1070 1         3 my $node = $self->root->tree;
1071 1         2 my @path;
1072            
1073 1         3 for (@_) {
1074 2 100 66     6 return unless $node->is_section && $node->has_key($_);
1075 1         4 push @path, [ $node, $_ ];
1076 1         2 $node = $node->subtree($_);
1077             }
1078              
1079 0         0 while (1) {
1080 0         0 my $loc = pop @path;
1081 0         0 $loc->[0]->delete($loc->[1]);
1082 0 0       0 last unless ($loc->[0]->keys == 0);
1083             }
1084             }
1085              
1086             =head1 AUXILIARY METHODS
1087              
1088             =head2 @array = $cfg->names_of(@path)
1089              
1090             If B<@path> refers to an existing configuration section, returns a list
1091             of names of variables and subsections defined within that section. Otherwise,
1092             returns empty list. For example, if you have
1093              
1094             [item foo]
1095             x = 1
1096             [item bar]
1097             x = 1
1098             [item baz]
1099             y = 2
1100              
1101             the call
1102              
1103             $cfg->names_of('item')
1104              
1105             will return
1106              
1107             ( 'foo', 'bar', 'baz' )
1108            
1109             =cut
1110              
1111             sub names_of {
1112 1     1 1 3 my $self = shift;
1113 1         2 my $node = $self->getnode(@_);
1114 1 50 33     5 return () unless defined($node) && $node->is_section;
1115 1         3 return $node->keys;
1116             }
1117              
1118             =head2 @array = $cfg->flatten()
1119              
1120             =head2 @array = $cfg->flatten(sort => $sort)
1121              
1122             Returns a I representation of the configuration, as a
1123             list of pairs B<[ $path, $value ]>, where B<$path> is a reference
1124             to the variable pathname, and B<$value> is a
1125             B object.
1126              
1127             The I<$sort> argument controls the ordering of the entries in the returned
1128             B<@array>. It is either a code reference suitable to pass to the Perl B
1129             function, or one of the following constants:
1130              
1131             =over 4
1132              
1133             =item NO_SORT
1134              
1135             Don't sort the array. Statements will be placed in an apparently random
1136             order.
1137              
1138             =item SORT_NATURAL
1139              
1140             Preserve relative positions of the statements. Entries in the array will
1141             be in the same order as they appeared in the configuration file. This is
1142             the default.
1143              
1144             =item SORT_PATH
1145              
1146             Sort by pathname.
1147              
1148             =back
1149              
1150             These constants are not exported by default. You can either import the
1151             ones you need, or use the B<:sort> keyword to import them all, e.g.:
1152              
1153             use Config::AST qw(:sort);
1154             @array = $cfg->flatten(sort => SORT_PATH);
1155            
1156             =cut
1157              
1158             sub flatten {
1159 0     0 1 0 my $self = shift;
1160 0         0 $self->tree->flatten(@_);
1161             }
1162              
1163             =head2 $h = $cfg->as_hash
1164              
1165             =head2 $h = $cfg->as_hash($map)
1166              
1167             Returns parse tree converted to a hash reference. If B<$map> is supplied,
1168             it must be a reference to a function. For each I<$key>/I<$value>
1169             pair, this function will be called as:
1170              
1171             ($newkey, $newvalue) = &{$map}($what, $key, $value)
1172              
1173             where B<$what> is C
or C, depending on the type of the
1174             hash entry being processed. Upon successful return, B<$newvalue> will be
1175             inserted in the hash slot for the key B<$newkey>.
1176              
1177             If B<$what> is C
, B<$value> is always a reference to an empty
1178             hash (since the parse tree is traversed in pre-order fashion). In that
1179             case, the B<$map> function is supposed to do whatever initialization that
1180             is necessary for the new subtree and return as B<$newvalue> either B<$value>
1181             itself, or a reference to a hash available inside the B<$value>. For
1182             example:
1183              
1184             sub map {
1185             my ($what, $name, $val) = @_;
1186             if ($name eq 'section') {
1187             $val->{section} = {};
1188             $val = $val->{section};
1189             }
1190             ($name, $val);
1191             }
1192            
1193             =cut
1194              
1195             sub as_hash {
1196 0     0 1 0 my $self = shift;
1197 0         0 $self->tree->as_hash(@_);
1198             }
1199              
1200             =head2 $cfg->canonical(%args)
1201              
1202             Returns the canonical string representation of the configuration tree.
1203             For details, please refer to the documentation of this method in class
1204             B.
1205            
1206             =cut
1207              
1208             sub canonical {
1209 9     9 1 236 my $self = shift;
1210 9         35 $self->tree->canonical(@_);
1211             }
1212            
1213              
1214             sub lint_node {
1215 13     13 0 25 my ($self, $lexicon, $node, @path) = @_;
1216              
1217 13 100       29 $lexicon = {} unless ref($lexicon) eq 'HASH';
1218 13 100       72 if (exists($lexicon->{section})) {
1219 7 50       13 return unless $node->is_section;
1220             } else {
1221 6 100       21 return if $node->is_section;
1222             }
1223              
1224 12 100 66     31 if (exists($lexicon->{select}) &&
1225 2         6 !$self->${ \ $lexicon->{select} }($node, @path)) {
1226 2         27 return;
1227             }
1228              
1229 10 100       17 if ($node->is_section) {
1230 5         29 $self->lint_subtree($lexicon->{section}, $node, @path);
1231             } else {
1232 5         9 my $val = $node->value;
1233 5         12 my %opts = ( locus => $node->locus );
1234            
1235 5 50       93 if (ref($val) eq 'ARRAY') {
1236 0 0       0 if ($lexicon->{array}) {
1237 0         0 my @ar;
1238 0         0 foreach my $v (@$val) {
1239 0 0       0 if (exists($lexicon->{re})) {
1240 0 0       0 if ($v !~ /$lexicon->{re}/) {
1241 0         0 $self->error("invalid value for $path[-1]", %opts);
1242 0         0 $self->{_error_count}++;
1243 0         0 next;
1244             }
1245             }
1246 0 0       0 if (my $ck = $lexicon->{check}) {
1247 0 0       0 unless ($self->$ck(\$v, @ar ? $ar[-1] : undef,
    0          
1248             $node->locus)) {
1249 0         0 $self->{_error_count}++;
1250 0         0 next;
1251             }
1252             }
1253 0         0 push @ar, $v;
1254             }
1255 0         0 $node->value(\@ar);
1256 0         0 return;
1257             } else {
1258 0         0 $val = pop(@$val);
1259             }
1260             }
1261            
1262 5 50       10 if (exists($lexicon->{re})) {
1263 0 0       0 if ($val !~ /$lexicon->{re}/) {
1264 0         0 $self->error("invalid value for $path[-1]", %opts);
1265 0         0 $self->{_error_count}++;
1266 0         0 return;
1267             }
1268             }
1269              
1270 5 50       11 if (my $ck = $lexicon->{check}) {
1271 0 0       0 unless ($self->$ck(\$val, undef, $node->locus)) {
1272 0         0 $self->{_error_count}++;
1273 0         0 return;
1274             }
1275             }
1276              
1277 5         9 $node->value($val);
1278             }
1279             }
1280              
1281             sub lint_subtree {
1282 8     8 0 20 my ($self, $lexicon, $node, @path) = @_;
1283            
1284 8         12 while (my ($var, $value) = each %{$node->subtree}) {
  23         44  
1285 15 100       37 if (exists($lexicon->{$var})) {
    100          
    100          
1286 10         30 $self->lint_node($lexicon->{$var}, $value, @path, $var);
1287             } elsif (exists($lexicon->{'*'})) {
1288 3         12 $self->lint_node($lexicon->{'*'}, $value, @path, $var);
1289             } elsif ($value->is_section) {
1290 1         2 next;
1291             } else {
1292 1         7 $self->error("keyword \"$var\" is unknown",
1293             locus => $value->locus);
1294 1         55 $self->{_error_count}++;
1295             }
1296             }
1297             }
1298              
1299             =head2 $cfg->lint([\%lex])
1300              
1301             Checks the syntax according to the keyword lexicon B<%lex> (or
1302             B<$cfg-Elexicon>, if called without arguments). On success,
1303             applies eventual default values and returns true. On errors, reports
1304             them using B and returns false.
1305              
1306             This method provides a way to delay syntax checking for a later time,
1307             which is useful, e.g. if some parts of the parser are loaded as modules
1308             after calling B.
1309            
1310             =cut
1311              
1312             sub lint {
1313 3     3 1 501 my ($self, $lexicon) = @_;
1314 3         43 return $self->commit(lint => 1, lexicon => $lexicon);
1315             }
1316              
1317             =head1 SEE ALSO
1318              
1319             L.
1320              
1321             L.
1322              
1323             =cut
1324              
1325              
1326             1;