summaryrefslogtreecommitdiff
path: root/lib/Config/AST/Follow.pm
blob: 0f4fbd595740c2fc7e89694e28e9e5a6c63cc621 (plain)
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
123
124
125
126
127
128
129
130
131
132
133
134
135
# 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

L<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;
    $key = $self->{_node}->root->mangle_key($key)
	if $self->{_node}->is_section;
    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($key)
	             // new Config::AST::Node::Null;
	return $next if $next->is_leaf || !$lex;
	$self->{_node} = $next;
    }
    
    $self->{_lex} = $lex;
    $self;
}

sub DESTROY { }

use overload
    bool => sub { !!shift->{_node} },
    '""' => sub { shift->{_node}->as_string },
    eq => sub {
	my ($self,$other) = @_;
	return $self->{_node}->as_string eq $other
    };


1;

Return to:

Send suggestions and report system problems to the System administrator.