summaryrefslogtreecommitdiff
path: root/lib/Config/AST/Follow.pm
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Config/AST/Follow.pm')
-rw-r--r--lib/Config/AST/Follow.pm106
1 files changed, 106 insertions, 0 deletions
diff --git a/lib/Config/AST/Follow.pm b/lib/Config/AST/Follow.pm
new file mode 100644
index 0000000..671e947
--- /dev/null
+++ b/lib/Config/AST/Follow.pm
@@ -0,0 +1,106 @@
+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;

Return to:

Send suggestions and report system problems to the System administrator.