File Coverage

lib/Config/AST/Follow.pm
Criterion Covered Total %
statement 48 54 88.8
branch 22 26 84.6
condition 5 6 83.3
subroutine 8 12 66.6
pod 0 1 0.0
total 83 99 83.8


line stmt bran cond sub pod time code
1             # This file is part of Config::AST -*- perl -*-
2             # Copyright (C) 2017-2019 Sergey Poznyakoff
3             #
4             # Config::AST 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             # Config::AST 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 Config::AST. If not, see .
16              
17             package Config::AST::Follow;
18 19     19   98 use Config::AST::Node;
  19         29  
  19         963  
19 19     19   82 use Config::AST::Node::Null;
  19         26  
  19         452  
20 19     19   1503 use strict;
  19         1529  
  19         306  
21 19     19   80 use warnings;
  19         25  
  19         462  
22 19     19   82 use Carp;
  19         24  
  19         10233  
23              
24             =head1 NAME
25              
26             Config::AST::Follow - direct addressing engine
27              
28             =head1 DESCRIPTION
29              
30             This class implements direct node addressing in B.
31             Objects of this class are created as
32              
33             $obj = Config::AST::Follow->new($node, $lexicon)
34              
35             where B<$node> is the start node, and B<$lexicon> is the lexicon
36             corresponding to that node. A B object transparently
37             delegates its methods to the underlying I<$node>, provided that such
38             method is defined for I<$node>. If it is not, it reproduces itself
39             with the new B<$node>, obtained as a result of the call to B<$node-Esubtree>
40             with the method name as its argument. If the result of the B call
41             is a leaf node, it is returned verbatim. The lexicon hash is consulted to
42             check if the requested node name is allowed or not. If it is not, B
43             is called. As a result, the following call:
44              
45             $obj->A->B->C
46              
47             is equivalent to
48              
49             $node->getnode('X', 'Y', 'Z')
50              
51             except that it will consult the lexicon to see if each name is allowed
52             within a particular section.
53              
54             =head1 SEE ALSO
55              
56             L(3).
57              
58             =cut
59              
60             sub new {
61 10     10 0 17 my ($class, $node, $lex) = @_;
62 10         27 bless { _node => $node, _lex => $lex }, $class;
63             }
64              
65             our $AUTOLOAD;
66             sub AUTOLOAD {
67 25     25   38 my $self = shift;
68              
69 25         75 $AUTOLOAD =~ s/(?:(.*)::)?(.+)//;
70 25         55 my ($p, $m) = ($1, $2);
71              
72 25 100       131 if ($self->{_node}->can($m)) {
73 3         4 return $self->{_node}->${\$m};
  3         14  
74             }
75              
76 22 50       34 croak "Can't locate object method \"$m\" via package \"$p\""
77             if @_;
78            
79             croak "Can't locate object method \"$m\" via package \"$p\" \
80             (and no lexical info exists to descend to $m)"
81 22 50       57 unless ref($self->{_lex}) eq 'HASH';
82            
83 22         34 (my $key = $m) =~ s/__/-/g;
84             $key = $self->{_node}->root->mangle_key($key)
85 22 100       37 if $self->{_node}->is_section;
86 22         28 my $lex = $self->{_lex};
87 22 50       33 if (ref($lex) eq 'HASH') {
88 22 100       38 if (exists($lex->{$key})) {
    100          
89 18         18 $lex = $lex->{$key};
90             } elsif (exists($lex->{'*'})) {
91 3         4 $lex = $lex->{'*'};
92             } else {
93 1         1 $lex = undef;
94             }
95 22 100       223 croak "Can't locate object method \"$m\" via package \"$p\""
96             unless $lex;
97             } else {
98 0         0 croak "Can't locate object method \"$m\" via package \"$p\""
99             }
100              
101 21 100       44 if (!ref($lex)) {
    50          
102 9 100       22 if ($lex eq '*') {
103 3         6 $lex = { '*' => '*' };
104             } else {
105 6         7 $lex = undef;
106             }
107             } elsif ($lex->{section}) {
108 12         13 $lex = $lex->{section};
109             } else {
110 0         0 $lex = undef;
111             }
112              
113 21 100       43 if (!$self->{_node}->is_null) {
114 19   66     31 my $next = $self->{_node}->subtree($key)
115             // new Config::AST::Node::Null;
116 19 100 100     39 return $next if $next->is_leaf || !$lex;
117 13         17 $self->{_node} = $next;
118             }
119            
120 15         19 $self->{_lex} = $lex;
121 15         69 $self;
122             }
123              
124       0     sub DESTROY { }
125              
126             use overload
127 0     0   0 bool => sub { !!shift->{_node} },
128 0     0   0 '""' => sub { shift->{_node}->as_string },
129             eq => sub {
130 0     0   0 my ($self,$other) = @_;
131 0         0 return $self->{_node}->as_string eq $other
132 19     19   115 };
  19         26  
  19         167  
133              
134              
135             1;