From 2be036c82a4d212152af6318eb1bcc749c565db7 Mon Sep 17 00:00:00 2001 From: Sergey Poznyakoff Date: Wed, 28 Aug 2019 14:06:29 +0300 Subject: 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. --- lib/Config/AST.pm | 144 +++++++++++++++++++++++++++++++---------- lib/Config/AST/Follow.pm | 6 +- lib/Config/AST/Node.pm | 10 +-- lib/Config/AST/Node/Null.pm | 4 +- lib/Config/AST/Node/Section.pm | 33 +++++++++- lib/Config/AST/Node/Value.pm | 6 +- lib/Config/AST/Root.pm | 101 +++++++++++++++++++++++++++++ t/01conf01.t | 1 - t/02conf01.t | 10 +-- t/02merge.t | 4 +- 10 files changed, 263 insertions(+), 56 deletions(-) create mode 100644 lib/Config/AST/Root.pm 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 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. 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. +L. -B. +L. =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(3). +L(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, -B, -B, -B. +L, +L, +L, +L. =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, -B. +L, +L. =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 is the root object of the tree or the +B object. The I VAL> pairs are passed to +the parent class constructor (see B). + =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 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, -B. +L, +L. =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, -B. +L, +L. =cut 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 +# +# 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 . + +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 attribute of B). Without +this intermediate class (if B pointed to B 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. + +=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))); -- cgit v1.2.1