diff options
Diffstat (limited to 'lib/Config/AST/Follow.pm')
-rw-r--r-- | lib/Config/AST/Follow.pm | 106 |
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; |