summaryrefslogtreecommitdiffabout
authorSergey Poznyakoff <gray@gnu.org.ua>2019-08-28 11:06:29 (GMT)
committer Sergey Poznyakoff <gray@gnu.org.ua>2019-08-28 16:23:06 (GMT)
commit2be036c82a4d212152af6318eb1bcc749c565db7 (patch) (side-by-side diff)
tree2c465e6aeeb9d5ad88bba8a2d8c3c836f6c7b6ad
parent3c83bbc82caed02633492928900a480dedcbdd10 (diff)
downloadconfig-ast-2be036c82a4d212152af6318eb1bcc749c565db7.tar.gz
config-ast-2be036c82a4d212152af6318eb1bcc749c565db7.tar.bz2
Re-implement case-insensitive lookups
* lib/Config/AST.pm (new): Use the lexicon method to store the new lexicon. Create the root node. (root,mangle_key): New method. (lexicon): Deep-copy the passed lexicon and preprocess its keys using the _clone_lexicon method. (_clone_lexicon): Auxiliary method for lexicon. (describe_keyword): New method. (all methods): Pass the "$self" argument to the Config::AST::Node::Section constructor calls. (add_node): Preprocess key names using mangle_key. (DESTROY): Destroy the tree to break circular references. * lib/Config/AST/Root.pm: New file. * lib/Config/AST/Node/Section.pm (new): First argument is mandatory: a reference to the root node or the owning Config::AST object. (is_leaf,is_section): Provide definitions. (root): New method. (subtree): Use root->mangle_key to prepare the lookup key. * lib/Config/AST/Node.pm (is_section): Return 0 * lib/Config/AST/Node/Value.pm: Likewise. * t/02conf01.t: The "root" name is now reserved and cannot be used in direct addressing. * t/02merge.t: Pass obligatory argument to the Config::AST::Node::Section constructor. * lib/Config/AST/Follow.pm: Use L<> for cross-references. * lib/Config/AST/Node/Null.pm: Likewise.
Diffstat (more/less context) (ignore whitespace changes)
-rw-r--r--lib/Config/AST.pm144
-rw-r--r--lib/Config/AST/Follow.pm6
-rw-r--r--lib/Config/AST/Node.pm10
-rw-r--r--lib/Config/AST/Node/Null.pm4
-rw-r--r--lib/Config/AST/Node/Section.pm33
-rw-r--r--lib/Config/AST/Node/Value.pm6
-rw-r--r--lib/Config/AST/Root.pm101
-rw-r--r--t/01conf01.t1
-rw-r--r--t/02conf01.t10
-rw-r--r--t/02merge.t4
10 files changed, 263 insertions, 56 deletions
diff --git a/lib/Config/AST.pm b/lib/Config/AST.pm
index 4020387..c279e2f 100644
--- a/lib/Config/AST.pm
+++ b/lib/Config/AST.pm
@@ -24,6 +24,7 @@ use Config::AST::Node qw(:sort);
use Config::AST::Node::Section;
use Config::AST::Node::Value;
use Config::AST::Follow;
+use Config::AST::Root;
use Data::Dumper;
require Exporter;
@@ -299,31 +300,39 @@ sub new {
local %_ = @_;
my $self = bless { _order => 0 }, $class;
my $v;
- my $err;
$self->{_debug} = delete $_{debug} || 0;
- $self->{_ci} = delete $_{ci} || 0;
+ $self->{_root} = new Config::AST::Root(delete $_{ci} || 0);
if (defined($v = delete $_{lexicon})) {
- if (ref($v) eq 'HASH') {
- $self->{_lexicon} = $v;
- } else {
- carp "lexicon must refer to a HASH";
- ++$err;
- }
+ $self->lexicon($v);
}
+ croak "unrecognized parameters" if keys(%_);
- if (keys(%_)) {
- foreach my $k (keys %_) {
- carp "unknown parameter $k"
- }
- ++$err;
- }
- croak "can't create configuration instance" if $err;
$self->reset;
return $self;
}
+=head2 $node = $cfg->root
+
+Returns the root node of the tree, initializing it if necessary.
+
+=cut
+
+sub root { shift->{_root} }
+
+=head2 $s = $r->mangle_key($name)
+
+Converts the string I<$name> to a form suitable for lookups, in accordance
+with the B<ci> parameter passed to the constructor.
+
+=cut
+
+sub mangle_key {
+ my ($self, $key) = @_;
+ return $self->root->mangle_key($key);
+}
+
=head2 $cfg->lexicon($hashref)
Returns current lexicon. If B<$hashref> is supplied, installs it as a
@@ -338,11 +347,70 @@ sub lexicon {
carp "too many arguments" if @_;
carp "lexicon must refer to a HASH" unless ref($lexicon) eq 'HASH';
$self->reset;
- $self->{_lexicon} = $lexicon;
+ $self->_clone_lexicon($lexicon);
}
return $self->{_lexicon};
}
+sub _clone_lexicon {
+ my ($self, $source_lex) = @_;
+ my @stk;
+ $self->{_lexicon} = {};
+ push @stk, [ $source_lex, $self->{_lexicon}, \&mangle_key ];
+ while (my $elt = pop @stk) {
+ while (my ($k, $v) = each %{$elt->[0]}) {
+ if ($elt->[2]) {
+ $k = $self->${\$elt->[2]}($k);
+ }
+
+ my $copy;
+ if (ref($v) eq 'HASH') {
+ $copy = {};
+ push @stk, [ $v, $copy,
+ (!$elt->[2] && $k eq 'section')
+ ? \&mangle_key : undef ];
+ } else {
+ $copy = $v;
+ }
+ $elt->[1]{$k} = $copy;
+ }
+ }
+}
+
+=head2 $cfg->describe_keyword(@path)
+
+Returns a lexicon entry for the statement at I<@path>. If no such
+statement is defined, returns undef.
+
+=cut
+
+sub describe_keyword {
+ my $self = shift;
+ my $lex = $self->lexicon;
+ return '*' unless $lex;
+ while (my $k = shift @_) {
+ $k = $self->mangle_key($k);
+ if (my $next = (ref($lex) eq 'HASH'
+ ? $lex->{$k} // $lex->{'*'}
+ : (($lex eq '*') ? $lex : undef))) {
+ $lex = $next;
+ if (ref($lex) eq 'HASH') {
+ if ($next = $lex->{section}) {
+ $lex = $next if @_;
+ next;
+ }
+ } elsif ($lex eq '*') {
+ next;
+ }
+ last;
+ } else {
+ return;
+ }
+ }
+ return if @_;
+ return $lex;
+}
+
=head1 PARSING
This module provides a framework for parsing, but does not implement parsers
@@ -449,6 +517,7 @@ sub fixup_tree {
: $d->{default};
if (exists($d->{section})) {
$n = new Config::AST::Node::Section(
+ $self,
default => 1,
subtree => $dfl
);
@@ -475,7 +544,8 @@ sub fixup_tree {
}
}
} else {
- my $node = new Config::AST::Node::Section;
+ my $node =
+ new Config::AST::Node::Section($self);
$self->fixup_tree($node, $d->{section}, @path, $k);
if ($node->keys > 0) {
# If the newly created node contains any subnodes
@@ -500,7 +570,7 @@ sub fixup_tree {
my $node;
unless ($node = $section->subtree($k)) {
- $node = new Config::AST::Node::Section;
+ $node = new Config::AST::Node::Section($self);
}
if ((!exists($d->{select})
|| $self->${ \ $d->{select} }($node, @path, $k))) {
@@ -536,7 +606,9 @@ for parsing another file.
sub reset {
my $self = shift;
$self->{_error_count} = 0;
- delete $self->{_tree};
+ if ($self->root) {
+ $self->root->reset;
+ }
}
=head1 METHODS
@@ -616,10 +688,11 @@ returns C<undef>.
sub getnode {
my $self = shift;
-
- my $node = $self->{_tree} or return undef;
+
+ return undef if $self->root->empty;
+ my $node = $self->root->tree;
for (@_) {
- $node = $node->subtree($self->{_ci} ? lc($_) : $_)
+ $node = $node->subtree($_)
or return undef;
}
return $node;
@@ -685,10 +758,7 @@ sub is_variable {
=cut
-sub tree {
- my $self = shift;
- return $self->{_tree} //= new Config::AST::Node::Section(locus => new Text::Locus);
-}
+sub tree { shift->root->tree }
=head2 $cfg->subtree(@path)
@@ -760,7 +830,10 @@ sub AUTOLOAD {
return Config::AST::Follow->new($self->tree, $self->lexicon)->${\$m};
}
-sub DESTROY { }
+sub DESTROY {
+ my $self = shift;
+ $self->root->reset if $self->root;
+}
=head1 CONSTRUCTING THE SYNTAX TREE
@@ -826,7 +899,7 @@ sub add_node {
my $name;
my $locus = $node->locus;
for (my $i = 0; $i < $pn; $i++) {
- $name = ${$path}[$i];
+ $name = $self->mangle_key(${$path}[$i]);
unless ($tree->is_section) {
$self->error(join('.', @{$path}[0..$i]) . ": not a section");
@@ -846,13 +919,14 @@ sub add_node {
} else {
$tree = $tree->subtree(
$name => new Config::AST::Node::Section(
+ $self,
order => $self->{_order}++,
locus => $locus->clone)
);
}
}
- $name = ${$path}[-1];
+ $name = $self->mangle_key(${$path}[-1]);
my $x = $kw->{$name} // $kw->{'*'};
if (!defined($x)) {
@@ -968,8 +1042,8 @@ sub set {
$node = $n;
} else {
$node = $node->subtree(
- $arg => new Config::AST::Node::Section
- );
+ $arg => new Config::AST::Node::Section($self)
+ );
}
}
@@ -992,7 +1066,8 @@ Unsets the configuration variable.
sub unset {
my $self = shift;
- my $node = $self->{_tree} or return;
+ return if $self->root->empty;
+ my $node = $self->root->tree;
my @path;
for (@_) {
@@ -1241,10 +1316,11 @@ sub lint {
=head1 SEE ALSO
-B<Config::AST::Node>.
+L<Config::AST::Node>.
-B<Config::Parser>.
+L<Config::Parser>.
=cut
+
1;
diff --git a/lib/Config/AST/Follow.pm b/lib/Config/AST/Follow.pm
index 4d996a5..cf05e34 100644
--- a/lib/Config/AST/Follow.pm
+++ b/lib/Config/AST/Follow.pm
@@ -53,7 +53,7 @@ within a particular section.
=head1 SEE ALSO
-B<Config::AST>(3).
+L<Config::AST>(3).
=cut
@@ -81,6 +81,8 @@ sub AUTOLOAD {
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})) {
@@ -109,7 +111,7 @@ sub AUTOLOAD {
}
if (!$self->{_node}->is_null) {
- my $next = $self->{_node}->subtree($self->{_ci} ? lc($key) : $key)
+ my $next = $self->{_node}->subtree($key)
// new Config::AST::Node::Null;
return $next if $next->is_leaf || !$lex;
$self->{_node} = $next;
diff --git a/lib/Config/AST/Node.pm b/lib/Config/AST/Node.pm
index 131bc41..06da6db 100644
--- a/lib/Config/AST/Node.pm
+++ b/lib/Config/AST/Node.pm
@@ -182,7 +182,7 @@ Returns true if node represents a section.
=cut
-sub is_section { ! shift->is_leaf }
+sub is_section { 0 }
=head2 $node->is_value
@@ -337,10 +337,10 @@ use overload
=head1 SEE ALSO
-B<Config::AST>,
-B<Config::AST::Node::Null>,
-B<Config::AST::Node::Value>,
-B<Config::AST::Node::Section>.
+L<Config::AST>,
+L<Config::AST::Node::Null>,
+L<Config::AST::Node::Value>,
+L<Config::AST::Node::Section>.
=cut
diff --git a/lib/Config/AST/Node/Null.pm b/lib/Config/AST/Node/Null.pm
index 699d49f..41242b1 100644
--- a/lib/Config/AST/Node/Null.pm
+++ b/lib/Config/AST/Node/Null.pm
@@ -79,8 +79,8 @@ use overload
=head1 SEE ALSO
-B<Config::AST>,
-B<Config::AST::Node>.
+L<Config::AST>,
+L<Config::AST::Node>.
=cut
diff --git a/lib/Config/AST/Node/Section.pm b/lib/Config/AST/Node/Section.pm
index 3343d95..4a825ab 100644
--- a/lib/Config/AST/Node/Section.pm
+++ b/lib/Config/AST/Node/Section.pm
@@ -31,24 +31,51 @@ Nodes of this class represent configuration sections in the AST.
=head1 METHODS
+=head2 new(ROOT, ARG => VAL, ...)
+
+Creates new section object. I<ROOT> is the root object of the tree or the
+B<Config::AST> object. The I<ARG =E<gt> VAL> pairs are passed to
+the parent class constructor (see B<Config::AST::Node>).
+
=cut
sub new {
my $class = shift;
- my $self = $class->SUPER::new(@_);
+ my $root = shift or croak "mandatory parameter missing";
+ local %_ = @_;
+ my $self = $class->SUPER::new(%_);
$self->{_subtree} = {};
+ if ($root->isa('Config::AST')) {
+ $root = $root->root;
+ }
+ $self->{_root} = $root;
return $self;
}
+sub is_leaf { 0 }
+sub is_section { 1 }
+
+sub root { shift->{_root} }
+
=head2 $t = $node->subtree
Returns tree containing all subordinate nodes of this node.
+=head2 $t = $node->subtree($key)
+
+Returns the subnode at I<$key> or B<undef> if there is no such subnode.
+
+=head2 $t = $node->subtree($key => $value)
+
+Creates new subnode with the given I<$key> and I<$value>. Returns the
+created node.
+
=cut
sub subtree {
my $self = shift;
if (my $key = shift) {
+ $key = $self->root->mangle_key($key);
if (my $val = shift) {
$self->{_subtree}{$key} = $val;
}
@@ -182,8 +209,8 @@ sub as_string { '(section)' }
=head1 SEE ALSO
-B<Config::AST>,
-B<Config::AST::Node>.
+L<Config::AST>,
+L<Config::AST::Node>.
=cut
diff --git a/lib/Config/AST/Node/Value.pm b/lib/Config/AST/Node/Value.pm
index 764c1b7..80da83e 100644
--- a/lib/Config/AST/Node/Value.pm
+++ b/lib/Config/AST/Node/Value.pm
@@ -87,6 +87,8 @@ Returns false.
sub is_leaf { 1 };
+sub is_section { 0 }
+
=head2 $s = $node->as_string
Returns the node value, converted to string.
@@ -158,8 +160,8 @@ use overload
=head1 SEE ALSO
-B<Config::AST>,
-B<Config::AST::Node>.
+L<Config::AST>,
+L<Config::AST::Node>.
=cut
diff --git a/lib/Config/AST/Root.pm b/lib/Config/AST/Root.pm
new file mode 100644
index 0000000..e0a6da8
--- a/dev/null
+++ b/lib/Config/AST/Root.pm
@@ -0,0 +1,101 @@
+# 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::Root;
+use strict;
+use warnings;
+
+=head1 NAME
+
+Config::AST::Root - root of the abstract syntax tree
+
+=head1 DESCRIPTION
+
+An auxiliary class representing the root of the abstract syntax tree.
+It is necessary because the tree itself forms a circular structure
+(due to the B<root> attribute of B<Config::AST::Node::Section>). Without
+this intermediate class (if B<root> pointed to B<Config::AST> itself),
+the structure would have never been destroyed, because each element
+would remain referenced at least once.
+
+=head1 CONSTRUCTOR
+
+=head2 $obj = new($ci)
+
+I<$ci> is one to enable case-insensitive keyword lookup, and 0 otherwise.
+
+=cut
+
+sub new {
+ my ($class, $ci) = @_;
+ bless { _ci => $ci }, $class;
+}
+
+=head1 METHODS
+
+=head2 $s = $r->mangle_key($name)
+
+Converts the string I<$name> to a form suitable for lookups, in accordance
+with the _ci attribute.
+
+=cut
+
+sub mangle_key {
+ my ($self, $key) = @_;
+ $self->{_ci} ? lc($key) : $key;
+}
+
+=head2 $r->reset
+
+Destroys the underlying syntax tree.
+
+=cut
+
+sub reset { delete shift->{_tree} }
+
+
+=head2 $t = $r->tree
+
+Returns the root node of the tree, initializing it if necessary.
+
+=cut
+
+sub tree {
+ my $self = shift;
+
+ return $self->{_tree} //=
+ new Config::AST::Node::Section($self,
+ locus => new Text::Locus);
+}
+
+=head2 $bool = $r->empty
+
+Returns true if the tree is empty.
+
+=cut
+
+sub empty {
+ my $self = shift;
+ return !($self->{_tree} && $self->{_tree}->keys > 0);
+}
+
+=head1 SEE ALSO
+
+L<Config::AST>.
+
+=cut
+
+1;
diff --git a/t/01conf01.t b/t/01conf01.t
index 5c91f7f..db307b7 100644
--- a/t/01conf01.t
+++ b/t/01conf01.t
@@ -15,4 +15,3 @@ my $cfg = new TestConfig(
);
ok($cfg->canonical, 'backend.foo.file="a" core.retain-interval=10 core.tempdir="/tmp"');
-
diff --git a/t/02conf01.t b/t/02conf01.t
index 8176df8..b7becb7 100644
--- a/t/02conf01.t
+++ b/t/02conf01.t
@@ -10,8 +10,8 @@ my $t = new TestConfig(
config => [
base => '/etc',
'file.passwd.mode' => '0644',
- 'file.passwd.root.uid' => 0,
- 'file.passwd.root.dir' => '/root',
+ 'file.passwd.main.uid' => 0,
+ 'file.passwd.main.dir' => '/root',
],
lexicon => {
base => 1,
@@ -20,7 +20,7 @@ my $t = new TestConfig(
passwd => {
section => {
mode => 1,
- root => {
+ main => {
section => {
uid => 1,
dir => 1
@@ -46,8 +46,8 @@ ok($t->base->is_leaf);
ok($t->base, '/etc');
ok($t->file->is_section);
ok($t->file->passwd->is_section);
-ok($t->file->passwd->root->dir);
-ok($t->file->passwd->root->dir,'/root');
+ok($t->file->passwd->main->dir);
+ok($t->file->passwd->main->dir,'/root');
ok($t->file->skel->is_null);
eval { $t->nonexistent };
ok($@ =~ m{Can't locate object method "nonexistent" via package "Config::AST::Follow"});
diff --git a/t/02merge.t b/t/02merge.t
index 5d3168c..f112271 100644
--- a/t/02merge.t
+++ b/t/02merge.t
@@ -16,7 +16,7 @@ my $t = new Config::AST(
}
});
-my $node = new Config::AST::Node::Section;
+my $node = new Config::AST::Node::Section($t);
$node->subtree(number => new Config::AST::Node::Value(
value => [1],
locus => new Text::Locus('input',1)));
@@ -25,7 +25,7 @@ $node->subtree(name => new Config::AST::Node::Value(
locus => new Text::Locus('input',2)));
$t->add_node(x => $node);
-$node = new Config::AST::Node::Section;
+$node = new Config::AST::Node::Section($t);
$node->subtree(number => new Config::AST::Node::Value(
value => 2,
locus => new Text::Locus('input',3)));

Return to:

Send suggestions and report system problems to the System administrator.