summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2019-08-23 13:40:38 +0300
committerSergey Poznyakoff <gray@gnu.org.ua>2019-08-23 13:40:48 +0300
commita4a87bed9b7dbb2c8d35ad3b32b39b53b1eae517 (patch)
tree2aa084bc29a818284bd5f6b4075888b93a937363
parenta9ee653da53f5e4e8158620d44a458f48400ac52 (diff)
downloadconfig-ast-a4a87bed9b7dbb2c8d35ad3b32b39b53b1eae517.tar.gz
config-ast-a4a87bed9b7dbb2c8d35ad3b32b39b53b1eae517.tar.bz2
Rewrite direct access engine
This changes the syntax of direct addressing. To access the node a.b.c, one can simply write $cfg->a->b->c Node names cannot coincide with existing method names, as the latter will take precedence. * lib/Config/AST.pm (AUTOLOAD): Bootstrap direct addressing mechanism. * lib/Config/AST/Follow.pm: New module. * lib/Config/AST/Node/Section.pm (AUTOLOAD): Remove. * t/01conf12.t: Use new direct addressing syntax. * t/02conf01.t: Likewise. * lib/Config/AST/Node/Value.pm: Use fallback instead of explicitly overloading particular operators.
-rw-r--r--lib/Config/AST.pm42
-rw-r--r--lib/Config/AST/Follow.pm106
-rw-r--r--lib/Config/AST/Node/Section.pm14
-rw-r--r--lib/Config/AST/Node/Value.pm39
-rw-r--r--t/01conf12.t22
-rw-r--r--t/02conf01.t46
6 files changed, 186 insertions, 83 deletions
diff --git a/lib/Config/AST.pm b/lib/Config/AST.pm
index 721d515..958c106 100644
--- a/lib/Config/AST.pm
+++ b/lib/Config/AST.pm
@@ -23,6 +23,7 @@ use Text::Locus;
23use Config::AST::Node qw(:sort); 23use Config::AST::Node qw(:sort);
24use Config::AST::Node::Section; 24use Config::AST::Node::Section;
25use Config::AST::Node::Value; 25use Config::AST::Node::Value;
26use Config::AST::Follow;
26use Data::Dumper; 27use Data::Dumper;
27 28
28require Exporter; 29require Exporter;
@@ -670,7 +671,7 @@ node at path
670 671
671one can write: 672one can write:
672 673
673 $node = $cfg->tree->Foo->Bar->Baz 674 $node = $cfg->foo->bar->baz
674 675
675This statement is equivalent to 676This statement is equivalent to
676 677
@@ -678,20 +679,45 @@ This statement is equivalent to
678 679
679except that if the node in question does not exist, direct access returns 680except that if the node in question does not exist, direct access returns
680a I<null node>, and B<getnode> returns C<undef>. Null node is a special node 681a I<null node>, and B<getnode> returns C<undef>. Null node is a special node
681representing a missing node. Its B<is_null> method returns true and it can 682representing a missing node. Its B<is_null> method returns true and it can
682be used in conditional context as a boolean value, e.g.: 683be used in conditional context as a boolean value, e.g.:
683 684
684 if (my $node = $cfg->tree->Foo->Bar->Baz) { 685 if (my $node = $cfg->foo->bar->baz) {
685 $val = $node->value; 686 $val = $node->value;
686 } 687 }
687 688
688To compose direct access statement, first capitalize each path component. If 689Direct addressing is enabled only if lexicon is provided (either during
689the component name contains dashes, replace them with double underscores. Use 690creation of the object, or later, via the B<lexicon> method).
690the resulting names as methods of B<$cfg-E<gt>tree>. For example, to
691retrieve the C<qw(files temp-dir)> node, use
692 691
693 $cfg->tree->Files->Temp__dir; 692Obviously, statements that have names coinciding with one of the methods of
693the B<Config::AST> class (or any of its subclasses) can't be used in direct
694addressing. In other words, you can't have a top-level statement called
695C<tree> and access it as
694 696
697 $cfg->tree
698
699This statement will always refer to the method B<tree> of the B<Config::AST>
700class.
701
702Another possible problem when using direct access are keywords with dashes.
703Currently a kludge is implemented to make it possible to access such
704keywords: when looking for a matching keyword, double underscores compare
705equal to a single dash. For example, to retrieve the C<qw(files temp-dir)>
706node, use
707
708 $cfg->files->temp__dir;
709
710=cut
711
712our $AUTOLOAD;
713sub AUTOLOAD {
714 my $self = shift;
715 $AUTOLOAD =~ s/(?:(.*)::)?(.+)//;
716 my ($p, $m) = ($1, $2);
717 croak "Can't locate object method \"$m\" via package \"$p\""
718 if @_ || !$self->lexicon;
719 return Config::AST::Follow->new($self->tree, $self->lexicon)->${\$m};
720}
695 721
696=head1 CONSTRUCTING THE SYNTAX TREE 722=head1 CONSTRUCTING THE SYNTAX TREE
697 723
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 @@
1package Config::AST::Follow;
2use Config::AST::Node;
3use Config::AST::Node::Null;
4use strict;
5use warnings;
6use Carp;
7
8=head1 NAME
9
10Config::AST::Follow - direct addressing engine
11
12=head1 DESCRIPTION
13
14This class implements direct node addressing in B<Config::AST>.
15Objects of this class are created as
16
17 $obj = Config::AST::Follow->new($node, $lexicon)
18
19where B<$node> is the start node, and B<$lexicon> is the lexicon
20corresponding to that node. A B<Config::AST::Follow> object transparently
21delegates its methods to the underlying I<$node>, provided that such
22method is defined for I<$node>. If it is not, it reproduces itself
23with the new B<$node>, obtained as a result of the call to B<$node-E<gt>subtree>
24with the method name as its argument. If the result of the B<subtree> call
25is a leaf node, it is returned verbatim. The lexicon hash is consulted to
26check if the requested node name is allowed or not. If it is not, B<croak>
27is called. As a result, the following call:
28
29 $obj->A->B->C
30
31is equivalent to
32
33 $node->getnode('X', 'Y', 'Z')
34
35except that it will consult the lexicon to see if each name is allowed
36within a particular section.
37
38=head1 SEE ALSO
39
40B<Config::AST>(3).
41
42=cut
43
44sub new {
45 my ($class, $node, $lex) = @_;
46 bless { _node => $node, _lex => $lex }, $class;
47}
48
49our $AUTOLOAD;
50sub AUTOLOAD {
51 my $self = shift;
52
53 $AUTOLOAD =~ s/(?:(.*)::)?(.+)//;
54 my ($p, $m) = ($1, $2);
55
56 if ($self->{_node}->can($m)) {
57 return $self->{_node}->${\$m};
58 }
59
60 croak "Can't locate object method \"$m\" via package \"$p\""
61 if @_;
62
63 croak "Can't locate object method \"$m\" via package \"$p\" \
64 (and no lexical info exists to descend to $m)"
65 unless ref($self->{_lex}) eq 'HASH';
66
67 (my $key = $m) =~ s/__/-/g;
68 my $lex = $self->{_lex};
69 if (ref($lex) eq 'HASH') {
70 if (exists($lex->{$key})) {
71 $lex = $lex->{$key};
72 } elsif (exists($lex->{'*'})) {
73 $lex = $lex->{'*'};
74 } else {
75 $lex = undef;
76 }
77 croak "Can't locate object method \"$m\" via package \"$p\""
78 unless $lex;
79 } else {
80 croak "Can't locate object method \"$m\" via package \"$p\""
81 }
82
83 if (!ref($lex)) {
84 if ($lex eq '*') {
85 $lex = { '*' => '*' };
86 } else {
87 $lex = undef;
88 }
89 } elsif ($lex->{section}) {
90 $lex = $lex->{section};
91 } else {
92 $lex = undef;
93 }
94
95 if (!$self->{_node}->is_null) {
96 my $next = $self->{_node}->subtree($self->{_ci} ? lc($key) : $key)
97 // new Config::AST::Node::Null;
98 return $next if $next->is_leaf || !$lex;
99 $self->{_node} = $next;
100 }
101
102 $self->{_lex} = $lex;
103 $self;
104}
105
1061;
diff --git a/lib/Config/AST/Node/Section.pm b/lib/Config/AST/Node/Section.pm
index 95ec603..2353c89 100644
--- a/lib/Config/AST/Node/Section.pm
+++ b/lib/Config/AST/Node/Section.pm
@@ -164,20 +164,6 @@ Returns the string "(section)".
164 164
165sub as_string { '(section)' } 165sub as_string { '(section)' }
166 166
167our $AUTOLOAD;
168
169sub AUTOLOAD {
170 my $self = shift;
171 my $key = $AUTOLOAD;
172 $key =~ s/.*:://;
173 if ($key =~ s/^([A-Z])(.*)/\l$1$2/) {
174 $key =~ s/__/-/g;
175 return $self->subtree($self->{_ci} ? lc($key) : $key)
176 // new Config::AST::Node::Null;
177 }
178 confess "Can't locate method $AUTOLOAD";
179}
180
181=head1 SEE ALSO 167=head1 SEE ALSO
182 168
183B<Config::AST>, 169B<Config::AST>,
diff --git a/lib/Config/AST/Node/Value.pm b/lib/Config/AST/Node/Value.pm
index b1036bf..98770c2 100644
--- a/lib/Config/AST/Node/Value.pm
+++ b/lib/Config/AST/Node/Value.pm
@@ -137,44 +137,7 @@ use overload
137 my $res = $self->as_string cmp "$other"; 137 my $res = $self->as_string cmp "$other";
138 return $swap ? - $res : $res; 138 return $swap ? - $res : $res;
139 }, 139 },
140 '+' => sub { 140