diff options
author | Sergey Poznyakoff <gray@gnu.org.ua> | 2019-08-28 14:06:29 +0300 |
---|---|---|
committer | Sergey Poznyakoff <gray@gnu.org.ua> | 2019-08-28 19:23:06 +0300 |
commit | 2be036c82a4d212152af6318eb1bcc749c565db7 (patch) | |
tree | 2c465e6aeeb9d5ad88bba8a2d8c3c836f6c7b6ad | |
parent | 3c83bbc82caed02633492928900a480dedcbdd10 (diff) | |
download | config-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.pm | 144 | ||||
-rw-r--r-- | lib/Config/AST/Follow.pm | 6 | ||||
-rw-r--r-- | lib/Config/AST/Node.pm | 10 | ||||
-rw-r--r-- | lib/Config/AST/Node/Null.pm | 4 | ||||
-rw-r--r-- | lib/Config/AST/Node/Section.pm | 33 | ||||
-rw-r--r-- | lib/Config/AST/Node/Value.pm | 6 | ||||
-rw-r--r-- | lib/Config/AST/Root.pm | 101 | ||||
-rw-r--r-- | t/01conf01.t | 1 | ||||
-rw-r--r-- | t/02conf01.t | 10 | ||||
-rw-r--r-- | t/02merge.t | 4 |
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))); |