summaryrefslogtreecommitdiffabout
authorSergey Poznyakoff <gray@gnu.org.ua>2017-12-02 16:24:38 (GMT)
committer Sergey Poznyakoff <gray@gnu.org.ua>2017-12-03 11:42:13 (GMT)
commitceb4bd03d48d161548e00f1db170b376583894a8 (patch) (unidiff)
tree86635a6469d44aff6aa443404363a355f5c0a394
downloadconfig-ast-ceb4bd03d48d161548e00f1db170b376583894a8.tar.gz
config-ast-ceb4bd03d48d161548e00f1db170b376583894a8.tar.bz2
Initial commit
Diffstat (more/less context) (ignore whitespace changes)
-rw-r--r--.gitignore11
-rw-r--r--lib/Config/Tree.pm893
-rw-r--r--lib/Config/Tree/Locus.pm288
-rw-r--r--lib/Config/Tree/Node.pm161
-rw-r--r--lib/Config/Tree/Node/Section.pm41
-rw-r--r--lib/Config/Tree/Node/Value.pm34
-rw-r--r--t/TestConfig.pm103
-rw-r--r--t/conf01.t18
-rw-r--r--t/conf02.t30
-rw-r--r--t/conf03.t29
-rw-r--r--t/conf04.t37
-rw-r--r--t/conf05.t30
-rw-r--r--t/conf06.t56
-rw-r--r--t/conf07.t56
-rw-r--r--t/conf08.t34
-rw-r--r--t/conf09.t27
-rw-r--r--t/conf10.t23
-rw-r--r--t/conf11.t17
-rw-r--r--t/locus.t50
19 files changed, 1938 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..cd17285
--- a/dev/null
+++ b/.gitignore
@@ -0,0 +1,11 @@
1.emacs*
2*~
3*.bak
4/MYMETA.json
5/MYMETA.yml
6Makefile
7/*.tar.gz
8/tmp
9/blib
10/pm_to_blib
11/inc
diff --git a/lib/Config/Tree.pm b/lib/Config/Tree.pm
new file mode 100644
index 0000000..39e0de9
--- a/dev/null
+++ b/lib/Config/Tree.pm
@@ -0,0 +1,893 @@
1# Configuration parser for Sourceyard -*- perl -*-
2# Copyright (C) 2017 Sergey Poznyakoff <gray@gnu.org>
3#
4# This program 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# This program 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 this program. If not, see <http://www.gnu.org/licenses/>.
16
17package Config::Tree;
18
19use strict;
20use warnings;
21use Carp;
22use Config::Tree::Locus;
23use Config::Tree::Node::Section;
24use Config::Tree::Node::Value;
25use Data::Dumper;
26
27require Exporter;
28our @ISA = qw(Exporter);
29our %EXPORT_TAGS = ( 'sort' => [ qw(NO_SORT SORT_NATURAL SORT_PATH) ] );
30our @EXPORT_OK = qw(NO_SORT SORT_NATURAL SORT_PATH);
31
32our $VERSION = "1.00";
33
34=head1 NAME
35
36Config::Tree - generalized configuration file parser
37
38=head1 SYNOPSIS
39
40 my $cfg = new Config::Tree($filename, %opts);
41 $cfg->parse() or die;
42
43 if ($cfg->is_set('core', 'variable')) {
44 ...
45 }
46
47 my $x = $cfg->get('file', 'locking');
48
49 $cfg->set('file', 'locking', 'true');
50
51 $cfg->unset('file', 'locking');
52
53=head1 DESCRIPTION
54
55Configuration file handling. Features:
56
57=over 4
58
59=item 1
60
61Handles I<git>-format configuration files.
62
63=item 2
64
65Table-driven syntax checking and validation.
66
67=item 3
68
69Optional caching facility allows for faster loading. This is especially
70useful for big configurations.
71
72=item 4
73
74Built-in B<lint> facility.
75
76=item 5
77
78Location tracking.
79
80=item 6
81
82Dump facility. The parsed configuration can be output to the given file
83handler in a standardized form.
84
85=item 7
86
87Both random access and iteration over all settings is possible.
88
89=back
90
91=head1 METHODS
92
93=head2 $cfg = new Config::Tree($filename, %opts);
94
95Creates new configuration object for file B<$filename>. Valid
96options are:
97
98=over 4
99
100=item B<debug> => I<NUM>
101
102Sets debug verbosity level.
103
104=item B<ci> => B<0> | B<1>
105
106If B<1>, enables case-insensitive keyword matching. Default is B<0>,
107i.e. the keywords are case-sensitive.
108
109=item B<parameters> => \%hash
110
111Defines the syntax table. See below for a description of B<%hash>.
112
113=back
114
115=head3 Syntax hash
116
117The hash passed via the B<parameters> keyword defines the keywords and
118sections allowed within a configuration file. In a simplest case, a
119keyword is described as
120
121 name => 1
122
123This means that B<name> is a valid keyword, but does not imply anything
124more about it or its value. A more complex declaration is possible, in
125which the value is a hash reference, containing one or more of the following
126keywords:
127
128=over 4
129
130=item mandatory => 0 | 1
131
132Whether or not this setting is mandatory.
133
134=item default => I<VALUE>
135
136Default value for the setting. It is assigned when entire configuration file
137has been parsed, if that particular setting did not occur in it. If I<VALUE>
138is a code, it will be invoked as a method each time the value is accessed.
139
140Default values must be pure Perl values (not the values that should appear
141in the configuration file). They are not processed using the B<check>
142callbacks.
143
144=item array => 0 | 1
145
146If B<1>, the value of the setting is an array. Each subsequent occurrence
147of the statement appends its value to the end of the array.
148
149=item re => I<regexp>
150
151Defines a regular expression to which must be matched by the value of the
152setting, otherwise a syntax error will be reported.
153
154=item select => I<coderef>
155
156Points to a function to be called to decide whether to apply this hash to
157a particular configuration setting. The function is called as
158
159 $self->$coderef($node, @path)
160
161where $node is the B<Config::Tree::Node::Value> object (use
162B<$vref-E<gt>value>, to obtain the actual value), and B<@path> is its patname.
163
164=item check => I<coderef>
165
166Defines a code which will be called after parsing the statement in order to
167verify its value. The I<coderef> is called as
168
169 $self->$coderef($valref, $prev_value, $locus)
170
171where B<$valref> is a reference to its value, and B<$prev_value> is the
172value of the previous instance of this setting. The function must return non-0
173if the value is OK for that setting. In that case, it is allowed to modify
174the value, referenced by B<$valref>. If the value is erroneous, the function
175must issue an appropriate error message using B<$cfg-E<gt>error>, and return 0.
176
177=back
178
179To define a section, use the B<section> keyword, e.g.:
180
181 core => {
182 section => {
183 pidfile => {
184 mandatory => 1
185 },
186 verbose => {
187 re => qr/^(?:on|off)/i
188 }
189 }
190 }
191
192This says that a section B<[core]> can have two variables: B<pidfile>, which
193is mandatory, and B<verbose>, whose value must be B<on>, or B<off> (case-
194insensitive).
195
196To allow for arbitrary keywords, use B<*>. For example, the following
197declares the B<[code]> section, which must have the B<pidfile> setting
198and is allowed to have any other settings as well.
199
200 code => {
201 section => {
202 pidfile => { mandatory => 1 },
203 '*' => 1
204 }
205 }
206
207Everything said above applies to the B<'*'> as well. E.g. the following
208example declares the B<[code]> section, which must have the B<pidfile>
209setting and is allowed to have I<subsections> with arbitrary settings.
210
211 code => {
212 section => {
213 pidfile = { mandatory => 1 },
214 '*' => {
215 section => {
216 '*' => 1
217 }
218 }
219 }
220 }
221
222The special entry
223
224 '*' => '*'
225
226means "any settings and any subsections".
227
228=cut
229
230sub new {
231 my $class = shift;
232 local %_ = @_;
233 my $self = bless { _order => 0 }, $class;
234 my $v;
235 my $err;
236
237 $self->{_debug} = delete $_{debug} || 0;
238 $self->{_ci} = delete $_{ci} || 0;
239
240 if (defined($v = delete $_{parameters})) {
241 if (ref($v) eq 'HASH') {
242 $self->{_parameters} = $v;
243 } else {
244 carp "parameters must refer to a HASH";
245 ++$err;
246 }
247 }
248
249 if (keys(%_)) {
250 foreach my $k (keys %_) {
251 carp "unknown parameter $k"
252 }
253 ++$err;
254 }
255 croak "can't create configuration instance" if $err;
256 $self->reset;
257 return $self;
258}
259
260sub reset {
261 my $self = shift;
262 $self->{_error_count} = 0;
263 delete $self->{_conf};
264}
265
266=head2 $cfg->error($message)
267
268=head2 $cfg->error($message, locus => $loc)
269
270Prints the B<$message> on STDERR. If B<locus> is given, its value must
271be a reference to a valid B<Config::Tree::Locus>(3) object. In that
272case, the object will be formatted first, then followed by a ": " and the
273B<$message>.
274
275=cut
276
277sub error {
278 my $self = shift;
279 my $err = shift;
280 local %_ = @_;
281 print STDERR "$_{locus}: " if exists $_{locus};
282 print STDERR "$err\n";
283}
284
285=head2 $cfg->debug($lev, @msg)
286
287If B<$lev> is greater than or equal to the B<debug> value used when
288creating B<$cfg>, outputs on standard error the strings from @msg,
289separating them with a single space character.
290
291Otherwise, does nothing.
292
293=cut
294
295sub debug {
296 my $self = shift;
297 my $lev = shift;
298 return unless $self->{_debug} >= $lev;
299 $self->error("DEBUG: " . join(' ', @_));
300}
301
302sub _fixup {
303 my ($self, $section, $params, @path) = @_;
304
305 while (my ($k, $d) = each %{$params}) {
306 next unless ref($d) eq 'HASH';
307
308 if (exists($d->{default}) && !$section->has_key($k)) {
309 my $n;
310 my $dfl = ref($d->{default}) eq 'CODE'
311 ? sub { $self->${ \ $d->{default} } }
312 : $d->{default};
313 if (exists($d->{section})) {
314 $n = new Config::Tree::Node::Section(
315 default => 1,
316 subtree => $dfl
317 );
318 } else {
319 $n = new Config::Tree::Node::Value(
320 default => 1,
321 value => $dfl
322 );
323 }
324 $section->subtree($k => $n);
325 }
326
327 if (exists($d->{section})) {
328 if ($k eq '*') {
329 while (my ($name, $vref) = each %{$section->subtree}) {
330 if (my $sel = $d->{select}) {
331 if ($self->$sel($vref, @path, $name)) {
332 next;
333 }
334 } elsif ($vref->is_section) {
335 $self->_fixup($vref, $d->{section}, @path, $name);
336 }
337 }
338 } else {
339 my $node;
340
341 unless ($node = $section->subtree($k)) {
342 $node = new Config::Tree::Node::Section;
343 }
344 if ((!exists($d->{select})
345 || $self->${ \ $d->{select} }($node, @path, $k))) {
346 $self->_fixup($node, $d->{section}, @path, $k);
347 }
348 if ($node->keys > 0) {
349 $section->subtree($k => $node);
350 }
351 }
352 }
353
354 if ($d->{mandatory} && !$section->has_key($k)) {
355 $self->error(exists($d->{section})
356 ? "mandatory section ["
357 . join(' ', @path, $k)
358 . "] not present"
359 : "mandatory variable \""
360 . join('.', @path, $k)
361 . "\" not set",
362 locus => $section->locus);
363 $self->{_error_count}++;
364 }
365 }
366}
367
368=head2 $cfg->parse()
369
370Parses the configuration file and stores the data in the object. Returns
371true on success and false on failure. Eventual errors in the configuration
372are reported using B<error>.
373
374=cut
375
376sub parse {
377 my ($self) = @_;
378 croak "call to abstract method"
379}
380
381sub getnode {
382 my $self = shift;
383
384 my $node = $self->{_conf} or return undef;
385 for (@_) {
386 $node = $node->subtree($self->{_ci} ? lc($_) : $_)
387 or return undef;
388 }
389 return $node;
390}
391
392=head2 $var = $cfg->get(@path);
393
394Returns the B<Config::Tree::Node::Value>(3) corresponding to the
395configuration variable represented by its I<path>, or B<undef> if the
396variable is not set. The path is a list of configuration variables leading
397to the value in question. For example, the following statement:
398
399 pidfile = /var/run/x.pid
400
401has the path
402
403 ( 'pidfile' )
404
405The path of the B<pidfile> statement in section B<core>, e.g.:
406
407 [core]
408 pidfile = /var/run/x.pid
409
410is
411
412 ( 'core', 'pidfile' )
413
414Similarly, the path of the B<file> setting in the following configuration
415file:
416
417 [item foo]
418 file = bar
419
420is
421 ( 'item', 'foo', 'bar' )
422
423=cut
424
425sub get {
426 my $self = shift;
427 croak "no variable to get" unless @_;
428 my $node = $self->getnode(@_) or return undef;
429 my $value = $node->value;
430 if (ref($value) eq 'ARRAY') {
431 return wantarray ? @$value : $value;
432 } elsif (ref($value) eq 'HASH') {
433 return wantarray ? %$value : $value;
434 }
435 return $value;
436}
437
438=head2 $cfg->is_set(@path)
439
440Returns true if the configuration variable addressed by B<@path> is
441set.
442
443=cut
444
445sub is_set {
446 my $self = shift;
447 return defined $self->getnode(@_);
448}
449
450=head2 $cfg->is_section(@path)
451
452Returns true if the configuration section addressed by B<@path> is
453set.
454
455=cut
456
457sub is_section {
458 my $self = shift;
459 my $node = $self->getnode(@_);
460 return defined($node) && $node->is_section;
461}
462
463=head2 $cfg->is_variable(@path)
464
465Returns true if the configuration setting addressed by B<@path>
466is set and is a variable.
467
468=cut
469
470sub is_variable {
471 my $self = shift;
472 my $node = $self->getnode(@_);
473 return defined($node) && $node->is_value;
474}
475
476sub tree {
477 my $self = shift;
478 return $self->{_conf} //= new Config::Tree::Node::Section(locus => new Config::Tree::Locus);
479}
480
481sub _get_section_synt {
482 my ($self, $kw, $name) = @_;
483
484 if (defined($kw)) {
485 if (ref($kw) eq 'HASH') {
486 my $synt;
487 if (exists($kw->{$name})) {
488 $synt = $kw->{$name};
489 } elsif (exists($kw->{'*'})) {
490 $synt = $kw->{'*'};
491 if ($synt eq '*') {
492 return { '*' => '*' };
493 }
494 }
495 if (defined($synt)
496 && ref($synt) eq 'HASH'
497 && exists($synt->{section})) {
498 return $synt->{section};
499 }
500 }
501 }
502 return
503}
504
505=head2 add_node($node, $path)
506
507=cut
508
509sub add_node {
510 my ($self, $path, $v, $locus) = @_;
511
512 unless (ref($path) eq 'ARRAY') {
513 $path = [ split(/\./, $path) ]
514 }
515
516 my $kw = $self->{_parameters} // { '*' => '*' };
517 my $node = $self->tree;
518 my $pn = $#{$path};
519 my $name;
520 for (my $i = 0; $i < $pn; $i++) {
521 $name = ${$path}[$i];
522
523 unless ($node->is_section) {
524 $self->error(join('.', @{$path}[0..$i]) . ": not a section");
525 $self->{_error_count}++;
526 return;
527 }
528
529 $kw = $self->_get_section_synt($kw, $name);
530 unless ($kw) {
531 $self->error(join('.', @{$path}[0..$i]) . ": unknown section");
532 $self->{_error_count}++;
533 return;
534 }
535
536 if (my $subtree = $node->subtree($name)) {
537 $node = $subtree;
538 } else {
539 $node = $node->subtree(
540 $name => new Config::Tree::Node::Section(
541 order => $self->{_order}++,
542 locus => $locus->clone)
543 );
544 }
545 }
546
547 $name = ${$path}[-1];
548
549 my $x = $kw->{$name} // $kw->{'*'};
550 if (!defined($x)) {
551 $self->error("keyword \"$name\" is unknown", locus => $locus);
552 $self->{_error_count}++;
553 return;
554 }
555
556 if (ref($x) eq 'HASH') {
557 my $errstr;
558 my $prev_val;
559 if ($node->has_key($name)) {
560 # FIXME: is_value?
561 $prev_val = $node->subtree($name)->value;
562 }
563 if (exists($x->{re})) {
564 if ($v !~ /$x->{re}/) {
565 $self->error("invalid value for $name",
566 locus => $locus);
567 $self->{_error_count}++;
568 return;
569 }
570 }
571
572 if (my $ck = $x->{check}) {
573 unless ($self->$ck(\$v, $prev_val, $locus)) {
574 $self->{_error_count}++;
575 return;
576 }
577 }
578
579 if ($x->{array}) {
580 if (!defined($prev_val)) {
581 $v = [ $v ];
582 } else {
583 $v = [ @{$prev_val}, $v ];
584 }
585 }
586 }
587
588 $node->locus->add($locus->clone);
589
590 my $newnode;
591 if ($newnode = $node->subtree($name)) {
592 $newnode->locus->add($locus);
593 } else {
594 $newnode = $node->subtree(
595 $name => new Config::Tree::Node::Value(locus => $locus)
596 );
597 }
598 $newnode->order($self->{order}++);
599 $newnode->value($v);
600 return $newnode;
601}
602
603sub commit {
604 my ($self) = @_;
605 # FIXME
606 $self->_fixup($self->tree, $self->{_parameters})
607 if exists $self->{_parameters};
608 return $self->{_error_count} == 0;
609}
610
611=head2 $cfg->set(@path, $value)
612
613Sets the configuration variable B<@path> to B<$value>.
614
615=cut
616
617sub set {
618 my $self = shift;
619 my $node = $self->tree;
620
621 while ($#_ > 1) {
622 croak "not a section" unless $node->is_section;
623 my $arg = shift;
624 if (my $n = $node->subtree($arg)) {
625 $node = $n;
626 } else {
627 $node = $node->subtree(
628 $arg => new Config::Tree::Node::Section
629 );
630 }
631 }
632
633 my $v = $node->subtree($_[0]) ||
634 $node->subtree($_[0] => new Config::Tree::Node::Value(
635 order => $self->{_order}++
636 ));
637
638 $v->value($_[1]);
639 $v->default(0);
640 return $v;
641}
642
643=head2 cfg->unset(@path)
644
645Unsets the configuration variable.
646
647=cut
648
649sub unset {
650 my $self = shift;
651
652 my $node = $self->{_conf} or return;
653 my @path;
654
655 for (@_) {
656 return unless $node->is_section && $node->has_key($_);
657 push @path, [ $node, $_ ];
658 $node = $node->subtree($_);
659 }
660
661 while (1) {
662 my $loc = pop @path;
663 $loc->[0]->delete($loc->[1]);
664 last unless ($loc->[0]->keys == 0);
665 }
666}
667
668=head2 @array = $cfg->names_of(@path)
669
670If B<@path> refers to an existing configuration section, returns a list
671of names of variables and subsections defined within that section. E.g.,
672if you have
673
674 [item foo]
675 x = 1
676 [item bar]
677 x = 1
678 [item baz]
679 y = 2
680
681the call
682
683 $cfg->names_of('item')
684
685will return
686
687 ( 'foo', 'bar', 'baz' )
688
689=cut
690
691sub names_of {
692 my $self = shift;
693 my $node = $self->getnode(@_);
694 return () unless defined($node) && $node->is_section;
695 return $node->keys;
696}
697
698=head2 @array = $cfg->flatten()
699
700=head2 @array = $cfg->flatten(sort => $sort)
701
702Returns a I<flattened> representation of the configuration, as a
703list of pairs B<[ $path, $value ]>, where B<$path> is a reference
704to the variable pathname, and B<$value> is a
705B<Config::Tree::Node::Value> object.
706
707=cut
708
709use constant {
710 NO_SORT => 0,
711 SORT_NATURAL => 1,
712 SORT_PATH => 2
713};
714
715=pod
716
717The I<$sort> argument controls the ordering of the entries in the returned
718B<@array>. It is either a code reference suitable to pass to the Perl B<sort>
719function, or one of the following constants:
720
721=over 4
722
723=item NO_SORT
724
725Don't sort the array. Statements will be placed in an apparently random
726order.
727
728=item SORT_NATURAL
729
730Preserve relative positions of the statements. Entries in the array will
731be in the same order as they appeared in the configuration file. This is
732the default.
733
734=item SORT_PATH
735
736Sort by pathname.
737
738=back
739
740These constants are not exported by default. You can either import the
741ones you need, or use the B<:sort> keyword to import them all, e.g.:
742
743 use Sourceyard::Config qw(:sort);
744 @array = $cfg->flatten(sort => SORT_PATH);
745
746=cut
747
748sub flatten {
749 my $self = shift;
750 local %_ = @_;
751 my $sort = delete($_{sort}) || SORT_NATURAL;
752 my @ar;
753 my $i;
754
755 croak "unrecognized keyword arguments: ". join(',', keys %_)
756 if keys %_;
757
758 push @ar, [ [], $self->{_conf} ];
759 foreach my $elt (@ar) {
760 next if $elt->[1]->is_value;
761 while (my ($kw, $val) = each %{$elt->[1]->subtree}) {
762 push @ar, [ [@{$elt->[0]}, $kw], $val ];
763 }
764 }
765
766 if (ref($sort) eq 'CODE') {
767 $sort = sub { sort $sort @_ };
768 } elsif ($sort == SORT_PATH) {
769 $sort = sub {
770 sort { join('.',@{$a->[0]}) cmp join('.', @{$b->[0]}) } @_
771 };
772 } elsif ($sort == SORT_NATURAL) {
773 $sort = sub {
774 sort { $a->[1]->order <=> $b->[1]->order } @_
775 };
776 } elsif ($sort == NO_SORT) {
777 $sort = sub { @_ };
778 } else {
779 croak "unsupported sort value";
780 }
781 shift @ar; # toss off first entry
782 return &{$sort}(grep { $_->[1]->is_value } @ar);
783}
784
785sub __lint {
786 my ($self, $syntax, $node, @path) = @_;
787
788 $syntax = {} unless ref($syntax) eq 'HASH';
789 if (exists($syntax->{section})) {
790 return unless $node->is_section;
791 } else {
792 return if $node->is_section;
793 }
794
795 if (exists($syntax->{select}) &&
796 !$self->${ \ $syntax->{select} }($node, @path)) {
797 return;
798 }
799
800 if ($node->is_section) {
801 $self->_lint($syntax->{section}, $node, @path);
802 } else {
803 my $val = $node->value;
804 my %opts = ( locus => $node->locus );
805
806 if (ref($val) eq 'ARRAY') {
807 if ($syntax->{array}) {
808 my @ar;
809 foreach my $v (@$val) {
810 if (exists($syntax->{re})) {
811 if ($v !~ /$syntax->{re}/) {
812 $self->error("invalid value for $path[-1]", %opts);
813 $self->{_error_count}++;
814 next;
815 }
816 }
817 if (my $ck = $syntax->{check}) {
818 unless ($self->$ck(\$v, @ar ? $ar[-1] : undef,
819 $node->locus)) {
820 $self->{_error_count}++;
821 next;
822 }
823 }
824 push @ar, $v;
825 }
826 $node->value(\@ar);
827 return;
828 } else {
829 $val = pop(@$val);
830 }
831 }
832
833 if (exists($syntax->{re})) {
834 if ($val !~ /$syntax->{re}/) {
835 $self->error("invalid value for $path[-1]", %opts);
836 $self->{_error_count}++;
837 return;
838 }
839 }
840
841 if (my $ck = $syntax->{check}) {
842 unless ($self->$ck(\$val, undef, $node->locus)) {
843 $self->{_error_count}++;
844 return;
845 }
846 }
847
848 $node->value($val);
849 }
850}
851
852sub _lint {
853 my ($self, $syntab, $node, @path) = @_;
854
855 while (my ($var, $value) = each %{$node->subtree}) {
856 if (exists($syntab->{$var})) {
857 $self->__lint($syntab->{$var}, $value, @path, $var);
858 } elsif (exists($syntab->{'*'})) {
859 $self->__lint($syntab->{'*'}, $value, @path, $var);
860 } elsif ($value->is_section) {
861 next;
862 } else {
863 $self->error("keyword \"$var\" is unknown",
864 locus => $value->locus);
865 $self->{_error_count}++;
866 }
867 }
868}
869
870=head2 $cfg->lint(\%synt)
871
872Checks the syntax according to the syntax table B<%synt>. On success,
873applies eventual default values and returns true. On errors, reports
874them using B<error> and returns false.
875
876This method provides a way to delay syntax checking for a later time,
877which is useful, e.g. if some parts of the parser are loaded as modules
878after calling B<parse>.
879
880=cut
881
882sub lint {
883 my ($self, $synt) = @_;
884
885# $synt->{'*'} = { section => { '*' => 1 }} ;
886 $self->{_conf} = new Config::Tree::Node::Section(default => 1)
887 unless exists $self->{_conf};
888 $self->_lint($synt, $self->{_conf});
889 $self->_fixup($self->{_conf}, $synt);
890 return $self->{_error_count} == 0;
891}
892
8931;
diff --git a/lib/Config/Tree/Locus.pm b/lib/Config/Tree/Locus.pm
new file mode 100644
index 0000000..5808b9b
--- a/dev/null
+++ b/lib/Config/Tree/Locus.pm
@@ -0,0 +1,288 @@
1package Config::Tree::Locus;
2
3use strict;
4use warnings;
5use parent 'Exporter';
6
7use Carp;
8use Storable qw(dclone);
9use Scalar::Util qw(blessed);
10
11=head1 NAME
12
13Config::Tree::Locus - source file location
14
15=head1 SYNOPSIS
16
17use Config::Tree::Locus;
18
19$locus = new Config::Tree::Locus;
20
21$locus = new Config::Tree::Locus($file, $line);
22
23$locus->add($file, $line);
24
25$s = $locus->format;
26
27$locus->fixup_names('old' => 'new');
28
29$locus->fixup_lines();
30
31print "$locus: text\n";
32
33$res = $locus1 + $locus2;
34
35=head1 DESCRIPTION
36
37Provides support for manipulating source file locations.
38
39=head2 $locus = new Config::Tree::Locus($file, $line, ...);
40
41Creates a new locus object. Arguments are optional. If given, they
42indicate the source file name and line numbers this locus is to represent.
43
44=cut
45
46sub new {
47 my $class = shift;
48
49 my $self = bless { _table => {}, _order => 0 }, $class;
50
51 croak "line numbers not given" if @_ == 1;
52 $self->add(@_) if @_ > 1;
53
54 return $self;
55}
56
57=head2 $obj->clone
58
59Creates a new B<Config::Tree::Locus> which is exact copy of B<$obj>.
60
61=cut
62
63sub clone {
64 my $self = shift;
65 return dclone($self);
66}
67
68=head2 $locus->add($file, $line, [$line1 ...]);
69
70Adds new location to the locus. Use this for statements spanning several
71lines and/or files.
72
73Returns B<$locus>.
74
75=cut
76
77sub add {
78 my ($self, $file) = (shift, shift);
79 unless (exists($self->{_table}{$file})) {
80 $self->{_table}{$file}{_order} = $self->{_order}++;
81 $self->{_table}{$file}{_lines} = [];
82 }
83 push @{$self->{_table}{$file}{_lines}}, @_;
84 delete $self->{_string};
85 return $self;
86}
87
88=head2 $locus->add_locus($locus2);
89
90Adds locations from B<$locus2> to B<$locus>.
91
92=cut
93
94sub add_locus {
95 my ($self, $other) = @_;
96 croak "not the same class"
97 unless blessed($other) && $other->isa(__PACKAGE__);
98 while (my ($file, $tab) = each %{$other->{_table}}) {
99 $self->add($file, @{$tab->{_lines}});
100 }
101 return $self;
102 }
103
104=head2 $s = $locus->format($msg);
105
106Returns a string representation of the locus. The argument is optional.
107If given, its string representation will be concatenated to the formatted
108locus with a ": " in between. If multiple arguments are supplied, their
109string representations will be concatenated, separated by horizontal
110space characters. This is useful for formatting error messages.
111
112If the locus contains multiple file locations, the method tries to compact
113them by representing contiguous line ranges as B<I<X>-I<Y>> and outputting
114each file name once. Line ranges are separated by commas. File locations
115are separated by semicolons. E.g.:
116
117 $locus = new Config::Tree::Locus("foo", 1);
118 $locus->add("foo", 2);
119 $locus->add("foo", 3);
120 $locus->add("foo", 5);
121 $locus->add("bar", 2);
122 $locus->add("bar", 7);
123 print $locus->format("here it goes");
124
125will produce the following:
126
127 foo:1-3,5;bar:2,7: here it goes
128
129=cut
130
131sub format {
132 my $self = shift;
133 unless (exists($self->{_string})) {
134 $self->{_string} = '';
135 foreach my $file (sort {
136 $self->{_table}{$a}{_order} <=> $self->{_table}{$b}{_order}
137 }
138 keys %{$self->{_table}}) {
139 $self->{_string} .= ';' if $self->{_string};
140 $self->{_string} .= "$file";
141 if (my @lines = @{$self->{_table}{$file}{_lines}}) {
142 $self->{_string} .= ':';
143 my $beg = shift @lines;
144 my $end = $beg;
145 my @ranges;
146 foreach my $line (@lines) {
147 if ($line == $end + 1) {
148 $end = $line;
149 } else {
150 if ($end > $beg) {
151 push @ranges, "$beg-$end";
152 } else {
153 push @ranges, $beg;
154 }
155 $beg = $end = $line;
156 }
157 }
158
159 if ($end > $beg) {
160 push @ranges, "$beg-$end";
161 } else {
162 push @ranges, $beg;
163 }
164 $self->{_string} .= join(',', @ranges);
165 }
166 }
167 }
168 if (@_) {
169 if ($self->{_string} ne '') {
170 return "$self->{_string}: " . join(' ', @_);
171 } else {
172 return join(' ', @_);
173 }
174 }
175 return $self->{_string};
176}
177
178=head2 Overloaded operations
179
180When used in a string, the locus object formats itself. E.g. to print
181a diagnostic message one can write:
182
183 print "$locus: some text\n";
184
185In fact, this method is preferred over calling B<$locus->format>.
186
187Two objects can be added:
188
189 $loc1 + $loc2
190
191This will produce a new Locus object containing locations from both B<loc1>
192and B<$loc2>.
193
194Moreover, a term can also be a string in the form B<"I<file>:I<line>>:
195
196 $loc + "file:10"
197
198or
199
200 "file:10" + $loc
201
202=cut
203
204use overload
205 '""' => sub { shift->format() },
206 '+' => sub {
207 my ($self, $other, $swap) = @_;
208 if (blessed $other) {
209 return $self->clone->add_locus($other);
210 } elsif (!ref($other) && $other =~ m/^(.+):(\d+)$/) {
211 if ($swap) {
212 return new Config::Tree::Locus($1, $2) + $self;
213 } else {
214 return $self->clone->add($1, $2);
215 }
216 } else {
217 croak "bad argument type in locus addition";
218 }
219 };
220
221=head2 $locus->fixup_names('foo' => 'bar', 'baz' => 'quux');
222
223Replaces file names in the locations according to the arguments.
224
225=cut
226
227sub fixup_names {
228 my $self = shift;
229 local %_ = @_;
230 while (my ($oldname, $newname) = each %_) {
231 next unless exists $self->{_table}{$oldname};
232 croak "target name already exist" if exists $self->{_table}{$newname};
233 $self->{_table}{$newname} = delete $self->{_table}{$oldname};
234 }
235 delete $self->{_string};
236}
237
238=head2 $locus->fixup_lines('foo' => 1, 'baz' => -2);
239
240Offsets line numbers for each named file by the given number of lines. E.g.:
241
242 $locus = new Config::Tree::Locus("foo", 1);
243 $locus->add("foo", 2);
244 $locus->add("foo", 3);
245 $locus->add("bar", 3);
246 $locus->fixup_lines(foo => 1. bar => -1);
247 print $locus->format;
248
249will produce
250
251 foo:2-4,bar:2
252
253If given a single argument, the operation will affect all locations. E.g.,
254adding the following to the example above:
255
256 $locus->fixup_lines(10);
257 print $locus->format;
258
259will produce
260
261 foo:22-24;bar:22
262
263=cut
264
265sub fixup_lines {
266 my $self = shift;
267 return unless @_;
268 if ($#_ == 0) {
269 my $offset = shift;
270 while (my ($file, $ref) = each %{$self->{_table}}) {
271 $ref->{_lines} = [map { $_ + $offset } @{$ref->{_lines}}];
272 }
273 } elsif ($#_ % 2) {
274 local %_ = @_;
275 while (my ($file, $offset) = each %_) {
276 if (exists($self->{_table}{$file})) {
277 $self->{_table}{$file}{_lines} =
278 [map { $_ + $offset }
279 @{$self->{_table}{$file}{_lines}}];
280 }
281 }
282 } else {
283 croak "bad number of arguments";
284 }
285 delete $self->{_string};
286}
287
2881;
diff --git a/lib/Config/Tree/Node.pm b/lib/Config/Tree/Node.pm
new file mode 100644
index 0000000..6197ffb
--- a/dev/null
+++ b/lib/Config/Tree/Node.pm
@@ -0,0 +1,161 @@
1package Config::Tree::Node;
2
3use strict;
4use warnings;
5use parent 'Exporter';
6use Clone 'clone';
7
8use Carp;
9
10=head1 NAME
11
12Config::Tree::Node - generic configuration node
13
14=head1 SYNOPSIS
15
16use parent 'Config::Tree::Node';
17
18=head1 DESCRIPTION
19
20This is an abstract class representing a node in the configuration parse
21tree. A node can be either a non-leaf node, representing a I<section>, or
22a leaf node, representing configuration I<statement>.
23
24=head1 METHODS
25
26=head2 new(ARG => VAL, ...)
27
28Creates new object. Recognized arguments are:
29
30=over 4
31
32=item B<clone =E<gt>> I<OBJ>
33
34Clone object I<OBJ>, which must be an instance of B<Config::Tree::Node>
35or its derived class.
36
37=item
38
39=item B<default =E<gt>> I<VAL>
40
41Sets default value.
42
43=item B<locus =E<gt>> I<LOC>
44
45Sets the locus - an object of class B<Config::Tree::Locus>, which see.
46
47=item B<file =E<gt>> I<NAME>
48
49Sets the file name.
50
51=item B<order =E<gt>> I<N>
52
53Sets ordinal number.
54
55=back
56
57=cut
58
59sub new {
60 my $class = shift;
61 local %_ = @_;
62 my $v;
63 my $self;
64 if ($v = delete $_{clone}) {
65 $self = clone($v);
66 } else {
67 $self = bless { }, $class;
68 }
69 if (defined($v = delete $_{default})) {
70 $self->default($v);
71 }
72 if (defined($v = delete $_{locus})) {
73 $self->locus($v);
74 }
75
76 if (defined($v = delete $_{file})) {
77 $self->locus($v, delete $_{line} // 0);
78 }
79 if (defined($v = delete $_{order})) {
80 $self->order($v);
81 }
82 croak "unrecognized arguments" if keys(%_);
83 return $self;
84}
85
86=head2 $x = $node->locus;
87
88Returns a locus associated with the node.
89
90=head2 locus(LOC)
91
92=head2 locus(FILE, LINE)
93
94Associates a locus with the node. In the second form, a new locus object
95is created for location I<FILE>:I<LINE>.
96
97=cut
98
99sub locus {
100 my $self = shift;
101 if (@_ == 1) {
102 croak "bad argument type"
103 unless ref($_[0]) eq 'Config::Tree::Locus';
104 $self->{_locus} = $_[0];
105 } elsif (@_ == 2) {
106 $self->{_locus} = new Config::Tree::Locus(@_);
107 } elsif (@_) {
108 croak "bad number of arguments";
109 }
110 return $self->{_locus};
111}
112
113=head2 $x = $node->order
114
115=head2 $node->order(I<N>)
116
117Returns or sets and returns ordinal number for the node.
118
119=cut
120
121sub order {
122 my ($self, $val) = @_;
123 if (defined($val)) {
124 $self->{_order} = $val;
125 }
126 return $self->{_order} // 0;
127}
128
129sub default {
130 my ($self, $val) = @_;
131 if (defined($val)) {
132 $self->{_default} = $val;
133 }
134 return $self->{_default};
135}
136
137=head2 is_leaf
138
139Returns true if node is a leaf node
140
141=cut
142
143=head2 is_section()
144
145Returns true if node represents a section.
146
147=cut
148
149sub is_section { ! shift->is_leaf }
150
151=head2 is_section()
152
153Returns true if node represents a value (or statement).
154
155=cut
156
157sub is_value { shift->is_leaf }
158
1591;
160
161
diff --git a/lib/Config/Tree/Node/Section.pm b/lib/Config/Tree/Node/Section.pm
new file mode 100644
index 0000000..833f5c5
--- a/dev/null
+++ b/lib/Config/Tree/Node/Section.pm
@@ -0,0 +1,41 @@
1package Config::Tree::Node::Section;
2use parent 'Config::Tree::Node';
3use strict;
4use warnings;
5
6sub new {
7 my $class = shift;
8 my $self = $class->SUPER::new(@_);
9 $self->{_subtree} = {};
10 return $self;
11}
12
13sub subtree {
14 my $self = shift;
15 if (my $key = shift) {
16 if (my $val = shift) {
17 $self->{_subtree}{$key} = $val;
18 }
19 return $self->{_subtree}{$key};
20 }
21 return $self->{_subtree};
22}
23
24sub keys {
25 my $self = shift;
26 return keys %{$self->{_subtree}};
27}
28
29sub has_key {
30 my ($self, $key) = @_;
31 return $self->subtree($key);
32}
33
34sub delete {
35 my ($self, $key) = @_;
36 delete $self->{_subtree}{$key};
37}
38
39sub is_leaf { 0 }
40
411;
diff --git a/lib/Config/Tree/Node/Value.pm b/lib/Config/Tree/Node/Value.pm
new file mode 100644
index 0000000..ee14159
--- a/dev/null
+++ b/lib/Config/Tree/Node/Value.pm
@@ -0,0 +1,34 @@
1package Config::Tree::Node::Value;
2use parent 'Config::Tree::Node';
3use strict;
4use warnings;
5
6sub new {
7 my $class = shift;
8 local %_ = @_;
9 my $v = delete $_{value};
10 my $self = $class->SUPER::new(%_);
11 $self->value($v);
12 return $self;
13}
14
15sub value {
16 my ($self, $val) = @_;
17
18 if (defined($val)) {
19 $self->{_value} = $val;
20 return; # Avoid evaluatig value too early
21 } else {
22 $val = $self->{_value};
23 }
24
25 if (ref($val) eq 'CODE') {
26 $val = &$val;
27 }
28
29 return $val;
30}
31
32sub is_leaf { 1 };
33
341;
diff --git a/t/TestConfig.pm b/t/TestConfig.pm
new file mode 100644
index 0000000..de1ade9
--- a/dev/null
+++ b/t/TestConfig.pm
@@ -0,0 +1,103 @@
1package TestConfig;
2
3use strict;
4use Carp;
5use File::Temp;
6
7use Config::Tree qw(:sort);
8use parent 'Config::Tree';
9
10sub new {
11 my $class = shift;
12 local %_ = @_;
13
14 my $config = delete $_{config};
15 my $exp = delete $_{expect};
16
17 my $self = $class->SUPER::new(%_);
18 $self->{_expected_errors} = $exp // [];
19 my $i = 1;
20 while ((my $k = shift @$config) && (my $v = shift @$config)) {
21# while (my ($k,$v) = each %$config) {
22 $self->add_node($k, $v, new Config::Tree::Locus('input', $i++));
23 }
24 $self->commit;
25 if (@{$self->{_expected_errors}}) {
26 $self->{_status} = 0;
27 $self->report("not all expected errors reported: @{$self->{_expected_errors}}");
28 }
29 return $self;
30}
31
32sub success {
33 my ($self) = @_;
34 return $self->{_status};
35}
36
37sub canonical {
38 my $self = shift;
39 local %_ = @_;
40 my $delim;
41 unless (defined($delim = delete $_{delim})) {
42 $delim = " ";
43 }
44 carp "unknown parameters: " . join(', ', keys(%_)) if (keys(%_));
45
46 return join $delim, map {
47 local $Data::Dumper::Useqq = 1;
48 local $Data::Dumper::Terse = 1;
49 local $Data::Dumper::Indent = 0;
50 join('.', @{$_->[0]}) . "=" . Data::Dumper->Dump([$_->[1]->value]);
51 } $self->flatten(sort => SORT_PATH);
52}
53
54sub expected_error {
55 my ($self, $msg) = @_;
56
57 if (exists($self->{_expected_errors})) {
58 my ($i) = grep { ${$self->{_expected_errors}}[$_] eq $msg }
59 0..$#{$self->{_expected_errors}};
60 if (defined($i)) {
61 splice(@{$self->{_expected_errors}}, $i, 1);
62 return 1;
63 }
64 }
65}
66
67sub error {
68 my $self = shift;
69 my $err = shift;
70 local %_ = @_;
71 push @{$self->{_errors}}, { message => $err };
72 print STDERR "$_{locus}: $err\n"
73 unless $self->expected_error($err);
74}
75
76sub errors {
77 my $self = shift;
78 return undef if $self->success;
79 return @{$self->{_errors}};
80}
81
82sub report {
83 my ($self, $err) = @_;
84 print STDERR "$err\n"
85}
86
87sub lint {
88 my $self = shift;
89 my $synt = shift;
90 local %_ = @_;
91 my $exp = $self->{_expected_errors} = delete $_{expect};
92 carp "unknown parameters: " . join(', ', keys(%_)) if (keys(%_));
93
94 my $ret = $self->SUPER::lint($synt);
95
96 if ($exp && @{$self->{_expected_errors}}) {
97 $self->{_status} = 0;
98 $self->report("not all expected errors reported: @{$self->{_expected_errors}}");
99 }
100 return $ret;
101}
102
1031;
diff --git a/t/conf01.t b/t/conf01.t
new file mode 100644
index 0000000..5c91f7f
--- a/dev/null
+++ b/t/conf01.t
@@ -0,0 +1,18 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 1);
8
9my $cfg = new TestConfig(
10 config => [
11 'core.retain-interval' => '10',
12 'core.tempdir' => '/tmp',
13 'backend.foo.file' => 'a'
14 ]
15);
16ok($cfg->canonical, 'backend.foo.file="a" core.retain-interval=10 core.tempdir="/tmp"');
17
18
diff --git a/t/conf02.t b/t/conf02.t
new file mode 100644
index 0000000..ce55ff1
--- a/dev/null
+++ b/t/conf02.t
@@ -0,0 +1,30 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 7);
8
9my $cfg = new TestConfig(
10 config => [
11 'core.retain-interval' => '10',
12 'core.tempdir' => '/tmp',
13 'backend.foo.file' => 'foo'
14 ]
15);
16
17ok($cfg->is_set('backend','foo','file'));
18ok($cfg->is_variable('backend','foo','file'));
19ok($cfg->get('backend','foo','file'), 'foo');
20
21ok($cfg->is_set('core', 'verbose') == 0);
22
23ok($cfg->is_section('backend','foo'));
24
25$cfg->set('core','verbose','On');
26ok($cfg->get('core','verbose'),'On');
27
28$cfg->unset('core','tmpdir');
29ok($cfg->is_set('core','tmpdir') == 0);
30
diff --git a/t/conf03.t b/t/conf03.t
new file mode 100644
index 0000000..b887995
--- a/dev/null
+++ b/t/conf03.t
@@ -0,0 +1,29 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 1);
8
9my %keywords = (
10 core => {
11 section => {
12 'tempdir' => 1,
13 'verbose' => 1,
14 }
15 },
16 backend => {
17 section => {
18 file => 1
19 }
20 }
21);
22my $cfg = new TestConfig(
23 config => [
24 'core.tempdir' => '/tmp',
25 'core.output' => 'file'
26 ],
27 parameters => \%keywords,
28 expect => [ 'keyword "output" is unknown' ]);
29ok($cfg->errors() == 1);
diff --git a/t/conf04.t b/t/conf04.t
new file mode 100644
index 0000000..0ad4b64
--- a/dev/null
+++ b/t/conf04.t
@@ -0,0 +1,37 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 1);
8
9my %keywords = (
10 core => {
11 section => {
12 'retain-interval' => { mandatory => 1 },
13 'tempdir' => 1,
14 'verbose' => 1,
15 }
16 },
17 backend => {
18 section => {
19 file => {
20 section => {
21 name => { mandatory => 1 },
22 local => 1
23 }
24 }
25 }
26 }
27);
28
29my $cfg = new TestConfig(
30 config => [
31 'core.tempdir' => '/tmp',
32 'backend.file.local' => 1
33 ],
34 parameters => \%keywords,
35 expect => [ 'mandatory variable "core.retain-interval" not set',
36 'mandatory variable "backend.file.name" not set' ]);
37ok($cfg->errors()==2);
diff --git a/t/conf05.t b/t/conf05.t
new file mode 100644
index 0000000..4cb7942
--- a/dev/null
+++ b/t/conf05.t
@@ -0,0 +1,30 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 1);
8
9my %keywords = (
10 core => {
11 section => {
12 list => {
13 array => 1
14 },
15 pidfile => 1
16 }
17 }
18);
19
20my $cfg = new TestConfig(
21 config => [
22 'core.list' => 'en',
23 'core.list' => 'to',
24 'core.list' => '5',
25
26 'core.pidfile' => 'file1',
27 'core.pidfile' => 'file2'
28 ],
29 parameters => \%keywords);
30ok($cfg->canonical(),'core.list=["en","to",5] core.pidfile="file2"');
diff --git a/t/conf06.t b/t/conf06.t
new file mode 100644
index 0000000..1d04c8e
--- a/dev/null
+++ b/t/conf06.t
@@ -0,0 +1,56 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6use Data::Dumper;
7
8plan(tests => 3);
9
10my %keywords = (
11 core => {
12 section => {
13 'retain-interval' => { mandatory => 1 },
14 'tempdir' => 1,
15 'verbose' => 1,
16 }
17 },
18 '*' => '*'
19);
20
21my $cfg = new TestConfig(
22 config => [
23 'core.retain-interval' => 10,
24 'core.tempdir' => '/tmp',
25 'backend.file.local' => 1,
26 'backend.file.level' => 3
27 ],
28 parameters => \%keywords);
29
30ok($cfg->canonical, 'backend.file.level=3 backend.file.local=1 core.retain-interval=10 core.tempdir="/tmp"');
31
32ok($cfg->lint(\%keywords));
33
34my %subkw = (
35 core => {
36 section => {
37 'retain-interval' => { mandatory => 1 },
38 'tempdir' => 1,
39 'verbose' => 1,
40 }
41 },
42 backend => {
43 section => {
44 file => {
45 section => {
46 name => { mandatory => 1 },
47 local => 1
48 }
49 }
50 }
51 }
52);
53
54ok(!$cfg->lint(\%subkw,
55 expect => [ 'keyword "level" is unknown',
56 'mandatory variable "backend.file.name" not set' ]));
diff --git a/t/conf07.t b/t/conf07.t
new file mode 100644
index 0000000..ba28872
--- a/dev/null
+++ b/t/conf07.t
@@ -0,0 +1,56 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6use Data::Dumper;
7
8plan(tests => 2);
9
10my %keywords = (
11 core => {
12 section => {
13 'retain-interval' => { mandatory => 1 },
14 'tempdir' => 1,
15 'verbose' => 1,
16 }
17 },
18 '*' => '*'
19);
20
21my $cfg = new TestConfig(
22 config => [
23 'core.retain-interval' => 10,
24 'item.foo.backend' => 'tar',
25 'item.foo.directory' => 'baz',
26 'item.bar.backend' => 'mysql',
27 'item.bar.database' => 'quux'
28 ],
29 parameters => \%keywords
30);
31
32ok($cfg->canonical, 'core.retain-interval=10 item.bar.backend="mysql" item.bar.database="quux" item.foo.backend="tar" item.foo.directory="baz"');
33
34my %subkw = (
35 item => {
36 section => {
37 '*' => {
38 select => sub {
39 my ($vref) = @_;
40 return 0 unless ref($vref) eq 'HASH';
41 return $vref->{backend}->{-value} eq 'tar';
42 },
43 section => {
44 backend => 1,
45 directory => {
46 mandatory => 1,
47 }
48 }
49 }
50 }
51 }
52);
53
54ok($cfg->lint(\%subkw));
55
56
diff --git a/t/conf08.t b/t/conf08.t
new file mode 100644
index 0000000..8068de2
--- a/dev/null
+++ b/t/conf08.t
@@ -0,0 +1,34 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 1);
8
9my %keywords = (
10 core => {
11 section => {
12 name => {
13 check => sub {
14 my ($self, $vref, $prev, $loc) = @_;
15 if ($$vref !~ /^[A-Z]/) {
16 $self->error("must start with a capital letter",
17 locus => $loc);
18 return 0;
19 }
20 return 1;
21 }
22 }
23 }
24 }
25);
26
27ok(new TestConfig(
28 config => [
29 'core.name' => 'foo'
30 ],
31 parameters => \%keywords,
32 expect => [ "must start with a capital letter" ]));
33
34
diff --git a/t/conf09.t b/t/conf09.t
new file mode 100644
index 0000000..cbe5536
--- a/dev/null
+++ b/t/conf09.t
@@ -0,0 +1,27 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 2);
8
9my %keywords = (
10 core => {
11 section => {
12 backend => { mandatory => 1, default => "file" },
13 acl => 1
14 }
15 },
16 file => {
17 section => {
18 name => 1
19 }
20 }
21);
22
23my $cfg = new TestConfig(parameters => \%keywords);
24ok($cfg);
25ok($cfg->canonical, q{core.backend="file"});
26
27
diff --git a/t/conf10.t b/t/conf10.t
new file mode 100644
index 0000000..5dbecc3
--- a/dev/null
+++ b/t/conf10.t
@@ -0,0 +1,23 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 1);
8
9my %keywords = (
10 base => { mandatory => 1 },
11 file => { default => sub {
12 my $self = shift;
13 return $self->get('base') . '/passwd';
14 }
15 }
16);
17
18my $t = new TestConfig(
19 config => [
20 base => '/etc'
21 ],
22 parameters => \%keywords);
23ok($t->get('file'), '/etc/passwd');
diff --git a/t/conf11.t b/t/conf11.t
new file mode 100644
index 0000000..13516b8
--- a/dev/null
+++ b/t/conf11.t
@@ -0,0 +1,17 @@
1# -*- perl -*-
2use lib qw(t lib);
3use strict;
4use Test;
5use TestConfig;
6
7plan(tests => 3);
8
9my $cfg = new TestConfig(
10 config => [
11 'core.retain-interval' => 10,
12 'core.tempdir' => '/tmp'
13 ]
14 );
15ok(join(',', $cfg->getnode('core')->keys), 'retain-interval,tempdir');
16ok($cfg->getnode('core')->keys, 2);
17ok(join(',', sort $cfg->names_of('core')), 'retain-interval,tempdir');
diff --git a/t/locus.t b/t/locus.t
new file mode 100644
index 0000000..0f8de52
--- a/dev/null
+++ b/t/locus.t
@@ -0,0 +1,50 @@
1# -*- perl -*-
2use strict;
3use lib qw(t lib);
4use Test;
5use Config::Tree::Locus;
6
7plan(tests => 14);
8
9my $loc = new Config::Tree::Locus;
10ok($loc->format, '');
11ok($loc->format('test', 'message'), 'test message');
12
13$loc->add('foo', 10);
14ok($loc->format, "foo:10");
15ok("$loc", "foo:10");
16
17$loc->add('foo', 11);
18$loc->add('foo', 12);
19$loc->add('foo', 13);
20ok($loc->format, "foo:10-13");
21
22$loc->add('foo', 24);
23$loc->add('foo', 28);
24ok($loc->format, "foo:10-13,24,28");
25ok($loc->format('test', 'message'), "foo:10-13,24,28: test message");
26
27$loc->add('bar', 1);
28$loc->add('baz', 8);
29$loc->add('baz', 9);
30$loc->add('bar', 5);
31ok($loc->format, "foo:10-13,24,28;bar:1,5;baz:8-9");
32
33$loc->fixup_names('foo' => 'Foo', 'bar' => 'BAR');
34ok($loc->format, "Foo:10-13,24,28;BAR:1,5;baz:8-9");
35
36$loc->fixup_lines('Foo' => -1, 'baz' => 2);
37ok($loc->format, "Foo:9-12,23,27;BAR:1,5;baz:10-11");
38
39$loc->fixup_lines(3);
40ok($loc->format, "Foo:12-15,26,30;BAR:4,8;baz:13-14");
41
42$loc = new Config::Tree::Locus("foo", 10, 15);
43ok("$loc", "foo:10,15");
44
45$loc += "bar:11";
46ok("$loc", "foo:10,15;bar:11");
47
48$loc = new Config::Tree::Locus("foo", 10);
49my $res = "bar:1" + $loc;
50ok("$res", "bar:1;foo:10");

Return to:

Send suggestions and report system problems to the System administrator.