1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
# This file is part of Config::AST -*- perl -*-
# Copyright (C) 2017-2019 Sergey Poznyakoff <gray@gnu.org>
#
# Config::AST is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3, or (at your option)
# any later version.
#
# Config::AST is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Config::AST. If not, see <http://www.gnu.org/licenses/>.
package Config::AST::Follow;
use Config::AST::Node;
use Config::AST::Node::Null;
use strict;
use warnings;
use Carp;
=head1 NAME
Config::AST::Follow - direct addressing engine
=head1 DESCRIPTION
This class implements direct node addressing in B<Config::AST>.
Objects of this class are created as
$obj = Config::AST::Follow->new($node, $lexicon)
where B<$node> is the start node, and B<$lexicon> is the lexicon
corresponding to that node. A B<Config::AST::Follow> object transparently
delegates its methods to the underlying I<$node>, provided that such
method is defined for I<$node>. If it is not, it reproduces itself
with the new B<$node>, obtained as a result of the call to B<$node-E<gt>subtree>
with the method name as its argument. If the result of the B<subtree> call
is a leaf node, it is returned verbatim. The lexicon hash is consulted to
check if the requested node name is allowed or not. If it is not, B<croak>
is called. As a result, the following call:
$obj->A->B->C
is equivalent to
$node->getnode('X', 'Y', 'Z')
except that it will consult the lexicon to see if each name is allowed
within a particular section.
=head1 SEE ALSO
B<Config::AST>(3).
=cut
sub new {
my ($class, $node, $lex) = @_;
bless { _node => $node, _lex => $lex }, $class;
}
our $AUTOLOAD;
sub AUTOLOAD {
my $self = shift;
$AUTOLOAD =~ s/(?:(.*)::)?(.+)//;
my ($p, $m) = ($1, $2);
if ($self->{_node}->can($m)) {
return $self->{_node}->${\$m};
}
croak "Can't locate object method \"$m\" via package \"$p\""
if @_;
croak "Can't locate object method \"$m\" via package \"$p\" \
(and no lexical info exists to descend to $m)"
unless ref($self->{_lex}) eq 'HASH';
(my $key = $m) =~ s/__/-/g;
my $lex = $self->{_lex};
if (ref($lex) eq 'HASH') {
if (exists($lex->{$key})) {
$lex = $lex->{$key};
} elsif (exists($lex->{'*'})) {
$lex = $lex->{'*'};
} else {
$lex = undef;
}
croak "Can't locate object method \"$m\" via package \"$p\""
unless $lex;
} else {
croak "Can't locate object method \"$m\" via package \"$p\""
}
if (!ref($lex)) {
if ($lex eq '*') {
$lex = { '*' => '*' };
} else {
$lex = undef;
}
} elsif ($lex->{section}) {
$lex = $lex->{section};
} else {
$lex = undef;
}
if (!$self->{_node}->is_null) {
my $next = $self->{_node}->subtree($self->{_ci} ? lc($key) : $key)
// new Config::AST::Node::Null;
return $next if $next->is_leaf || !$lex;
$self->{_node} = $next;
}
$self->{_lex} = $lex;
$self;
}
1;
|