summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergey Poznyakoff <gray@gnu.org.ua>2019-08-28 14:06:29 +0300
committerSergey Poznyakoff <gray@gnu.org.ua>2019-08-28 19:23:06 +0300
commit2be036c82a4d212152af6318eb1bcc749c565db7 (patch)
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.
-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
@@ -21,12 +21,13 @@ use warnings;
use Carp;
use Text::Locus;
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;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ( 'sort' => [ qw(NO_SORT SORT_NATURAL SORT_PATH) ] );
our @EXPORT_OK = qw(NO_SORT SORT_NATURAL SORT_PATH);
@@ -296,37 +297,45 @@ means "any settings and any subsections are allowed".
sub new {
my $class = shift;
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
new lexicon.
=cut
@@ -335,17 +344,76 @@ sub lexicon {
my $self = shift;
if (@_) {
my $lexicon = shift;
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
for any particular configuration formats. To implement a parser, the programmer
must write a class that inherits from B<Config::AST>. This class should
implement the B<parse> method which, when called, will actually perform the
@@ -446,12 +514,13 @@ sub fixup_tree {
my $n;
my $dfl = ref($d->{default}) eq 'CODE'
? sub { $self->${ \ $d->{default} } }
: $d->{default};
if (exists($d->{section})) {
$n = new Config::AST::Node::Section(
+ $self,
default => 1,
subtree => $dfl
);
} else {
$n = new Config::AST::Node::Value(
default => 1,
@@ -472,13 +541,14 @@ sub fixup_tree {
} elsif ($vref->is_section) {
$self->fixup_tree($vref, $d->{section},
@path, $name);
}
}
} 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
# after fixup, they were created because syntax
# contained mandatory variables with default values.
# Treat sections containing such variables as
@@ -497,13 +567,13 @@ sub fixup_tree {
}
}
} else {
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))) {
$self->fixup_tree($node, $d->{section}, @path, $k);
}
if ($node->keys > 0) {
@@ -533,13 +603,15 @@ for parsing another file.
=cut
sub reset {
my $self = shift;
$self->{_error_count} = 0;
- delete $self->{_tree};
+ if ($self->root) {
+ $self->root->reset;
+ }
}
=head1 METHODS
=head2 $cfg->error($message)
@@ -613,16 +685,17 @@ Retrieves the AST node referred to by B<@path>. If no such node exists,
returns C<undef>.
=cut
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;
}
=head2 $var = $cfg->get(@path);
@@ -682,16 +755,13 @@ sub is_variable {
=head2 $cfg->tree
Returns the parse tree.
=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)
Returns the configuration subtree associated with the statement indicated by
B<@path>.
@@ -757,13 +827,16 @@ sub AUTOLOAD {
my ($p, $m) = ($1, $2);
croak "Can't locate object method \"$m\" via package \"$p\""
if @_ || !$self->lexicon;
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
The methods described in this section are intended for use by the parser
implementers. They should be called from the implementation of the B<parse>
method in order to construct the tree.
@@ -823,13 +896,13 @@ sub add_node {
my $kw = $self->{_lexicon} // { '*' => '*' };
my $tree = $self->tree;
my $pn = $#{$path};
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");
$self->{_error_count}++;
return;
}
@@ -843,19 +916,20 @@ sub add_node {
if (my $subtree = $tree->subtree($name)) {
$tree = $subtree;
} 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)) {
$self->error("keyword \"$name\" is unknown", locus => $locus);
$self->{_error_count}++;
return;
@@ -965,14 +1039,14 @@ sub set {
croak "not a section" unless $node->is_section;
my $arg = shift;
if (my $n = $node->subtree($arg)) {
$node = $n;
} else {
$node = $node->subtree(
- $arg => new Config::AST::Node::Section
- );
+ $arg => new Config::AST::Node::Section($self)
+ );
}
}
my $v = $node->subtree($_[0]) ||
$node->subtree($_[0] => new Config::AST::Node::Value(
order => $self->{_order}++
@@ -989,13 +1063,14 @@ Unsets the configuration variable.
=cut
sub unset {
my $self = shift;
- my $node = $self->{_tree} or return;
+ return if $self->root->empty;
+ my $node = $self->root->tree;
my @path;
for (@_) {
return unless $node->is_section && $node->has_key($_);
push @path, [ $node, $_ ];
$node = $node->subtree($_);
@@ -1238,13 +1313,14 @@ sub lint {
my ($self, $lexicon) = @_;
return $self->commit(lint => 1, lexicon => $lexicon);
}
=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
@@ -50,13 +50,13 @@ is equivalent to
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).
+L<Config::AST>(3).
=cut
sub new {
my ($class, $node, $lex) = @_;
bless { _node => $node, _lex => $lex }, $class;
@@ -78,12 +78,14 @@ sub AUTOLOAD {
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->{'*'};
@@ -106,13 +108,13 @@ sub AUTOLOAD {
$lex = $lex->{section};
} else {
$lex = undef;
}
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;
}
$self->{_lex} = $lex;
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
@@ -179,13 +179,13 @@ sub is_null { 0 }
=head2 $node->is_section
Returns true if node represents a section.
=cut
-sub is_section { ! shift->is_leaf }
+sub is_section { 0 }
=head2 $node->is_value
Returns true if node represents a value (or statement).
=cut
@@ -334,16 +334,16 @@ use overload
my ($self,$other) = @_;
return $self->as_string eq $other
};
=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
1;
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
@@ -76,12 +76,12 @@ use overload
bool => \&value,
'0+' => \&value,
fallback => 1;
=head1 SEE ALSO
-B<Config::AST>,
-B<Config::AST::Node>.
+L<Config::AST>,
+L<Config::AST::Node>.
=cut
1;
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
@@ -28,30 +28,57 @@ Config::AST::Node::Section - Configuration section node.
=head1 DESCRIPTION
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;
}
return $self->{_subtree}{$key};
}
return $self->{_subtree};
@@ -179,12 +206,12 @@ Returns the string "(section)".
=cut
sub as_string { '(section)' }
=head1 SEE ALSO
-B<Config::AST>,
-B<Config::AST::Node>.
+L<Config::AST>,
+L<Config::AST::Node>.
=cut
1;
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
@@ -84,12 +84,14 @@ sub value {
Returns false.
=cut
sub is_leaf { 1 };
+sub is_section { 0 }
+
=head2 $s = $node->as_string
Returns the node value, converted to string.
=cut
@@ -155,12 +157,12 @@ use overload
},
fallback => 1;
=head1 SEE ALSO
-B<Config::AST>,
-B<Config::AST::Node>.
+L<Config::AST>,
+L<Config::AST::Node>.
=cut
1;
diff --git a/lib/Config/AST/Root.pm b/lib/Config/AST/Root.pm
new file mode 100644
index 0000000..e0a6da8
--- /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
@@ -12,7 +12,6 @@ my $cfg = new TestConfig(
'core.tempdir' => '/tmp',
'backend.foo.file' => 'a'
]
);
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
@@ -7,23 +7,23 @@ use TestConfig;
plan(tests => 9);
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,
file => {
section => {
passwd => {
section => {
mode => 1,
- root => {
+ main => {
section => {
uid => 1,
dir => 1
}
},
}
@@ -43,12 +43,12 @@ my $t = new TestConfig(
});
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"});
ok($t->other->x->y->is_null);
diff --git a/t/02merge.t b/t/02merge.t
index 5d3168c..f112271 100644
--- a/t/02merge.t
+++ b/t/02merge.t
@@ -13,22 +13,22 @@ my $t = new Config::AST(
number => { array => 1 },
name => 1
}
}
});
-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)));
$node->subtree(name => new Config::AST::Node::Value(
value => 'foo',
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)));
$node->subtree(name => new Config::AST::Node::Value(
value => 'bar',
locus => new Text::Locus('input',4)));

Return to:

Send suggestions and report system problems to the System administrator.