This is an automated email from the git hooks/post-receive script.
dod pushed a commit to annotated tag upstream/2.095
in repository libconfig-model-perl.
commit db7a25a3252eb67226f2e0ff7323b738bf5cf1f3
Author: Dominique Dumont <d...@debian.org>
Date: Tue Dec 6 19:00:57 2016 +0100
New upstream version 2.095
---
Build.PL | 5 +-
Changes | 16 +
MANIFEST | 4 +
META.json | 13 +-
META.yml | 9 +-
README.md | 6 +
lib/Config/Model.pm | 6 +-
lib/Config/Model/Annotation.pm | 16 +-
lib/Config/Model/AnyId.pm | 18 +-
lib/Config/Model/AnyThing.pm | 457 +------------------
lib/Config/Model/Backend/Any.pm | 4 +-
lib/Config/Model/Backend/Fstab.pm | 4 +-
lib/Config/Model/Backend/IniFile.pm | 4 +-
lib/Config/Model/Backend/Json.pm | 4 +-
lib/Config/Model/Backend/PlainFile.pm | 4 +-
lib/Config/Model/Backend/ShellVar.pm | 4 +-
lib/Config/Model/Backend/Yaml.pm | 4 +-
lib/Config/Model/BackendMgr.pm | 22 +-
lib/Config/Model/CheckList.pm | 8 +-
lib/Config/Model/Cookbook/CreateModelFromDoc.pod | 2 +-
lib/Config/Model/Describe.pm | 4 +-
lib/Config/Model/DumpAsData.pm | 4 +-
lib/Config/Model/Dumper.pm | 4 +-
lib/Config/Model/Exception.pm | 46 +-
lib/Config/Model/FuseUI.pm | 4 +-
lib/Config/Model/HashId.pm | 45 +-
lib/Config/Model/IdElementReference.pm | 6 +-
lib/Config/Model/Instance.pm | 11 +-
lib/Config/Model/Iterator.pm | 4 +-
lib/Config/Model/ListId.pm | 6 +-
lib/Config/Model/Lister.pm | 4 +-
lib/Config/Model/Loader.pm | 86 +++-
lib/Config/Model/Manual/ModelCreationAdvanced.pod | 2 +-
.../Model/Manual/ModelCreationIntroduction.pod | 2 +-
lib/Config/Model/Node.pm | 26 +-
lib/Config/Model/ObjTreeScanner.pm | 4 +-
lib/Config/Model/Report.pm | 8 +-
lib/Config/Model/{AnyThing.pm => Role/Grab.pm} | 507 ++-------------------
lib/Config/Model/Role/HelpAsText.pm | 97 ++++
lib/Config/Model/Role/NodeLoader.pm | 4 +-
lib/Config/Model/Role/WarpMaster.pm | 4 +-
lib/Config/Model/SearchElement.pm | 4 +-
lib/Config/Model/SimpleUI.pm | 14 +-
lib/Config/Model/TermUI.pm | 4 +-
lib/Config/Model/TreeSearcher.pm | 6 +-
lib/Config/Model/Utils/GenClassPod.pm | 4 +-
lib/Config/Model/Value.pm | 6 +-
lib/Config/Model/Value/LayeredInclude.pm | 4 +-
lib/Config/Model/ValueComputer.pm | 8 +-
lib/Config/Model/WarpedNode.pm | 12 +-
lib/Config/Model/Warper.pm | 10 +-
t/annotation.t | 26 +-
t/backend_mgr.t | 106 +++--
t/dump_load_model.pm | 7 +
t/hash_id_of_values.t | 10 +
t/load.t | 9 +
.../multi-ini-examples/max-overflow/etc/bar.conf | 1 +
t/model_tests.d/multi-ini-test-conf.pl | 71 +++
58 files changed, 642 insertions(+), 1148 deletions(-)
diff --git a/Build.PL b/Build.PL
index afc6bc2..6e95fbe 100644
--- a/Build.PL
+++ b/Build.PL
@@ -69,6 +69,7 @@ my $build = $class->new(
'build_requires' => {
'Config::Model::Tester' => '2.053',
'Module::Build' => '0.34',
+ 'Path::Tiny' => '0.070',
'Test::Differences' => '0',
'Test::Exception' => '0',
'Test::File::Contents' => '0',
@@ -110,8 +111,10 @@ my $build = $class->new(
'MouseX::StrictConstructor' => '0',
'POSIX' => '0',
'Parse::RecDescent' => 'v1.90.0',
- 'Path::Tiny' => '0',
+ 'Path::Tiny' => '0.070',
'Pod::POM' => '0',
+ 'Pod::Simple' => '3.23',
+ 'Pod::Text' => '0',
'Scalar::Util' => '0',
'Storable' => '0',
'Text::Diff' => '0',
diff --git a/Changes b/Changes
index 16ecf0a..a43c95c 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,19 @@
+2.095 2016-12-06
+
+ New feature usable by cme:
+ * loader: add .insort() command for hash element
+ * Hash element: add insort method
+
+ Term UI improvement
+ * better format the output of 'desc' command (transform
+ pod doc to text). This requires Pod::Text and
+ Pod::Simple 3.23
+
+ Bug fix:
+ * track and save annotation changes (gh #12)
+ * Node: propagate check override in init() (which fixes
+ loading of a systemd config that contains an error)
+
2.094 2016-11-09
Fix compatibility with older Term::ReadLine::Gnu:
diff --git a/MANIFEST b/MANIFEST
index 29518f4..54dac94 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -44,6 +44,8 @@ lib/Config/Model/Manual/ModelCreationIntroduction.pod
lib/Config/Model/Node.pm
lib/Config/Model/ObjTreeScanner.pm
lib/Config/Model/Report.pm
+lib/Config/Model/Role/Grab.pm
+lib/Config/Model/Role/HelpAsText.pm
lib/Config/Model/Role/NodeLoader.pm
lib/Config/Model/Role/WarpMaster.pm
lib/Config/Model/SearchElement.pm
@@ -122,6 +124,8 @@ t/model_tests.d/fstab-test-conf.pl
t/model_tests.d/layer-examples/mini/etc/foo-config.pl
t/model_tests.d/layer-examples/mini/home/joe/foo/config.pl
t/model_tests.d/layer-test-conf.pl
+t/model_tests.d/multi-ini-examples/max-overflow/etc/bar.conf
+t/model_tests.d/multi-ini-test-conf.pl
t/model_tests.d/multistrap-examples/arm/home/foo/my_arm.conf
t/model_tests.d/multistrap-examples/arm/usr/share/multistrap/crosschroot.conf
t/model_tests.d/multistrap-examples/from_scratch/usr/share/multistrap/crosschroot.conf
diff --git a/META.json b/META.json
index 1e308ff..00009de 100644
--- a/META.json
+++ b/META.json
@@ -4,13 +4,13 @@
"Dominique Dumont"
],
"dynamic_config" : 0,
- "generated_by" : "Dist::Zilla version 6.008, CPAN::Meta::Converter version
2.150010",
+ "generated_by" : "Dist::Zilla version 6.008, CPAN::Meta::Converter version
2.150005",
"license" : [
"lgpl_2_1"
],
"meta-spec" : {
"url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec";,
- "version" : 2
+ "version" : "2"
},
"name" : "Config-Model",
"prereqs" : {
@@ -56,8 +56,10 @@
"MouseX::StrictConstructor" : "0",
"POSIX" : "0",
"Parse::RecDescent" : "v1.90.0",
- "Path::Tiny" : "0",
+ "Path::Tiny" : "0.070",
"Pod::POM" : "0",
+ "Pod::Simple" : "3.23",
+ "Pod::Text" : "0",
"Scalar::Util" : "0",
"Storable" : "0",
"Text::Diff" : "0",
@@ -69,6 +71,7 @@
"test" : {
"requires" : {
"Config::Model::Tester" : "2.053",
+ "Path::Tiny" : "0.070",
"Test::Differences" : "0",
"Test::Exception" : "0",
"Test::File::Contents" : "0",
@@ -91,7 +94,7 @@
"web" : "http://github.com/dod38fr/config-model";
}
},
- "version" : "2.094",
- "x_serialization_backend" : "Cpanel::JSON::XS version 3.022"
+ "version" : "2.095",
+ "x_serialization_backend" : "JSON::XS version 3.03"
}
diff --git a/META.yml b/META.yml
index b785367..ddae9fc 100644
--- a/META.yml
+++ b/META.yml
@@ -5,6 +5,7 @@ author:
build_requires:
Config::Model::Tester: '2.053'
Module::Build: '0.34'
+ Path::Tiny: '0.070'
Test::Differences: '0'
Test::Exception: '0'
Test::File::Contents: '0'
@@ -15,7 +16,7 @@ build_requires:
configure_requires:
Module::Build: '0.34'
dynamic_config: 0
-generated_by: 'Dist::Zilla version 6.008, CPAN::Meta::Converter version
2.150010'
+generated_by: 'Dist::Zilla version 6.008, CPAN::Meta::Converter version
2.150005'
license: lgpl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -50,8 +51,10 @@ requires:
MouseX::StrictConstructor: '0'
POSIX: '0'
Parse::RecDescent: v1.90.0
- Path::Tiny: '0'
+ Path::Tiny: '0.070'
Pod::POM: '0'
+ Pod::Simple: '3.23'
+ Pod::Text: '0'
Scalar::Util: '0'
Storable: '0'
Text::Diff: '0'
@@ -62,5 +65,5 @@ resources:
bugtracker: https://github.com/dod38fr/config-model/issues
homepage: https://github.com/dod38fr/config-model/wiki
repository: git://github.com/dod38fr/config-model.git
-version: '2.094'
+version: '2.095'
x_serialization_backend: 'YAML::Tiny version 1.69'
diff --git a/README.md b/README.md
index 2f81091..9163497 100644
--- a/README.md
+++ b/README.md
@@ -1,3 +1,9 @@
+# Config-Model
+
+Configuration schema on steroids.
+
+[](https://travis-ci.org/dod38fr/config-model)
+
# What is Config-Model project
[Config::Model](https://metacpan.org/pod/Config::Model) is:
diff --git a/lib/Config/Model.pm b/lib/Config/Model.pm
index dd68c32..2fb9f36 100644
--- a/lib/Config/Model.pm
+++ b/lib/Config/Model.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model;
-$Config::Model::VERSION = '2.094';
+$Config::Model::VERSION = '2.095';
use strict ;
use warnings;
use 5.10.1;
@@ -1678,7 +1678,7 @@ Config::Model - Create tools to validate, migrate and
edit configuration files
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -2730,7 +2730,7 @@ CPANTS
The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a
distribution.
-L<http://cpants.perl.org/dist/overview/Config-Model>
+L<http://cpants.cpanauthors.org/dist/Config-Model>
=item *
diff --git a/lib/Config/Model/Annotation.pm b/lib/Config/Model/Annotation.pm
index 96430c8..47d3f0b 100644
--- a/lib/Config/Model/Annotation.pm
+++ b/lib/Config/Model/Annotation.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Annotation;
-$Config::Model::Annotation::VERSION = '2.094';
+$Config::Model::Annotation::VERSION = '2.095';
use Mouse;
use English;
@@ -164,7 +164,7 @@ Config::Model::Annotation - Read and write configuration
annotations
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -224,8 +224,12 @@ version 2.094
=head1 DESCRIPTION
This module provides an object that read and write annotations (a bit
-like comments) to and from a configuration tree and save them in a file (not
-configuration file)
+like comments) to and from a configuration tree and save them in a
+file (not configuration file). This module can be used to save
+annotation for configuration files that do not support comments.
+
+THis module should not be used for configuration files that support
+comments.
Depending on the effective id of the process, the annotation is
saved in:
@@ -257,6 +261,10 @@ Save annotations in a file (See L<DESCRIPTION>)
Loads annotations from a file (See L<DESCRIPTION>)
+=head1 CAVEATS
+
+This module is currently not used.
+
=head1 AUTHOR
Dominique Dumont, (ddumont at cpan dot org)
diff --git a/lib/Config/Model/AnyId.pm b/lib/Config/Model/AnyId.pm
index a6e880f..b74845f 100644
--- a/lib/Config/Model/AnyId.pm
+++ b/lib/Config/Model/AnyId.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::AnyId;
-$Config::Model::AnyId::VERSION = '2.094';
+$Config::Model::AnyId::VERSION = '2.095';
use 5.010;
use Mouse;
@@ -24,6 +24,11 @@ use Scalar::Util qw/weaken/;
extends qw/Config::Model::AnyThing/;
+use Mouse::Util::TypeConstraints;
+
+subtype 'KeyArray' => as 'ArrayRef' ;
+coerce 'KeyArray' => from 'Str' => via { [$_] } ;
+
my $logger = get_logger("Tree::Element::Id");
my $deep_check_logger = get_logger('DeepCheck');
my $fix_logger = get_logger("Anything::Fix");
@@ -103,7 +108,12 @@ my @common_hash_params = qw/default_with_init/;
has \@common_hash_params => ( is => 'ro', isa => 'Maybe[HashRef]' );
my @common_list_params = qw/allow_keys default_keys auto_create_keys/;
-has \@common_list_params => ( is => 'ro', isa => 'Maybe[ArrayRef]' );
+has \@common_list_params => (
+ is => 'ro',
+ isa => 'KeyArray',
+ coerce => 1,
+ default => sub { []; }
+);
my @common_str_params = qw/allow_keys_from allow_keys_matching follow_keys_from
migrate_keys_from migrate_values_from
@@ -1001,7 +1011,7 @@ Config::Model::AnyId - Base class for hash or list element
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -1163,7 +1173,7 @@ be used with string index type)
When set, the default parameter (or set of parameters) are used as
default keys hashes and created automatically when the C<keys> or C<exists>
-functions are used on an I<empty> hash..
+functions are used on an I<empty> hash.
You can use C<< default_keys => 'foo' >>,
or C<< default_keys => ['foo', 'bar'] >>.
diff --git a/lib/Config/Model/AnyThing.pm b/lib/Config/Model/AnyThing.pm
index 1678eb5..e43cbaa 100644
--- a/lib/Config/Model/AnyThing.pm
+++ b/lib/Config/Model/AnyThing.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::AnyThing;
-$Config::Model::AnyThing::VERSION = '2.094';
+$Config::Model::AnyThing::VERSION = '2.095';
use Mouse;
# FIXME: must cleanup warp mechanism to implement this
@@ -195,18 +195,22 @@ sub xpath {
sub annotation {
my $self = shift;
- $self->{annotation} = join( "\n", grep ( defined $_, @_ ) )
- if @_
- and not $self->instance->preset
- and not $self->instance->layered;
+ my $old_note = $self->{annotation} || '';
+ if (@_ and not $self->instance->preset and not $self->instance->layered) {
+ my $new = $self->{annotation} = join( "\n", grep ( defined $_, @_ ) );
+ $self->notify_change(note => 'updated annotation') unless $new eq
$old_note;
+ }
+
return $self->{annotation} || '';
}
sub clear_annotation {
my $self = shift;
+ $self->notify_change(note => 'deleted annotation') if $self->{annotation};
$self->{annotation} = '';
}
+# may be used (but not yet) to load annotation from perl data file
sub load_pod_annotation {
my $self = shift;
my $pod = shift;
@@ -230,339 +234,6 @@ sub load_pod_annotation {
}
}
-## Navigation
-
-# accept commands like
-# item:b -> go down a node, create a new node if necessary
-# - climbs up
-# ! climbs up to the top
-
-# Now return an object and not a value !
-
-sub grab {
- my $self = shift;
- my ( $steps, $mode, $autoadd, $type, $grab_non_available, $check ) =
- ( undef, 'strict', 1, undef, 0, 'yes' );
-
- my %args = @_ > 1 ? @_ : ( steps => $_[0] );
-
- $steps = delete $args{steps} // delete $args{step};
- $mode = delete $args{mode} if defined $args{mode};
- $autoadd = delete $args{autoadd} if defined $args{autoadd};
- $grab_non_available = delete $args{grab_non_available}
- if defined $args{grab_non_available};
- $type = delete $args{type}; # node, leaf or
undef
- $check = $self->_check_check( delete $args{check} );
-
- if ( defined $args{strict} ) {
- carp "grab: deprecated parameter 'strict'. Use mode";
- $mode = delete $args{strict} ? 'strict' : 'adaptative';
- }
-
- Config::Model::Exception::User->throw(
- object => $self,
- message => "grab: unexpected parameter: " . join( ' ', keys %args ) )
if %args;
-
- Config::Model::Exception::Internal->throw(
- error => "grab: steps parameter must be a string " . "or an array ref"
)
- unless ref $steps eq 'ARRAY' || not ref $steps;
-
- # accept commands, grep remove empty items left by spurious spaces
- my $huge_string = ref $steps ? join( ' ', @$steps ) : $steps;
- my @command = (
- $huge_string =~ m/
- ( # begin of *one* command
- (?: # group parts of a command (e.g ...:... )
- [^\s"]+ # match anything but a space and a quote
- (?: # begin quoted group
- " # begin of a string
- (?: # begin group
- \\" # match an escaped quote
- | # or
- [^"] # anything but a quote
- )* # lots of time
- " # end of the string
- ) # end of quoted group
- ? # match if I got more than one group
- )+ # can have several parts in one command
- ) # end of *one* command
- /gx
- );
-
- my @saved = @command;
-
- $logger->debug(
- "grab: executing '",
- join( "' '", @command ),
- "' on object '",
- $self->name, "'"
- );
-
- my @found = ($self);
-
-COMMAND:
- while (@command) {
- last if $mode eq 'step_by_step' and @saved > @command;
-
- my $cmd = shift @command;
-
- my $obj = $found[-1];
- $logger->debug( "grab: executing cmd '$cmd' on object '", $obj->name,
"($obj)'" );
-
- if ( $cmd eq '!' ) {
- push @found, $obj->grab_root();
- next;
- }
-
- if ( $cmd =~ /^!([\w:]*)/ ) {
- my $ancestor = $obj->grab_ancestor($1);
- if ( defined $ancestor ) {
- push @found, $ancestor;
- next;
- }
- else {
- Config::Model::Exception::AncestorClass->throw(
- object => $obj,
- info => "grab called from '"
- . $self->name
- . "' with steps '@saved' looking for class $1"
- ) if $mode eq 'strict';
- return;
- }
- }
-
- if ( $cmd =~ /^\?(\w[\w-]*)/ ) {
- push @found, $obj->grab_ancestor_with_element_named($1);
- $cmd =~ s/^\?//; #remove the go up part
- unshift @command, $cmd;
- next;
- }
-
- if ( $cmd eq '-' ) {
- if ( defined $obj->parent ) {
- push @found, $obj->parent;
- next;
- }
- else {
- $logger->debug( "grab: ", $obj->name, " has no parent" );
- return $mode eq 'adaptative' ? $obj : undef;
- }
- }
-
- unless ( $obj->isa('Config::Model::Node')
- or $obj->isa('Config::Model::WarpedNode') ) {
- Config::Model::Exception::Model->throw(
- object => $obj,
- message => "Cannot apply command '$cmd' on leaf item"
- . " (full command is '@saved')"
- );
- }
-
- my ( $name, $action, $arg ) =
- ( $cmd =~ /(\w[\-\w]*)(?:(:)((?:"[^\"]*")|(?:[\w:\/\.\-\+]+)))?/ );
-
- if ( defined $arg and $arg =~ /^"/ and $arg =~ /"$/ ) {
- $arg =~ s/^"//; # remove leading quote
- $arg =~ s/"$//; # remove trailing quote
- }
-
- {
- no warnings "uninitialized";
- $logger->debug("grab: cmd '$cmd' -> name '$name', action
'$action', arg '$arg'");
- }
-
- unless ( $obj->has_element($name) ) {
- if ( $mode eq 'step_by_step' ) {
- return wantarray ? ( undef, @command ) : undef;
- }
- elsif ( $mode eq 'loose' ) {
- return;
- }
- elsif ( $mode eq 'adaptative' ) {
- last;
- }
- else {
- Config::Model::Exception::UnknownElement->throw(
- object => $obj,
- element => $name,
- function => 'grab',
- info => "grab called from '" . $self->name . "' with
steps '@saved'"
- );
- }
- }
-
- unless (
- $grab_non_available
- or $obj->is_element_available(
- name => $name,
- )
- ) {
- if ( $mode eq 'step_by_step' ) {
- return wantarray ? ( undef, @command ) : undef;
- }
- elsif ( $mode eq 'loose' ) {
- return;
- }
- elsif ( $mode eq 'adaptative' ) {
- last;
- }
- else {
- Config::Model::Exception::UnavailableElement->throw(
- object => $obj,
- element => $name,
- function => 'grab',
- info => "grab called from '" . $self->name . "' with
steps '@saved'"
- );
- }
- }
-
- my $next_obj = $obj->fetch_element(
- name => $name,
- check => $check,
- accept_hidden => $grab_non_available
- );
-
- # create list or hash element only if autoadd is true
- if ( defined $action
- and $autoadd == 0
- and not $next_obj->exists($arg) ) {
- return if $mode eq 'loose';
- Config::Model::Exception::UnknownId->throw(
- object => $obj->fetch_element($name),
- element => $name,
- id => $arg,
- function => 'grab'
- ) unless $mode eq 'adaptative';
- last;
- }
-
- if ( defined $action and not $next_obj->isa('Config::Model::AnyId') ) {
- return if $mode eq 'loose';
- Config::Model::Exception::Model->throw(
- object => $obj,
- message => "Cannot apply command '$cmd' on non hash or non
list item"
- . " (full command is '@saved'). item is '"
- . $next_obj->name . "'"
- );
- last;
- }
-
- # action can only be :
- $next_obj = $next_obj->fetch_with_id(index => $arg, check => $check)
if defined $action;
-
- push @found, $next_obj;
- }
-
- # check element type
- if ( defined $type ) {
- my @allowed = ref $type ? @$type : ($type);
- while ( @found and not grep {$found[-1]->get_type eq $_} @allowed ) {
- Config::Model::Exception::WrongType->throw(
- object => $found[-1],
- function => 'grab',
- got_type => $found[-1]->get_type,
- expected_type => $type,
- info => "requested with steps '$steps'"
- ) if $mode ne 'adaptative';
- pop @found;
- }
- }
-
- my $return = $found[-1];
- $logger->debug( "grab: returning object '", $return->name, "($return)'" );
- return wantarray ? ( $return, @command ) : $return;
-}
-
-sub grab_value {
- my $self = shift;
- my %args = scalar @_ == 1 ? ( steps => $_[0] ) : @_;
-
- my $obj = $self->grab(%args);
-
- # Pb: may return a node. add another option to grab ??
- # to get undef value when needed?
-
- return if ( $args{mode} and $args{mode} eq 'loose' and not defined $obj );
-
- Config::Model::Exception::User->throw(
- object => $self,
- message => "grab_value: cannot get value of non-leaf or check_list "
- . "item with '"
- . join( "' '", @_ )
- . "'. item is $obj"
- )
- unless ref $obj
- and ( $obj->isa("Config::Model::Value")
- or $obj->isa("Config::Model::CheckList") );
-
- my $value = $obj->fetch;
- if ( $logger->is_debug ) {
- my $str = defined $value ? $value : '<undef>';
- $logger->debug( "grab_value: returning value $str of object '",
$obj->name );
- }
- return $value;
-}
-
-sub grab_annotation {
- my $self = shift;
- my @args = scalar @_ == 1 ? ( steps => $_[0] ) : @_;
-
- my $obj = $self->grab(@args);
-
- return $obj->annotation;
-}
-
-sub grab_root {
- my $self = shift;
- return defined $self->parent
- ? $self->parent->grab_root
- : $self;
-}
-
-sub grab_ancestor {
- my $self = shift;
- my $class = shift || die "grab_ancestor: missing ancestor class";
-
- return $self if $self->get_type eq 'node' and $self->config_class_name eq
$class;
-
- return $self->{parent}->grab_ancestor($class) if defined $self->{parent};
- return;
-}
-
-#internal. Used by grab with '?xxx' steps
-sub grab_ancestor_with_element_named {
- my ( $self, $search, $type ) = @_;
-
- my $obj = $self;
-
- while (1) {
- $logger->debug(
- "grab_ancestor_with_element_named: executing cmd '?$search' on
object " . $obj->name );
-
- my $obj_element_name = $obj->element_name;
-
- if ( $obj->isa('Config::Model::Node')
- and $obj->has_element( name => $search, type => $type ) ) {
-
- # object contains the search element, we need to grab the
- # searched object (i.e. the '?foo' part is done
- return $obj;
- }
- elsif ( defined $obj->parent ) {
-
- # going up
- $obj = $obj->parent;
- }
- else {
- # there's no more up to go to...
- Config::Model::Exception::Model->throw(
- object => $self,
- error => "Error: cannot grab '?$search'" . "from " .
$self->name
- );
- }
- }
-}
-
# fallback method for object that don't implement has_data
sub has_data {
my $self= shift;
@@ -655,7 +326,7 @@ Config::Model::AnyThing - Base class for configuration tree
item
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -696,12 +367,12 @@ Returns the root node of the configuration tree.
=head2 location()
Returns the node location in the configuration tree. This location
-conforms with the syntax defined by L</grab()> method.
+conforms with the syntax defined by L<grab|Config::Model::Role::Grab/grab>
method.
=head2 location_short()
Returns the node location in the configuration tree. This location truncates
long
-indexes to be readable. It cannot be used by L</grab()> method.
+indexes to be readable. It cannot be used by
L<grab|Config::Model::Role::Grab/grab> method.
=head2 composite_name
@@ -758,110 +429,6 @@ Clear the annotation of an element
=head1 Information management
-=head2 grab(...)
-
-Grab an object from the configuration tree.
-
-Parameters are:
-
-=over
-
-=item C<steps> (or C<step>)
-
-A string indicating the steps to follow in the tree to find the
-required item. (mandatory)
-
-=item C<mode>
-
-When set to C<strict>, C<grab> throws an exception if no object is found
-using the passed string. When set to C<adaptative>, the object found last is
-returned. For instance, for the steps C<good_step wrong_step>, only
-the object held by C<good_step> is returned. When set to C<loose>, grab
-returns undef in case of problem. (default is C<strict>)
-
-=item C<type>
-
-Either C<node>, C<leaf>, C<hash> or C<list> or an array ref containing these
-values. Returns only an object of
-requested type. Depending on C<strict> value, C<grab> either
-throws an exception or returns the last object found with the requested type.
-(optional, default to C<undef>, which means any type of object)
-
-Examples:
-
- $root->grep(steps => 'foo:2 bar', type => 'leaf')
- $root->grep(steps => 'foo:2 bar', type => ['leaf','check_list'])
-
-=item C<autoadd>
-
-When set to 1, C<hash> or C<list> configuration element are created
-when requested by the passed steps. (default is 1).
-
-=item grab_non_available
-
-When set to 1, grab returns an object even if this one is not
-available. I.e. even if this element was warped out. (default is 0).
-
-=back
-
-The C<steps> parameters is made of the following items separated by
-spaces:
-
-=over 8
-
-=item -
-
-Go up one node
-
-=item !
-
-Go to the root node.
-
-=item !Foo
-
-Go up the configuration tree until the C<Foo> configuration class is found.
Raise an exception if
-no C<Foo> class is found when root node is reached.
-
-=item xxx
-
-Go down using C<xxx> element.
-
-=item xxx:yy
-
-Go down using C<xxx> element and id C<yy> (valid for hash or list elements)
-
-=item ?xxx
-
-Go up the tree until a node containing element C<xxx> is found. Then go down
-the tree like item C<xxx>.
-
-If C<?xxx:yy>, go up the tree the same way. But no check is done to
-see if id C<yy> actually exists or not. Only the element C<xxx> is
-considered when going up the tree.
-
-=back
-
-=head2 grab_value(...)
-
-Like L</grab(...)>, but returns the value of a leaf or check_list object, not
-just the leaf object.
-
-C<grab_value> raises an exception if following the steps ends on anything but a
-leaf or a check_list.
-
-=head2 grab_annotation(...)
-
-Like L</grab(...)>, but returns the annotation of an object.
-
-=head2 grab_root()
-
-Returns the root of the configuration tree.
-
-=head2 grab_ancestor( Foo )
-
-Go up the configuration tree until the C<Foo> configuration class is found.
Returns
-the found node or undef.
-
=head2 notify_change(...)
Notify the instance of semantic changes. Parameters are:
diff --git a/lib/Config/Model/Backend/Any.pm b/lib/Config/Model/Backend/Any.pm
index c43f5dd..eea9fc1 100644
--- a/lib/Config/Model/Backend/Any.pm
+++ b/lib/Config/Model/Backend/Any.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Backend::Any;
-$Config::Model::Backend::Any::VERSION = '2.094';
+$Config::Model::Backend::Any::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -185,7 +185,7 @@ Config::Model::Backend::Any - Virtual class for other
backends
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Backend/Fstab.pm
b/lib/Config/Model/Backend/Fstab.pm
index 9ceb2ec..494dd6e 100644
--- a/lib/Config/Model/Backend/Fstab.pm
+++ b/lib/Config/Model/Backend/Fstab.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Backend::Fstab;
-$Config::Model::Backend::Fstab::VERSION = '2.094';
+$Config::Model::Backend::Fstab::VERSION = '2.095';
use Mouse;
use Carp;
use Log::Log4perl qw(get_logger :levels);
@@ -164,7 +164,7 @@ Config::Model::Backend::Fstab - Read and write config from
fstab file
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Backend/IniFile.pm
b/lib/Config/Model/Backend/IniFile.pm
index 431caa0..cb6b2f7 100644
--- a/lib/Config/Model/Backend/IniFile.pm
+++ b/lib/Config/Model/Backend/IniFile.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Backend::IniFile;
-$Config::Model::Backend::IniFile::VERSION = '2.094';
+$Config::Model::Backend::IniFile::VERSION = '2.095';
use Carp;
use Mouse;
use 5.10.0;
@@ -408,7 +408,7 @@ Config::Model::Backend::IniFile - Read and write config as
a INI file
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Backend/Json.pm b/lib/Config/Model/Backend/Json.pm
index 535e285..cd8b421 100644
--- a/lib/Config/Model/Backend/Json.pm
+++ b/lib/Config/Model/Backend/Json.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Backend::Json;
-$Config::Model::Backend::Json::VERSION = '2.094';
+$Config::Model::Backend::Json::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -93,7 +93,7 @@ Config::Model::Backend::Json - Read and write config as a
JSON data structure
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Backend/PlainFile.pm
b/lib/Config/Model/Backend/PlainFile.pm
index cc674ed..a6bb690 100644
--- a/lib/Config/Model/Backend/PlainFile.pm
+++ b/lib/Config/Model/Backend/PlainFile.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Backend::PlainFile;
-$Config::Model::Backend::PlainFile::VERSION = '2.094';
+$Config::Model::Backend::PlainFile::VERSION = '2.095';
use Carp;
use Mouse;
use Config::Model::Exception;
@@ -189,7 +189,7 @@ Config::Model::Backend::PlainFile - Read and write config
as plain file
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Backend/ShellVar.pm
b/lib/Config/Model/Backend/ShellVar.pm
index 47a1f75..5c74379 100644
--- a/lib/Config/Model/Backend/ShellVar.pm
+++ b/lib/Config/Model/Backend/ShellVar.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Backend::ShellVar;
-$Config::Model::Backend::ShellVar::VERSION = '2.094';
+$Config::Model::Backend::ShellVar::VERSION = '2.095';
use Carp;
use Mouse;
use Config::Model::Exception;
@@ -114,7 +114,7 @@ Config::Model::Backend::ShellVar - Read and write config as
a C<SHELLVAR> data s
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Backend/Yaml.pm b/lib/Config/Model/Backend/Yaml.pm
index d719922..a71f20e 100644
--- a/lib/Config/Model/Backend/Yaml.pm
+++ b/lib/Config/Model/Backend/Yaml.pm
@@ -9,7 +9,7 @@
#
package Config::Model::Backend::Yaml;
-$Config::Model::Backend::Yaml::VERSION = '2.094';
+$Config::Model::Backend::Yaml::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -110,7 +110,7 @@ Config::Model::Backend::Yaml - Read and write config as a
YAML data structure
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/BackendMgr.pm b/lib/Config/Model/BackendMgr.pm
index fdb53cb..8a71490 100644
--- a/lib/Config/Model/BackendMgr.pm
+++ b/lib/Config/Model/BackendMgr.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::BackendMgr;
-$Config::Model::BackendMgr::VERSION = '2.094';
+$Config::Model::BackendMgr::VERSION = '2.095';
use Mouse;
use Carp;
@@ -813,7 +813,7 @@ Config::Model::BackendMgr - Load configuration node on
demand
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -951,6 +951,24 @@ directory can be hardcoded in the custom class.
C<config_dir> beginning
with 'C<~>' is munged so C<~> is replaced by C<< File::HomeDir->my_data >>.
See L<File::HomeDir> for details.
+=item file
+
+Specify configuration file name (without the path). This parameter is
+optional as the file name can be hardcoded in the custom class.
+
+The configuration file name can be specified with C<&index> keyword
+when a backend is associated to a node contained in a hash. For instance,
+with C<file> set to C<index.conf>:
+
+ service # hash element
+ foo # hash index
+ nodeA # values of nodeA are stored in foo.conf
+ bar # hash index
+ nodeB # values of nodeB are stored in bar.conf
+
+Alternatively, C<file> can be set to C<->, in which case, the
+configuration is read from STDIN.
+
=item os_config_dir
Specify alternate location of a configuration directory depending on the OS
diff --git a/lib/Config/Model/CheckList.pm b/lib/Config/Model/CheckList.pm
index d3cf4e9..26548c7 100644
--- a/lib/Config/Model/CheckList.pm
+++ b/lib/Config/Model/CheckList.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::CheckList;
-$Config::Model::CheckList::VERSION = '2.094';
+$Config::Model::CheckList::VERSION = '2.095';
use Mouse;
use 5.010;
@@ -23,6 +23,8 @@ use Storable qw/dclone/;
extends qw/Config::Model::AnyThing/;
with "Config::Model::Role::WarpMaster";
+with "Config::Model::Role::Grab";
+with "Config::Model::Role::HelpAsText";
my $logger = get_logger("Tree::Element::CheckList");
@@ -744,7 +746,7 @@ Config::Model::CheckList - Handle check list element
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -931,7 +933,7 @@ checklist are available.
This other hash or other checklist is indicated by the C<refer_to> or
C<computed_refer_to> parameter. C<refer_to> uses the syntax of the
-C<steps> parameter of L<grab(...)|Config::AnyThing/"grab(...)">
+C<steps> parameter of L<grab(...)|Config::Role::Grab/grab">
See L<refer_to parameter|Config::Model::IdElementReference/"refer_to
parameter">.
diff --git a/lib/Config/Model/Cookbook/CreateModelFromDoc.pod
b/lib/Config/Model/Cookbook/CreateModelFromDoc.pod
index bdcc24f..1b861db 100644
--- a/lib/Config/Model/Cookbook/CreateModelFromDoc.pod
+++ b/lib/Config/Model/Cookbook/CreateModelFromDoc.pod
@@ -13,7 +13,7 @@ Config::Model::Cookbook::CreateModelFromDoc - Create a
configuration model from
=head1 VERSION
-version 2.094
+version 2.095
=head1 Introduction
diff --git a/lib/Config/Model/Describe.pm b/lib/Config/Model/Describe.pm
index a916744..acd84da 100644
--- a/lib/Config/Model/Describe.pm
+++ b/lib/Config/Model/Describe.pm
@@ -9,7 +9,7 @@
#
package Config::Model::Describe;
-$Config::Model::Describe::VERSION = '2.094';
+$Config::Model::Describe::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -182,7 +182,7 @@ Config::Model::Describe - Provide a description of a node
element
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/DumpAsData.pm b/lib/Config/Model/DumpAsData.pm
index 00c716f..0b500c3 100644
--- a/lib/Config/Model/DumpAsData.pm
+++ b/lib/Config/Model/DumpAsData.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::DumpAsData;
-$Config::Model::DumpAsData::VERSION = '2.094';
+$Config::Model::DumpAsData::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -252,7 +252,7 @@ Config::Model::DumpAsData - Dump configuration content as a
perl data structure
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Dumper.pm b/lib/Config/Model/Dumper.pm
index 6800ea0..fed73df 100644
--- a/lib/Config/Model/Dumper.pm
+++ b/lib/Config/Model/Dumper.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Dumper;
-$Config::Model::Dumper::VERSION = '2.094';
+$Config::Model::Dumper::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -259,7 +259,7 @@ Config::Model::Dumper - Serialize data of config tree
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Exception.pm b/lib/Config/Model/Exception.pm
index 99f3144..1500d92 100644
--- a/lib/Config/Model/Exception.pm
+++ b/lib/Config/Model/Exception.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Exception;
-$Config::Model::Exception::VERSION = '2.094';
+$Config::Model::Exception::VERSION = '2.095';
use warnings;
use strict;
use Data::Dumper;
@@ -93,19 +93,19 @@ sub full_message {
}
package Config::Model::Exception::Any;
-$Config::Model::Exception::Any::VERSION = '2.094';
+$Config::Model::Exception::Any::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception';
package Config::Model::Exception::ModelDeclaration;
-$Config::Model::Exception::ModelDeclaration::VERSION = '2.094';
+$Config::Model::Exception::ModelDeclaration::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::Fatal';
sub _desc {'configuration model declaration error' }
package Config::Model::Exception::User ;
-$Config::Model::Exception::User::VERSION = '2.094';
+$Config::Model::Exception::User::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::Any';
sub _desc {'user error' }
@@ -113,7 +113,7 @@ sub _desc {'user error' }
## old classes below
package Config::Model::Exception::Syntax;
-$Config::Model::Exception::Syntax::VERSION = '2.094';
+$Config::Model::Exception::Syntax::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::Any';
@@ -134,7 +134,7 @@ sub full_message {
}
package Config::Model::Exception::LoadData;
-$Config::Model::Exception::LoadData::VERSION = '2.094';
+$Config::Model::Exception::LoadData::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
@@ -158,7 +158,7 @@ sub full_message {
}
package Config::Model::Exception::Model;
-$Config::Model::Exception::Model::VERSION = '2.094';
+$Config::Model::Exception::Model::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::Fatal';
@@ -191,7 +191,7 @@ sub full_message {
}
package Config::Model::Exception::Load;
-$Config::Model::Exception::Load::VERSION = '2.094';
+$Config::Model::Exception::Load::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
@@ -220,7 +220,7 @@ sub full_message {
}
package Config::Model::Exception::UnavailableElement;
-$Config::Model::Exception::UnavailableElement::VERSION = '2.094';
+$Config::Model::Exception::UnavailableElement::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
@@ -251,7 +251,7 @@ sub full_message {
}
package Config::Model::Exception::AncestorClass;
-$Config::Model::Exception::AncestorClass::VERSION = '2.094';
+$Config::Model::Exception::AncestorClass::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
@@ -259,7 +259,7 @@ sub _desc { 'unknown ancestor class'}
package Config::Model::Exception::ObsoleteElement;
-$Config::Model::Exception::ObsoleteElement::VERSION = '2.094';
+$Config::Model::Exception::ObsoleteElement::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
@@ -275,7 +275,7 @@ sub full_message {
my $msg = $self->description;
my $location = $obj->name;
- my $help = $obj->get_help($element) || '';
+ my $help = $obj->get_help_as_text($element) || '';
$msg .= " '$element' in node '$location'.\n";
$msg .= "\t$help\n";
@@ -284,7 +284,7 @@ sub full_message {
}
package Config::Model::Exception::UnknownElement;
-$Config::Model::Exception::UnknownElement::VERSION = '2.094';
+$Config::Model::Exception::UnknownElement::VERSION = '2.095';
use Carp;
use Mouse;
@@ -359,14 +359,14 @@ sub full_message {
}
package Config::Model::Exception::WarpError;
-$Config::Model::Exception::WarpError::VERSION = '2.094';
+$Config::Model::Exception::WarpError::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
sub _desc { 'warp error'}
package Config::Model::Exception::Fatal;
-$Config::Model::Exception::Fatal::VERSION = '2.094';
+$Config::Model::Exception::Fatal::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::Any';
@@ -374,7 +374,7 @@ sub _desc { 'fatal error' }
package Config::Model::Exception::UnknownId;
-$Config::Model::Exception::UnknownId::VERSION = '2.094';
+$Config::Model::Exception::UnknownId::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
@@ -408,7 +408,7 @@ sub full_message {
}
package Config::Model::Exception::WrongValue;
-$Config::Model::Exception::WrongValue::VERSION = '2.094';
+$Config::Model::Exception::WrongValue::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
@@ -416,7 +416,7 @@ sub _desc { 'wrong value'};
package Config::Model::Exception::WrongType;
-$Config::Model::Exception::WrongType::VERSION = '2.094';
+$Config::Model::Exception::WrongType::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
@@ -447,14 +447,14 @@ sub full_message {
}
package Config::Model::Exception::ConfigFile;
-$Config::Model::Exception::ConfigFile::VERSION = '2.094';
+$Config::Model::Exception::ConfigFile::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::User';
sub _desc { 'error in configuration file' }
package Config::Model::Exception::ConfigFile::Missing;
-$Config::Model::Exception::ConfigFile::Missing::VERSION = '2.094';
+$Config::Model::Exception::ConfigFile::Missing::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::ConfigFile';
@@ -471,14 +471,14 @@ sub full_message {
}
package Config::Model::Exception::Formula;
-$Config::Model::Exception::Formula::VERSION = '2.094';
+$Config::Model::Exception::Formula::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::Model';
sub _desc { 'error in computation formula of the configuration model'}
package Config::Model::Exception::Internal;
-$Config::Model::Exception::Internal::VERSION = '2.094';
+$Config::Model::Exception::Internal::VERSION = '2.095';
use Mouse;
extends 'Config::Model::Exception::Fatal';
@@ -500,7 +500,7 @@ Config::Model::Exception - Exception mechanism for
configuration model
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/FuseUI.pm b/lib/Config/Model/FuseUI.pm
index f8420f0..338fcd7 100644
--- a/lib/Config/Model/FuseUI.pm
+++ b/lib/Config/Model/FuseUI.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::FuseUI;
-$Config::Model::FuseUI::VERSION = '2.094';
+$Config::Model::FuseUI::VERSION = '2.095';
# there's no Singleton with Mouse
use Mouse;
@@ -327,7 +327,7 @@ Config::Model::FuseUI - Fuse virtual file interface for
Config::Model
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/HashId.pm b/lib/Config/Model/HashId.pm
index 4070011..2ad94f2 100644
--- a/lib/Config/Model/HashId.pm
+++ b/lib/Config/Model/HashId.pm
@@ -8,18 +8,26 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::HashId;
-$Config::Model::HashId::VERSION = '2.094';
+$Config::Model::HashId::VERSION = '2.095';
use Mouse;
+use 5.10.1;
use Config::Model::Exception;
use Carp;
+use Mouse::Util::TypeConstraints;
+
+subtype 'HaskKeyArray' => as 'ArrayRef' ;
+coerce 'HaskKeyArray' => from 'Str' => via { [$_] } ;
+
use Log::Log4perl qw(get_logger :levels);
my $logger = get_logger("Tree::Element::Id::Hash");
extends qw/Config::Model::AnyId/;
+with "Config::Model::Role::Grab";
+
has data => ( is => 'rw', isa => 'HashRef', default => sub { {}; } );
has list => (
is => 'rw',
@@ -31,8 +39,12 @@ has list => (
}
);
-has [qw/default_keys auto_create_keys/] =>
- ( is => 'rw', isa => 'ArrayRef', default => sub { []; } );
+has [qw/default_keys auto_create_keys/] => (
+ is => 'rw',
+ isa => 'HaskKeyArray',
+ coerce => 1,
+ default => sub { []; }
+);
has [qw/morph ordered/] => ( is => 'ro', isa => 'Bool' );
sub BUILD {
@@ -217,6 +229,21 @@ sub sort {
}
}
+sub insort {
+ my ($self, $id) = @_;
+
+ if ($self->ordered) {
+ my $elt = $self->fetch_with_id($id);
+ $self->_sort;
+ return $elt;
+ }
+ else {
+ Config::Model::Exception::User->throw(
+ object => $self,
+ message => "cannot call insort on non ordered hash"
+ );
+ }
+}
# hash only method
sub firstkey {
@@ -511,7 +538,7 @@ Config::Model::HashId - Handle hash element for
configuration model
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -548,6 +575,16 @@ Returns the number of elements of the hash.
Sort an ordered hash. Throws an error if called on a non ordered hash.
+=head2 insort
+
+Parameters: key
+
+Create a new element in the ordered hash while keeping alphabetical order of
the keys
+
+Returns the newly created element.
+
+Throws an error if called on a non ordered hash.
+
=head2 firstkey
Returns the first key of the hash. Behaves like C<each> core perl
diff --git a/lib/Config/Model/IdElementReference.pm
b/lib/Config/Model/IdElementReference.pm
index 122db56..fe30c32 100644
--- a/lib/Config/Model/IdElementReference.pm
+++ b/lib/Config/Model/IdElementReference.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::IdElementReference;
-$Config::Model::IdElementReference::VERSION = '2.094';
+$Config::Model::IdElementReference::VERSION = '2.095';
use Mouse;
use Carp;
@@ -190,7 +190,7 @@ Config::Model::IdElementReference - Refer to id element(s)
and extract keys
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -317,7 +317,7 @@ Construction is handled by the calling object
(L<Config::Model::Node>).
C<refer_to> is used to specify a hash element that is used as a
reference. C<refer_to> points to an array or hash element in the
configuration tree using the path syntax (See
-L<Config::Model::Node/grab> for details).
+L<Config::Model::Role::Grab/grab> for details).
=item computed_refer_to
diff --git a/lib/Config/Model/Instance.pm b/lib/Config/Model/Instance.pm
index b6b24a3..8561de7 100644
--- a/lib/Config/Model/Instance.pm
+++ b/lib/Config/Model/Instance.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Instance;
-$Config::Model::Instance::VERSION = '2.094';
+$Config::Model::Instance::VERSION = '2.095';
#use Scalar::Util qw(weaken) ;
use strict;
@@ -22,7 +22,6 @@ use Text::Diff;
use File::Path;
use Log::Log4perl qw(get_logger :levels);
-use Config::Model::Annotation;
use Config::Model::Exception;
use Config::Model::Node;
use Config::Model::Loader;
@@ -554,7 +553,7 @@ Config::Model::Instance - Instance of configuration tree
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -726,6 +725,12 @@ In scalar context, returns a big string. Useful to print.
Print all changes on STDOUT and return the list of changes.
+=head2 clear_changes
+
+Clear list of changes. Note that changes pending in the configuration
+tree is not affected. This clears only the list shown to user. Use
+only for tests.
+
=head2 has_warning
Returns the number of warning found in the elements of this configuration
instance.
diff --git a/lib/Config/Model/Iterator.pm b/lib/Config/Model/Iterator.pm
index 7d2bfb0..fff9411 100644
--- a/lib/Config/Model/Iterator.pm
+++ b/lib/Config/Model/Iterator.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Iterator;
-$Config::Model::Iterator::VERSION = '2.094';
+$Config::Model::Iterator::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -281,7 +281,7 @@ Config::Model::Iterator - Iterates forward or backward a
configuration tree
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/ListId.pm b/lib/Config/Model/ListId.pm
index 6f2665b..98acce9 100644
--- a/lib/Config/Model/ListId.pm
+++ b/lib/Config/Model/ListId.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::ListId;
-$Config::Model::ListId::VERSION = '2.094';
+$Config::Model::ListId::VERSION = '2.095';
use 5.10.1;
use Mouse;
@@ -18,6 +18,8 @@ use Log::Log4perl qw(get_logger :levels);
use Carp;
extends qw/Config::Model::AnyId/;
+with "Config::Model::Role::Grab";
+
my $logger = get_logger("Tree::Element::Id::List");
has data => (
@@ -502,7 +504,7 @@ Config::Model::ListId - Handle list element for
configuration model
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Lister.pm b/lib/Config/Model/Lister.pm
index 33abe41..7aaf7fd 100644
--- a/lib/Config/Model/Lister.pm
+++ b/lib/Config/Model/Lister.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Lister;
-$Config::Model::Lister::VERSION = '2.094';
+$Config::Model::Lister::VERSION = '2.095';
use strict;
use warnings;
use Exporter;
@@ -85,7 +85,7 @@ Config::Model::Lister - List available models and applications
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Loader.pm b/lib/Config/Model/Loader.pm
index 06d7a6c..7e7b425 100644
--- a/lib/Config/Model/Loader.pm
+++ b/lib/Config/Model/Loader.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Loader;
-$Config::Model::Loader::VERSION = '2.094';
+$Config::Model::Loader::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -409,22 +409,28 @@ sub _load_check_list {
# function_args are the arguments passed to the load command
my %dispatch_action = (
list_leaf => {
- ':.sort' => sub { $_[1]->sort; },
- ':.push' => sub { $_[1]->push( @_[ 4 .. $#_ ] ); },
- ':.unshift' => sub { $_[1]->unshift( @_[ 4 .. $#_ ] ); },
- ':.insert_at' => sub { $_[1]->insert_at( @_[ 4 .. $#_ ] ); },
- ':.insort' => sub { $_[1]->insort( @_[ 4 .. $#_ ] ); },
+ ':.sort' => sub { $_[1]->sort; return 'ok';},
+ ':.push' => sub { $_[1]->push( @_[ 5 .. $#_ ] ); return 'ok';
},
+ ':.unshift' => sub { $_[1]->unshift( @_[ 5 .. $#_ ] ); return
'ok'; },
+ ':.insert_at' => sub { $_[1]->insert_at( @_[ 5 .. $#_ ] ); return
'ok'; },
+ ':.insort' => sub { $_[1]->insort( @_[ 5 .. $#_ ] ); return
'ok'; },
':.insert_before' => \&_insert_before,
},
'list_*' => {
- ':.copy' => sub { $_[1]->copy( $_[4], $_[5] ); },
- ':.clear' => sub { $_[1]->clear;},
+ ':.copy' => sub { $_[1]->copy( $_[5], $_[6] ); return 'ok'; },
+ ':.clear' => sub { $_[1]->clear; return 'ok'; },
+ },
+ hash_leaf => {
+ ':.insort' => sub { $_[1]->insort($_[5])->store($_[6]); return
'ok'; },
+ },
+ hash_node => => {
+ ':.insort' => \&_insort_hash_of_node,
},
'hash_*' => {
- ':.sort' => sub { $_[1]->sort; },
- ':@' => sub { $_[1]->sort; },
- ':.copy' => sub { $_[1]->copy( $_[4], $_[5] ); },
- ':.clear' => sub { $_[1]->clear;},
+ ':.sort' => sub { $_[1]->sort; return 'ok'; },
+ ':@' => sub { $_[1]->sort; return 'ok'; },
+ ':.copy' => sub { $_[1]->copy( $_[5], $_[6] ); return 'ok'; },
+ ':.clear' => sub { $_[1]->clear; return 'ok';},
},
leaf => {
':-=' => \&_remove_by_value,
@@ -434,7 +440,8 @@ my %dispatch_action = (
fallback => {
':-' => \&_remove_by_id,
'~' => \&_remove_by_id,
- } );
+ }
+);
my @equiv = qw/:@ :.sort :< :.push :> :.unshift/;
while (@equiv) {
@@ -443,20 +450,21 @@ while (@equiv) {
}
sub _insert_before {
- my ( $self, $element, $check, $inst, $before_str, @values ) = @_;
+ my ( $self, $element, $check, $inst, $cmdref, $before_str, @values ) = @_;
my $before = $before_str =~ m!^/! ? eval "qr$before_str" : $before_str;
$element->insert_before( $before, @values );
+ return 'ok';
}
sub _remove_by_id {
- my ( $self, $element, $check, $inst, $id ) = @_;
- $logger->debug("_remove_by_id: removing id $id");
+ my ( $self, $element, $check, $inst, $cmdref, $id ) = @_;
+ $logger->debug("_remove_by_id: removing id '$id'");
$element->remove($id);
return 'ok';
}
sub _remove_by_value {
- my ( $self, $element, $check, $inst, $rm_val ) = @_;
+ my ( $self, $element, $check, $inst, $cmdref, $rm_val ) = @_;
$logger->debug("_remove_by_value value $rm_val");
foreach my $idx ( $element->fetch_all_indexes ) {
@@ -468,7 +476,7 @@ sub _remove_by_value {
}
sub _remove_matched_value {
- my ( $self, $element, $check, $inst, $rm_val ) = @_;
+ my ( $self, $element, $check, $inst, $cmdref, $rm_val ) = @_;
$logger->debug("_remove_matched_value $rm_val");
@@ -483,7 +491,7 @@ sub _remove_matched_value {
}
sub _substitute_value {
- my ( $self, $element, $check, $inst, $s_val ) = @_;
+ my ( $self, $element, $check, $inst, $cmdref, $s_val ) = @_;
$logger->debug("_substitute_value $s_val");
@@ -495,6 +503,13 @@ sub _substitute_value {
return 'ok';
}
+sub _insort_hash_of_node {
+ my ( $self, $element, $check, $inst, $cmdref, $id ) = @_;
+ my $node = $element->insort($_[5]);
+ $logger->debug("_insort_hash_of_node: calling _load on node id $id");
+ return $self->_load( $node, $check, $cmdref );
+}
+
sub _load_list {
my ( $self, $node, $check, $inst, $cmdref ) = @_;
my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) =
@$inst;
@@ -544,8 +559,7 @@ sub _load_list {
|| $dispatch_action{$cargo_type}{$action}
|| $dispatch_action{'fallback'}{$action};
if ($dispatch) {
- $dispatch->( $self, $element, $check, $inst, @f_args );
- return 'ok';
+ return $dispatch->( $self, $element, $check, $inst, $cmdref,
@f_args );
}
}
@@ -660,11 +674,18 @@ sub _load_hash {
|| $dispatch_action{'fallback'}{$action};
if ($dispatch) {
# todo missing arguments
- $dispatch->( $self, $element, $check, $inst, @f_args );
- return 'ok';
+ return $dispatch->( $self, $element, $check, $inst, $cmdref,
@f_args );
}
}
+ if (not defined $id) {
+ Config::Model::Exception::Load->throw(
+ object => $element,
+ command => join( '', @$inst ),
+ error => qq!Unexpected hash instruction: '$action' or missing id!
+ );
+ }
+
my $obj = $element->fetch_with_id( index => $id, check => $check );
$self->_load_note( $obj, $note, $inst, $cmdref );
@@ -805,7 +826,7 @@ Config::Model::Loader - Load serialized data into config
tree
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -1034,6 +1055,23 @@ Insert C<zz> value on C<xxx> list before B<value>
matching C<yy>.
Insert C<zz> value on C<xxx> list so that existing alphanumeric order is
preserved.
+=item xxx:.insort(zz)
+
+For hash element containing nodes: creates a new hash element with
+C<zz> key on C<xxx> hash so that existing alphanumeric order of keys
+is preserved. Note that all keys are sorted once this instruction is
+called. Following instructions are applied on the created
+element. I.e. putting key order aside, C<xxx:.insort(zz)> has the
+same effect as C<xxx:zz> instruction.
+
+=item xxx:.insort(zz,vv)
+
+For hash element containing leaves: creates a new hash element with
+C<zz> key and assing value C<vv> so that existing alphanumeric order of keys
+is preserved. Note that all keys are sorted once this instruction is
+called. Putting key order aside, C<xxx:.insort(zz,vv)> has the
+same effect as C<xxx:zz=vv> instruction.
+
=item xxx:=z1,z2,z3
Set list element C<xxx> to list C<z1,z2,z3>. Use C<,,> for undef
diff --git a/lib/Config/Model/Manual/ModelCreationAdvanced.pod
b/lib/Config/Model/Manual/ModelCreationAdvanced.pod
index 833f2fa..4babc1c 100644
--- a/lib/Config/Model/Manual/ModelCreationAdvanced.pod
+++ b/lib/Config/Model/Manual/ModelCreationAdvanced.pod
@@ -13,7 +13,7 @@ Config::Model::Manual::ModelCreationAdvanced - Creating a
model with advanced fe
=head1 VERSION
-version 2.094
+version 2.095
=head1 Introduction
diff --git a/lib/Config/Model/Manual/ModelCreationIntroduction.pod
b/lib/Config/Model/Manual/ModelCreationIntroduction.pod
index 7f92d7d..62303a8 100644
--- a/lib/Config/Model/Manual/ModelCreationIntroduction.pod
+++ b/lib/Config/Model/Manual/ModelCreationIntroduction.pod
@@ -13,7 +13,7 @@ Config::Model::Manual::ModelCreationIntroduction -
Introduction to model creatio
=head1 VERSION
-version 2.094
+version 2.095
=head1 Introduction
diff --git a/lib/Config/Model/Node.pm b/lib/Config/Model/Node.pm
index 239b139..c899167 100644
--- a/lib/Config/Model/Node.pm
+++ b/lib/Config/Model/Node.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Node;
-$Config::Model::Node::VERSION = '2.094';
+$Config::Model::Node::VERSION = '2.095';
use Mouse;
with "Config::Model::Role::NodeLoader";
@@ -29,6 +29,9 @@ use List::MoreUtils qw(insert_after_string);
extends qw/Config::Model::AnyThing/;
+with "Config::Model::Role::Grab";
+with "Config::Model::Role::HelpAsText";
+
use vars qw(@status @level %default_property);
*status = *Config::Model::status;
@@ -312,6 +315,7 @@ sub check_properties {
sub init {
my $self = shift;
+ my %args = @_;
return if $self->{initialized};
$self->{initialized} = 1; # avoid recursions
@@ -332,7 +336,7 @@ sub init {
);
if ( defined $model->{read_config} ) {
- $self->read_config_data( check => $self->check );
+ $self->read_config_data( check => $args{check} // $self->check );
}
# use read_config data if write_config is missing
@@ -650,7 +654,7 @@ sub fetch_element {
my $check = $self->_check_check( $args{check} );
my $accept_hidden = $args{accept_hidden} || 0;
- $self->init();
+ $self->init(check => $check);
my $model = $self->{model};
@@ -1080,6 +1084,8 @@ sub copy_from {
$self->load( step => $dump, check => $check );
}
+# TODO: need Pod::Text attribute -> move that to a role ?
+# to translate Pod description to plain text when help is displayed
sub get_help {
my $self = shift;
@@ -1203,7 +1209,7 @@ Config::Model::Node - Class for configuration tree node
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -1751,17 +1757,17 @@ Returns 1 if the element is known in the model.
Returns 1 if the element is defined.
-=head2 grab(...)
+=head2 grab
-See L<Config::Model::AnyThing/"grab(...)">.
+See L<Config::Model::Role::Grab/grab">.
-=head2 grab_value(...)
+=head2 grab_value
-See L<Config::Model::AnyThing/"grab_value(...)">.
+See L<Config::Model::Role::Grab/grab_value">.
-=head2 grab_root()
+=head2 grab_root
-See L<Config::Model::AnyThing/"grab_root()">.
+See L<Config::Model::Role::Grab/"grab_root">.
=head2 get( path => ..., mode => ... , check => ... , get_obj => 1|0, autoadd
=> 1|0)
diff --git a/lib/Config/Model/ObjTreeScanner.pm
b/lib/Config/Model/ObjTreeScanner.pm
index 6594da7..7f85e32 100644
--- a/lib/Config/Model/ObjTreeScanner.pm
+++ b/lib/Config/Model/ObjTreeScanner.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::ObjTreeScanner;
-$Config::Model::ObjTreeScanner::VERSION = '2.094';
+$Config::Model::ObjTreeScanner::VERSION = '2.095';
use strict;
use Config::Model::Exception;
use Scalar::Util qw/blessed/;
@@ -285,7 +285,7 @@ Config::Model::ObjTreeScanner - Scan config tree and
perform call-backs for each
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Report.pm b/lib/Config/Model/Report.pm
index d39b33f..d4d7a7e 100644
--- a/lib/Config/Model/Report.pm
+++ b/lib/Config/Model/Report.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Report;
-$Config::Model::Report::VERSION = '2.094';
+$Config::Model::Report::VERSION = '2.095';
use Carp;
use strict;
use warnings;
@@ -44,11 +44,11 @@ sub report {
if ( defined $value ) {
my $name = defined $index ? " $element:$index" : $element;
push @$data_r, $obj->location . " $name = $value";
- my $desc = $obj->get_help($element);
+ my $desc = $obj->get_help_as_text($element);
if ( defined $desc and $desc ) {
push @$data_r, wrap( "\t", "\t\t", "DESCRIPTION: $desc" );
}
- my $effect = $value_obj->get_help($value);
+ my $effect = $value_obj->get_help_as_text($value);
if ( defined $effect and $effect ) {
push @$data_r, wrap( "\t", "\t\t", "SELECTED: $effect" );
}
@@ -90,7 +90,7 @@ Config::Model::Report - Reports data from config tree
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/AnyThing.pm b/lib/Config/Model/Role/Grab.pm
similarity index 53%
copy from lib/Config/Model/AnyThing.pm
copy to lib/Config/Model/Role/Grab.pm
index 1678eb5..3ab81cb 100644
--- a/lib/Config/Model/AnyThing.pm
+++ b/lib/Config/Model/Role/Grab.pm
@@ -7,228 +7,19 @@
#
# The GNU Lesser General Public License, Version 2.1, February 1999
#
-package Config::Model::AnyThing;
-$Config::Model::AnyThing::VERSION = '2.094';
-use Mouse;
+package Config::Model::Role::Grab;
+$Config::Model::Role::Grab::VERSION = '2.095';
+# ABSTRACT: Role to grab data from elsewhere in the tree
-# FIXME: must cleanup warp mechanism to implement this
-# use MouseX::StrictConstructor;
-
-use Pod::POM;
+use Mouse::Role;
+use strict;
+use warnings;
use Carp;
-use Log::Log4perl qw(get_logger :levels);
-use 5.10.1;
-
-my $logger = get_logger("Anything");
-my $change_logger = get_logger("ChangeTracker");
-
-has element_name => ( is => 'ro', isa => 'Str' );
-has parent => ( is => 'ro', isa => 'Config::Model::Node', weak_ref => 1
);
-
-has instance => (
- is => 'ro',
- isa => 'Config::Model::Instance',
- weak_ref => 1,
- handles => [qw/show_message/]
-);
-
-# needs_check defaults to 1 to trap undef mandatory values
-has needs_check => ( is => 'rw', isa => 'Bool', default => 1 );
-
-# index_value can be written to when move method is called. But let's
-# not advertise this feature.
-has index_value => (
- is => 'rw',
- isa => 'Str',
- trigger => sub { my $self = shift; $self->{location} = $self->_location; },
-);
-
-has container => ( is => 'ro', isa => 'Ref', required => 1, weak_ref => 1 );
-
-has container_type => ( is => 'ro', isa => 'Str', builder =>
'_container_type', lazy => 1 );
-
-sub _container_type {
- my $self = shift;
- my $p = $self->parent;
- return defined $p
- ? $p->element_type( $self->element_name )
- : 'node'; # root node
-
-}
-
-has root => (
- is => 'ro',
- isa => 'Config::Model::Node',
- weak_ref => 1,
- builder => '_root',
- lazy => 1
-);
-
-sub _root {
- my $self = shift;
-
- return $self->parent || $self;
-}
-
-has location => ( is => 'ro', isa => 'Str', builder => '_location', lazy
=> 1 );
-has location_short => ( is => 'ro', isa => 'Str', builder =>
'_location_short', lazy => 1 );
-
-has backend_support_annotation => (
- is => 'ro',
- isa => 'Bool',
- builder => '_backend_support_annotation',
- lazy => 1
-);
-
-sub _backend_support_annotation {
- my $self = shift;
- # this method is overridden in Config::Model::Node
- return $self->parent->backend_support_annotation;
-};
-
-sub notify_change {
- my $self = shift;
- my %args = @_;
-
- return if $self->instance->initial_load and not $args{really};
-
- $change_logger->debug( "called for ", $self->name, " from ", join( ' ',
caller ),
- " with ", join( ' ', %args ) )
- if $change_logger->is_debug;
-
- # needs_save may be overridden by caller
- $args{needs_save} //= 1;
- $args{path} //= $self->location;
- $args{name} //= $self->element_name if $self->element_name;
- $args{index} //= $self->index_value if $self->index_value;
-
- # better use %args instead of @_ to forward arguments. %args eliminates
duplicated keys
- $self->container->notify_change(%args);
-}
-
-sub _location {
- my $self = shift;
-
- my $str = '';
- $str .= $self->parent->location if defined $self->parent;
-
- $str .= ' ' if $str;
-
- $str .= $self->composite_name;
-
- return $str;
-}
-
-sub _location_short {
- my $self = shift;
-
- my $str = '';
- $str .= $self->parent->location_short if defined $self->parent;
-
- $str .= ' ' if $str;
-
- $str .= $self->composite_name_short;
-
- return $str;
-}
-
-#has composite_name => (is => 'ro', isa => 'Str' , builder =>
'_composite_name', lazy => 1);
-
-sub composite_name {
- my $self = shift;
- my $element = $self->element_name;
- $element = '' unless defined $element;
-
- my $idx = $self->index_value;
- return $element unless defined $idx;
- $idx = '"' . $idx . '"' if $idx =~ /\W/;
-
- return "$element:$idx";
-}
-
-sub composite_name_short {
- my $self = shift;
-
- my $element = $self->element_name;
- $element = '' unless defined $element;
-
-
- my $idx = $self->shorten_idx($self->index_value);
- return $element unless length $idx;
- $idx = '"' . $idx . '"' if $idx =~ /\W/;
- return "$element:$idx";
-}
-
-sub shorten_idx {
- my $self = shift;
- my $long_index = shift ;
-
- my @idx = split /\n/, $long_index // '' ;
- my $idx = shift @idx;
- $idx .= '[...]' if @idx;
-
- return $idx // ''; # may be undef on freebsd with perl 5.10.1 ...
-}
-
-
-## Fixme: not yet tested
-sub xpath {
- my $self = shift;
-
- $logger->debug("xpath called on $self");
-
- my $element = $self->element_name;
- $element = '' unless defined $element;
-
- my $idx = $self->index_value;
-
- my $str = '';
- $str .= $self->cim_parent->parent->xpath
- if $self->can('cim_parent')
- and defined $self->cim_parent;
-
- $str .= '/' . $element . ( defined $idx ? "[\@id=$idx]" : '' ) if $element;
-
- return $str;
-}
-
-sub annotation {
- my $self = shift;
- $self->{annotation} = join( "\n", grep ( defined $_, @_ ) )
- if @_
- and not $self->instance->preset
- and not $self->instance->layered;
- return $self->{annotation} || '';
-}
-
-sub clear_annotation {
- my $self = shift;
- $self->{annotation} = '';
-}
+use Mouse::Util;
+use Log::Log4perl qw(get_logger :levels);
-sub load_pod_annotation {
- my $self = shift;
- my $pod = shift;
-
- my $parser = Pod::POM->new();
- my $pom = $parser->parse_text($pod)
- || croak $parser->error();
- my $sections = $pom->head1();
-
- foreach my $s (@$sections) {
- next unless $s->title eq 'Annotations';
-
- foreach my $item ( $s->over->[0]->item ) {
- my $path = $item->title . ''; # force string representation.
Not understood why...
- $path =~ s/^[\s\*]+//;
- my $note = $item->text . '';
- $note =~ s/\s+$//;
- $logger->debug("load_pod_annotation: '$path' -> '$note'");
- $self->grab( steps => $path )->annotation($note);
- }
- }
-}
+my $logger = get_logger("Grab");
## Navigation
@@ -563,86 +354,6 @@ sub grab_ancestor_with_element_named {
}
}
-# fallback method for object that don't implement has_data
-sub has_data {
- my $self= shift;
- $logger->debug("called fall-back has_data for element", $self->name) if
$logger->is_debug;
- return 1;
-}
-
-sub model_searcher {
- my $self = shift;
- my %args = @_;
-
- my $model = $self->instance->config_model;
- return Config::Model::SearchElement->new( model => $model, node => $self,
%args );
-}
-
-sub searcher {
- carp "Config::Model::AnyThing searcher is deprecated";
- goto &model_searcher;
-}
-
-sub dump_as_data {
- my $self = shift;
- my $dumper = Config::Model::DumpAsData->new;
- $dumper->dump_as_data( node => $self, @_ );
-}
-
-# hum, check if the check information is valid
-sub _check_check {
- my $self = shift;
- my $p = shift;
-
- return 'yes' if not defined $p or $p eq '1' or $p eq 'yes';
- return 'no' if $p eq '0' or $p eq 'no';
- return $p if $p eq 'skip';
-
- croak "Internal error: Unvalid check value: $p";
-}
-
-sub has_fixes {
- my $self = shift;
- $logger->debug( "dummy has_fixes called on " . $self->name );
- return 0;
-}
-
-sub has_warning {
- my $self = shift;
- $logger->debug( "dummy has_warning called on " . $self->name );
- return 0;
-}
-
-sub warp_error {
- my $self = shift;
- return '' unless defined $self->{warper};
- return $self->{warper}->warp_error;
-}
-
-# used by Value and AnyId
-sub set_convert {
- my ( $self, $arg_ref ) = @_;
-
- my $convert = delete $arg_ref->{convert};
-
- # convert_sub keeps a subroutine reference
- $self->{convert_sub} =
- $convert eq 'uc' ? sub { uc(shift) }
- : $convert eq 'lc' ? sub { lc(shift) }
- : undef;
-
- Config::Model::Exception::Model->throw(
- object => $self,
- error => "Unexpected convert value: $convert, " . "expected lc or uc"
- ) unless defined $self->{convert_sub};
-}
-
-__PACKAGE__->meta->make_immutable;
-
-1;
-
-# ABSTRACT: Base class for configuration tree item
-
__END__
=pod
@@ -651,114 +362,25 @@ __END__
=head1 NAME
-Config::Model::AnyThing - Base class for configuration tree item
+Config::Model::Role::Grab - Role to grab data from elsewhere in the tree
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
- # internal class
+ $self->load_node( config_class_name => "...", %other_args);
=head1 DESCRIPTION
-This class must be inherited by all nodes or leaves of the
-configuration tree.
-
-AnyThing provides some methods and no constructor.
-
-=head1 Introspection methods
-
-=head2 element_name()
-
-Returns the element name that contain this object.
-
-=head2 index_value()
-
-For object stored in an array or hash element, returns the index (or key)
-containing this object.
-
-=head2 parent()
-
-Returns the node containing this object. May return undef if C<parent()>
-is called on the root of the tree.
-
-=head2 container_type()
-
-Returns the type (e.g. C<list> or C<hash> or C<leaf> or C<node> or
-C<warped_node>) of the element containing this object.
-
-=head2 root()
-
-Returns the root node of the configuration tree.
-
-=head2 location()
-
-Returns the node location in the configuration tree. This location
-conforms with the syntax defined by L</grab()> method.
-
-=head2 location_short()
-
-Returns the node location in the configuration tree. This location truncates
long
-indexes to be readable. It cannot be used by L</grab()> method.
-
-=head2 composite_name
-
-Return the element name with its index (if any). I.e. returns C<foo:bar> or
-C<foo>.
-
-=head2 composite_name_short
-
-Return the element name with its index (if any). Too long indexes are
-truncated to be readable.
-
-=head1 Annotation
-
-Annotation is a way to store miscellaneous information associated to
-each node. (Yeah... comments). Reading and writing annotation makes
-sense only if they can be read from and written to the configuration
-file, hence the need for the following method:
-
-=head2 backend_support_annotation
+Role used to let a tree item (i.e. node, hash, list or leaf) to grab
+another item or value from the configuration tree using a path (a bit
+like an xpath path with a different syntax).
-Returns 1 if at least one of the backends attached to a parent node
-support to read and write annotations (aka comments) in the
-configuration file.
+=head1 METHODS
-=head2 support_annotation
-
-Returns 1 if at least one of the backends support to read and write annotations
-(aka comments) in the configuration file.
-
-=head2 annotation( [ note1, [ note2 , ... ] ] )
-
-Without argument, return a string containing the object's annotation (or
-an empty string).
-
-With several arguments, join the arguments with "\n", store the annotations
-and return the resulting string.
-
-=head2 load_pod_annotation ( pod_string )
-
-Load annotations in configuration tree from a pod document. The pod must
-be in the form:
-
- =over
-
- =item path
-
- Annotation text
-
- =back
-
-=head2 clear_annotation
-
-Clear the annotation of an element
-
-=head1 Information management
-
-=head2 grab(...)
+=head2 grab
Grab an object from the configuration tree.
@@ -841,104 +463,33 @@ considered when going up the tree.
=back
-=head2 grab_value(...)
+=head2 grab_value
-Like L</grab(...)>, but returns the value of a leaf or check_list object, not
+Like L</grab>, but returns the value of a leaf or check_list object, not
just the leaf object.
C<grab_value> raises an exception if following the steps ends on anything but a
leaf or a check_list.
-=head2 grab_annotation(...)
+=head2 grab_annotation
-Like L</grab(...)>, but returns the annotation of an object.
+Like L</grab>, but returns the annotation of an object.
-=head2 grab_root()
+=head2 grab_root
Returns the root of the configuration tree.
-=head2 grab_ancestor( Foo )
-
-Go up the configuration tree until the C<Foo> configuration class is found.
Returns
-the found node or undef.
-
-=head2 notify_change(...)
-
-Notify the instance of semantic changes. Parameters are:
-
-=over 8
-
-=item old
-
-old value. (optional)
-
-=item new
-
-new value (optional)
-
-=item path
-
-Location of the changed parameter starting from root node. Default to
C<$self->location>.
-
-=item name
+=head2 grab_ancestor
-element name. Default to C<$self->element_name>
-
-=item index
-
-If the changed parameter is part of a hash or an array, C<index>
-contains the key or the index to get the changed parameter.
-
-=item note
-
-information about the change. Mandatory of neither old or new value are
defined.
-
-=item really
-
-When set to 1, force recording of change even if in initial load phase.
-
-=item needs_save
-
-internal parameter.
-
-=back
-
-=head2 show_message( string )
-
-Forwarded to L<Config::Model::Instance/"show_message( string )">.
-
-=head2 model_searcher ()
-
-Returns an object dedicated to search an element in the configuration
-model (respecting privilege level).
-
-This method returns a L<Config::Model::SearchElement> object. See
-L<Config::Model::Searcher> for details on how to handle a search.
-
-=head2 dump_as_data ( )
-
-Dumps the configuration data of the node and its siblings into a perl
-data structure.
-
-Returns a hash ref containing the data. See
-L<Config::Model::DumpAsData> for details.
-
-=head2 warp_error
-
-Returns a string describing any issue with L<Config::Model::Warper> object.
-Returns '' if invoked on a tree object without warp specification.
-
-=head1 AUTHOR
+Parameter: a configuration class name
-Dominique Dumont, (ddumont at cpan dot org)
+Go up the configuration tree until a node using the configuration
+class is found. Returns the found node or undef.
-=head1 SEE ALSO
+Example:
-L<Config::Model>,
-L<Config::Model::Instance>,
-L<Config::Model::Node>,
-L<Config::Model::Loader>,
-L<Config::Model::Dumper>
+ # returns a Config::Model::Node object for a Systemd::Service config class
+ $self->grab('Systemd::Service');
=head1 AUTHOR
diff --git a/lib/Config/Model/Role/HelpAsText.pm
b/lib/Config/Model/Role/HelpAsText.pm
new file mode 100644
index 0000000..706b8b6
--- /dev/null
+++ b/lib/Config/Model/Role/HelpAsText.pm
@@ -0,0 +1,97 @@
+#
+# This file is part of Config-Model
+#
+# This software is Copyright (c) 2005-2016 by Dominique Dumont.
+#
+# This is free software, licensed under:
+#
+# The GNU Lesser General Public License, Version 2.1, February 1999
+#
+package Config::Model::Role::HelpAsText;
+$Config::Model::Role::HelpAsText::VERSION = '2.095';
+# ABSTRACT: Transalet element help from pod to text
+
+use Mouse::Role;
+use strict;
+use warnings;
+use Pod::Text;
+use Pod::Simple 3.23;
+use 5.10.1;
+
+requires('get_help');
+
+sub get_help_as_text {
+ my $self = shift;
+
+ my $pod = $self->get_help(@_) ;
+ return undef unless defined $pod;
+
+ my $parser = Pod::Text->new(
+ indent => 0,
+ nourls => 1,
+ );
+
+ # require Pod::Simple 3.23
+ $parser->parse_characters('utf8');
+
+ my $output = '';
+ $parser->output_string(\$output);
+
+ $parser->parse_string_document("=pod\n\n" . $pod);
+ $output =~ s/[\n\s]+$//;
+
+ return $output;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Config::Model::Role::HelpAsText - Transalet element help from pod to text
+
+=head1 VERSION
+
+version 2.095
+
+=head1 SYNOPSIS
+
+ $self->get_help_as_text( ... );
+
+=head1 DESCRIPTION
+
+Role used to translate Config::Model help text or description from pod
+to text. The provided method should be used when the help text should
+be displayed on STDOUT.
+
+This functionality is provided as a role because the interface to
+L<Pod::Text> is not so easy.
+
+=head1 METHODS
+
+=head2 get_help_as_text
+
+Calls C<get_help> and tranlate the output to text.
+
+=head2 SEE ALSO
+
+L<Pod::Text>, L<Pod::Simple>
+
+=head1 AUTHOR
+
+Dominique Dumont
+
+=head1 COPYRIGHT AND LICENSE
+
+This software is Copyright (c) 2005-2016 by Dominique Dumont.
+
+This is free software, licensed under:
+
+ The GNU Lesser General Public License, Version 2.1, February 1999
+
+=cut
diff --git a/lib/Config/Model/Role/NodeLoader.pm
b/lib/Config/Model/Role/NodeLoader.pm
index 8a5395e..1947592 100644
--- a/lib/Config/Model/Role/NodeLoader.pm
+++ b/lib/Config/Model/Role/NodeLoader.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Role::NodeLoader;
-$Config::Model::Role::NodeLoader::VERSION = '2.094';
+$Config::Model::Role::NodeLoader::VERSION = '2.095';
# ABSTRACT: Load Node element in configuration tree
use Mouse::Role;
@@ -44,7 +44,7 @@ Config::Model::Role::NodeLoader - Load Node element in
configuration tree
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Role/WarpMaster.pm
b/lib/Config/Model/Role/WarpMaster.pm
index e501dc7..8a99d37 100644
--- a/lib/Config/Model/Role/WarpMaster.pm
+++ b/lib/Config/Model/Role/WarpMaster.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Role::WarpMaster;
-$Config::Model::Role::WarpMaster::VERSION = '2.094';
+$Config::Model::Role::WarpMaster::VERSION = '2.095';
# ABSTRACT: register and trigger a warped element
use Mouse::Role;
@@ -106,7 +106,7 @@ Config::Model::Role::WarpMaster - register and trigger a
warped element
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/SearchElement.pm
b/lib/Config/Model/SearchElement.pm
index a601043..146acee 100644
--- a/lib/Config/Model/SearchElement.pm
+++ b/lib/Config/Model/SearchElement.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::SearchElement;
-$Config::Model::SearchElement::VERSION = '2.094';
+$Config::Model::SearchElement::VERSION = '2.095';
use Log::Log4perl qw(get_logger :levels);
use Carp;
use strict;
@@ -333,7 +333,7 @@ Config::Model::SearchElement - Search an element in a
configuration model
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/SimpleUI.pm b/lib/Config/Model/SimpleUI.pm
index 465c1c9..d397181 100644
--- a/lib/Config/Model/SimpleUI.pm
+++ b/lib/Config/Model/SimpleUI.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::SimpleUI;
-$Config::Model::SimpleUI::VERSION = '2.094';
+$Config::Model::SimpleUI::VERSION = '2.095';
use Carp;
use 5.010;
use strict;
@@ -52,10 +52,14 @@ my $desc_sub = sub {
if (@_) {
my $item;
while ( $item = shift ) {
- if ( $obj->isa('Config::Model::Node') ) {
+ if ( $obj->get_type() eq 'node' ) {
my $type = $obj->element_type($item);
my $elt = $obj->fetch_element($item);
- $res .= "element $item (type $type): " . $obj->get_help($item)
. "\n";
+ my $help = $obj->get_help_as_text($item);
+ $res .= "element $item (type $type)";
+ $res .= ": " if $help;
+ $res .= "\n" if $help =~ /\n/ or length($help) > 40 ;
+ $res .= $help . "\n" if $help;
if ( $type eq 'leaf' and $elt->value_type eq 'enum' ) {
$res .= " possible values: " . join( ', ',
$elt->get_choice ) . "\n";
}
@@ -63,7 +67,7 @@ my $desc_sub = sub {
}
}
else {
- $res = $obj->get_help();
+ $res = $obj->get_help_as_text();
}
return $res;
};
@@ -330,7 +334,7 @@ Config::Model::SimpleUI - Simple interface for Config::Model
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/TermUI.pm b/lib/Config/Model/TermUI.pm
index a9bcf50..4a47e11 100644
--- a/lib/Config/Model/TermUI.pm
+++ b/lib/Config/Model/TermUI.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::TermUI;
-$Config::Model::TermUI::VERSION = '2.094';
+$Config::Model::TermUI::VERSION = '2.095';
use Carp;
use utf8; # so literals and identifiers can be in UTF-8
use v5.12; # or later to get "unicode_strings" feature
@@ -228,7 +228,7 @@ Config::Model::TermUI - Interactive command line interface
for cme
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/TreeSearcher.pm b/lib/Config/Model/TreeSearcher.pm
index 5ac6629..8bdc931 100644
--- a/lib/Config/Model/TreeSearcher.pm
+++ b/lib/Config/Model/TreeSearcher.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::TreeSearcher;
-$Config::Model::TreeSearcher::VERSION = '2.094';
+$Config::Model::TreeSearcher::VERSION = '2.095';
use Mouse;
use Mouse::Util::TypeConstraints;
@@ -147,7 +147,7 @@ Config::Model::TreeSearcher - Search tree for match in
value, description...
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -225,7 +225,7 @@ Search in all the items above
Search the keyword or pattern in the tree. The search is done in a case
insensitive manner. Returns a list of path pointing
-to the matching tree element. See L<Config::Model::AnyThing/grab(...)> for
details
+to the matching tree element. See L<Config::Model::Role::Grab/grab> for details
on the path syntax.
=head1 BUGS
diff --git a/lib/Config/Model/Utils/GenClassPod.pm
b/lib/Config/Model/Utils/GenClassPod.pm
index 81e98d5..3301b98 100644
--- a/lib/Config/Model/Utils/GenClassPod.pm
+++ b/lib/Config/Model/Utils/GenClassPod.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Utils::GenClassPod;
-$Config::Model::Utils::GenClassPod::VERSION = '2.094';
+$Config::Model::Utils::GenClassPod::VERSION = '2.095';
# ABSTRACT: generate pod documentation from configuration models
use strict;
@@ -55,7 +55,7 @@ Config::Model::Utils::GenClassPod - generate pod
documentation from configuratio
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Value.pm b/lib/Config/Model/Value.pm
index b2991bf..734590f 100644
--- a/lib/Config/Model/Value.pm
+++ b/lib/Config/Model/Value.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Value;
-$Config::Model::Value::VERSION = '2.094';
+$Config::Model::Value::VERSION = '2.095';
use 5.10.1;
use Mouse;
@@ -32,6 +32,8 @@ use List::MoreUtils qw(any) ;
extends qw/Config::Model::AnyThing/;
with "Config::Model::Role::WarpMaster";
+with "Config::Model::Role::Grab";
+with "Config::Model::Role::HelpAsText";
my $logger = get_logger("Tree::Element::Value");
my $change_logger = get_logger("Anything::Change");
@@ -1805,7 +1807,7 @@ Config::Model::Value - Strongly typed configuration value
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/Value/LayeredInclude.pm
b/lib/Config/Model/Value/LayeredInclude.pm
index 24411a2..8552b09 100644
--- a/lib/Config/Model/Value/LayeredInclude.pm
+++ b/lib/Config/Model/Value/LayeredInclude.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Value::LayeredInclude;
-$Config::Model::Value::LayeredInclude::VERSION = '2.094';
+$Config::Model::Value::LayeredInclude::VERSION = '2.095';
use 5.010;
use strict;
use warnings;
@@ -108,7 +108,7 @@ Config::Model::Value::LayeredInclude - Include a sub layer
configuration
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
diff --git a/lib/Config/Model/ValueComputer.pm
b/lib/Config/Model/ValueComputer.pm
index 82c90ce..6b0dd96 100644
--- a/lib/Config/Model/ValueComputer.pm
+++ b/lib/Config/Model/ValueComputer.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::ValueComputer;
-$Config::Model::ValueComputer::VERSION = '2.094';
+$Config::Model::ValueComputer::VERSION = '2.095';
use Mouse;
use MouseX::StrictConstructor;
@@ -581,7 +581,7 @@ Config::Model::ValueComputer - Provides configuration value
computation
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -643,7 +643,7 @@ A string formula that use variables and replace function.
A set of variable and their relative location in the tree (using the
notation explained in
-L<grab() method|Config::Model::AnyThing/"grab(...)">
+L<grab() method|Config::Model::Role::Grab/grab">
=item *
@@ -658,7 +658,7 @@ An optional parameter to force a Perl eval of a string.
B<Note>: A variable must point to a valid location in the configuration
tree. Even when C<&index()> or C<$replace{}> is used. After substitution
of these functions, the string is used as a path (See
-L<grab()|Config::Model::AnyThing/"grab(...)">) starting from the
+L<grab()|Config::Model::Role::Grab/grab">) starting from the
computed value. Hence the path must begin with C<!> to go back to root
node, or C<-> to go up a level.
diff --git a/lib/Config/Model/WarpedNode.pm b/lib/Config/Model/WarpedNode.pm
index cbfe274..c83fbf4 100644
--- a/lib/Config/Model/WarpedNode.pm
+++ b/lib/Config/Model/WarpedNode.pm
@@ -8,9 +8,8 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::WarpedNode;
-$Config::Model::WarpedNode::VERSION = '2.094';
+$Config::Model::WarpedNode::VERSION = '2.095';
use Mouse;
-with "Config::Model::Role::NodeLoader";
use Carp qw(cluck croak);
@@ -23,6 +22,9 @@ use Scalar::Util qw/weaken/;
extends qw/Config::Model::AnyThing/;
+with "Config::Model::Role::NodeLoader";
+with "Config::Model::Role::Grab";
+
my $logger = get_logger("Tree::Node::Warped");
# don't authorize to warp 'morph' parameter as it may lead to
@@ -80,7 +82,7 @@ foreach my $method (
qw/fetch_element config_class_name copy_from get_element_name
has_element is_element_available element_type load
fetch_element_value get_type get_cargo_type dump_tree
- describe get_help children get set accept_regexp/
+ describe get_help get_help_as_text children get set accept_regexp/
) {
# to register new methods in package
no strict "refs";
@@ -311,7 +313,7 @@ Config::Model::WarpedNode - Node that change config class
properties
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -405,7 +407,7 @@ Always set to C<warped_node>.
=item follow
-L<Grab string|Config::Model::AnyThing/"grab(...)"> leading to the
+L<Grab string|Config::Model::Role::Grab/grab"> leading to the
C<Config::Model::Value> warp master.
See L<Config::Model::Warper/"Warp follow argument"> for details.
diff --git a/lib/Config/Model/Warper.pm b/lib/Config/Model/Warper.pm
index c5cb31b..ab68c90 100644
--- a/lib/Config/Model/Warper.pm
+++ b/lib/Config/Model/Warper.pm
@@ -8,7 +8,7 @@
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::Warper;
-$Config::Model::Warper::VERSION = '2.094';
+$Config::Model::Warper::VERSION = '2.095';
use Mouse;
use Log::Log4perl qw(get_logger :levels);
@@ -620,7 +620,7 @@ Config::Model::Warper - Warp tree properties
=head1 VERSION
-version 2.094
+version 2.095
=head1 SYNOPSIS
@@ -654,13 +654,13 @@ and C<rules>:
=head2 Warp follow argument
-L<Grab string|Config::Model::AnyThing/"grab(...)"> leading to the
+L<Grab string|Config::Model::Role::Grab/grab> leading to the
C<Config::Model::Value> or L<Config::Model::CheckList> warp master. E.g.:
follow => '! tree_macro'
In case of several warp master, C<follow> is set to an array ref
-of several L<grab string|Config::Model::AnyThing/"grab(...)">:
+of several L<grab string|Config::Model::Role::Grab/grab>:
follow => [ '! macro1', '- macro2' ]
@@ -822,7 +822,7 @@ warp master is an enumerated type)
When a warped object is created, the constructor registers to the
warp masters. The warp master are found by using the special string
passed to the C<follow> parameter. As explained in
-L<grab method|Config::Model::AnyThing/"grab(...)">,
+L<grab method|Config::Model::Role::Grab/grab>,
the string provides the location of the warp master in the
configuration tree using a symbolic form.
diff --git a/t/annotation.t b/t/annotation.t
index b708005..9b3c61b 100644
--- a/t/annotation.t
+++ b/t/annotation.t
@@ -1,12 +1,13 @@
# -*- cperl -*-
use ExtUtils::testlib;
-use Test::More tests => 19;
+use Test::More ;
use Test::Memory::Cycle;
use Config::Model;
use Config::Model::Annotation;
use File::Path;
use Data::Dumper;
+use 5.10.0;
use warnings;
no warnings qw(once);
@@ -52,9 +53,14 @@ my $step =
. '! hash_a:X2=x hash_a:Y2=xy hash_a:toto#"index comment"
hash_b:X3=xy my_check_list=X2,X3';
ok( $root->load( step => $step ), "set up data in tree with '$step'" );
-
-my @annotate = map { [ $_ => "$_ annotation" ] }
- ( 'std_id', 'std_id:bc X', 'my_check_list', 'olist:0', 'olist:2' );
+$inst->clear_changes;
+
+my @annotate = map
+ { [ $_ => "$_ annotation" ] }
+ (
+ 'std_id', 'std_id', # test that 2 saves of same value is tracked once
+ 'std_id:bc X', 'my_check_list', 'olist:0', 'olist:2'
+ );
my %expect = ( 'hash_a:toto' => "index comment", 'olist:1' => 'olist1_comment'
);
foreach (@annotate) {
@@ -64,10 +70,18 @@ foreach (@annotate) {
ok( 1, "set annotation of $l" );
}
+say "pending changes:\n".$inst->list_changes if $trace;
+is( $inst->needs_save, 5, "verify instance needs_save status after storing
only annotations" );
+$inst->clear_changes;
+
is( $root->grab("std_id:ab X")->annotation('to delete'), 'to delete', "test
clear annotation" );
is( $root->grab("std_id:ab X")->clear_annotation, '', "test clear annotation"
);
+say "pending changes:\n".$inst->list_changes if $trace;
+is( $inst->needs_save, 2, "verify instance needs_save status after
store/delete annotations" );
+$inst->clear_changes;
+
my $annotate_saver = Config::Model::Annotation->new(
config_class_name => 'Master',
instance => $inst,
@@ -132,4 +146,6 @@ my $h3_ref = $saver2->get_annotation_hash();
print Dumper ($h3_ref) if $trace;
is_deeply( $h3_ref, \%expect3, "check loaded annotation data with non-empty
tree" );
-memory_cycle_ok($model);
+memory_cycle_ok($model, "memory cycles");
+
+done_testing;
diff --git a/t/backend_mgr.t b/t/backend_mgr.t
index 52f9aa0..fc4200f 100644
--- a/t/backend_mgr.t
+++ b/t/backend_mgr.t
@@ -4,15 +4,14 @@ use ExtUtils::testlib;
use Test::More;
use Test::Memory::Cycle;
use Config::Model;
-use File::Path;
-use File::Copy;
+use Path::Tiny 0.070;
use Test::Warn;
use Test::Exception;
use Test::File::Contents;
use warnings;
no warnings qw(once);
-
+use 5.10.1;
use strict;
use vars qw/$model/;
@@ -40,15 +39,15 @@ else {
ok( 1, "compiled" );
# pseudo root for config files
-my $wr_root = 'wr_root';
-my $root1 = "$wr_root/test1/";
-my $root2 = "$wr_root/test2/";
-my $root3 = "$wr_root/test3/";
+my $wr_root = path('wr_root');
+my $root1 = $wr_root->child('test1');
+my $root2 = $wr_root->child('test2');
+my $root3 = $wr_root->child('test3');
my $conf_dir = '/etc/test/';
# cleanup before tests
-rmtree($wr_root);
+$wr_root->remove_tree;
# model declaration
$model->create_config_class(
@@ -57,7 +56,10 @@ $model->create_config_class(
[qw/X Y Z/] => {
type => 'leaf',
value_type => 'enum',
- choice => [qw/Av Bv Cv/] } ] );
+ choice => [qw/Av Bv Cv/]
+ }
+ ]
+);
$model->create_config_class(
name => 'Level1',
@@ -86,7 +88,9 @@ $model->create_config_class(
bar => {
type => 'node',
config_class_name => 'Level2',
- } ] );
+ }
+ ]
+);
$model->create_config_class(
name => 'SameReadWriteSpec',
@@ -106,7 +110,10 @@ $model->create_config_class(
bar => {
type => 'node',
config_class_name => 'Level2',
- } ] );
+ },
+ int_with_max => {qw/type leaf value_type integer max 10/},
+ ]
+);
$model->create_config_class(
name => 'Master',
@@ -144,7 +151,8 @@ $model->create_config_class(
type => 'node',
config_class_name => 'SameReadWriteSpec',
},
- ] );
+ ]
+);
$model->create_config_class(
name => 'FromScratch',
@@ -158,7 +166,8 @@ $model->create_config_class(
element => [
aa => { type => 'leaf', value_type => 'string' },
- ] );
+ ]
+);
$model->create_config_class(
name => 'CdsWithFile',
@@ -172,7 +181,8 @@ $model->create_config_class(
element => [
aa => { type => 'leaf', value_type => 'string' },
- ] );
+ ]
+);
$model->create_config_class(
name => 'CdsWithNoFile',
@@ -181,7 +191,8 @@ $model->create_config_class(
element => [
aa => { type => 'leaf', value_type => 'string' },
- ] );
+ ]
+);
$model->create_config_class(
name => 'SimpleRW',
@@ -196,7 +207,8 @@ $model->create_config_class(
element => [
aa => { type => 'leaf', value_type => 'string' },
- ] );
+ ]
+);
#global variable to snoop on read config action
my %result;
@@ -264,7 +276,7 @@ package main;
my $i_fail = $model->instance(
instance_name => 'failed_inst',
root_class_name => 'Master',
- root_dir => $root1,
+ root_dir => $root1->stringify,
backend => 'perl_file',
);
throws_ok {
@@ -278,7 +290,7 @@ is( $result{master_read}, undef, "Master read conf dir" );
my $i_zero = $model->instance(
instance_name => 'zero_inst',
root_class_name => 'Master',
- root_dir => $root1,
+ root_dir => $root1->stringify,
);
ok( $i_zero, "Created instance (from scratch)" );
@@ -320,15 +332,15 @@ $i_zero->write_back( backend => 'all', force => 1 );
# check written files
foreach my $suffix (qw/cds ini/) {
map {
- my $f = "$root1$conf_dir/$_.$suffix";
- ok( -e $f, "check written file $f" );
+ my $f = $root1->child("$conf_dir/$_.$suffix");
+ ok( $f->is_file, "check written file $f" );
} ( 'zero_inst', 'zero_inst/level1', 'zero_inst/samerw' );
}
foreach my $suffix (qw/pl/) {
map {
- my $f = "$root1$conf_dir/$_.$suffix";
- ok( -e "$f", "check written file $f" );
+ my $f = $root1->child("$conf_dir/$_.$suffix");
+ ok( $f->is_file, "check written file $f" );
} ( 'zero_inst', 'zero_inst/level1' );
}
@@ -342,12 +354,15 @@ $i_zero->write_back( backend => 'all', config_dir =>
$override, force => 1 );
# check written files
foreach my $suffix (qw/cds ini/) {
- map { ok( -e "$root1$override$_.$suffix", "check written file
$root1$override$_.$suffix" ); }
- ( 'zero_inst', 'zero_inst/level1', 'zero_inst/samerw' );
+ map {
+ ok( $root1->child("$override$_.$suffix")->is_file,
+ "check written file ".$root1->child("$override$_.$suffix") );
+ } ( 'zero_inst', 'zero_inst/level1', 'zero_inst/samerw' );
}
foreach my $suffix (qw/pl/) {
- map { ok( -e "$root1$override$_.$suffix", "check written file
$root1$override$_.$suffix" ); }
- ( 'zero_inst', 'zero_inst/level1' );
+ map { ok( $root1->child("$override$_.$suffix")->is_file,
+ "check written file ".$root1->child("$override$_.$suffix") );
+ } ( 'zero_inst', 'zero_inst/level1' );
}
is( $result{wr_stuff}, $override, 'check custom overridden write dir' );
@@ -368,24 +383,22 @@ my %cds = (
"$inst2/level1" => 'bar X=Av Y=Bv - '
);
-my $dir2 = "$root2/etc/test/";
-mkpath( $dir2 . $inst2, 0, 0755 ) || die "Can't mkpath $dir2.$inst2:$!";
+my $dir2 = $root2->child("etc/test/");
+$dir2->child($inst2)->mkpath();
# write input config files
foreach my $f ( keys %cds ) {
- my $fout = "$dir2/$f.cds";
+ my $fout = $dir2->child($f.'.cds');
next if -r $fout;
- open( FOUT, ">$fout" ) or die "can't open $fout:$!";
- print FOUT $cds{$f};
- close FOUT;
+ $fout->spew($cds{$f});
}
# create another instance
my $test2_inst = $model->instance(
root_class_name => 'Master',
instance_name => $inst2,
- root_dir => $root2,
+ root_dir => $root2->stringify,
);
ok( $test2_inst, "created second instance" );
@@ -412,13 +425,6 @@ samerw
';
is( $dump2, $expect2, "$inst2: check dump" );
-# test loading with ini files
-map {
- my $o = $_;
- s!$root1/zero!ini!;
- copy( $o, "$root2/$_" ) or die "can't copy $o $_:$!"
-} glob("$root1/*.ini");
-
# create another instance to load ini files
my $ini_inst = $model->instance(
root_class_name => 'Master',
@@ -440,15 +446,6 @@ $dump = $ini_inst->config_root->dump_tree;
is( $dump, $expect_custom, "ini_test: check dump" );
-unlink( glob("$root2/*.ini") );
-
-# test loading with pl files
-map {
- my $o = $_;
- s!$root1/zero!pl!;
- copy( $o, "$root2/$_" ) or die "can't copy $o $_:$!"
-} glob("$root1/*.pl");
-
# create another instance to load pl files
my $pl_inst = $model->instance(
root_class_name => 'Master',
@@ -464,7 +461,7 @@ is( $dump, $expect_custom, "pl_test: check dump" );
my $scratch_i = $model->instance(
root_class_name => 'FromScratch',
instance_name => 'scratch_inst',
- root_dir => $root3,
+ root_dir => $root3->stringify,
);
ok( $scratch_i, "Created instance from scratch to load cds files" );
@@ -478,7 +475,7 @@ ok( -e "$root3/$conf_dir/scratch_inst.cds", "wrote cds
config file" );
my $cdswf = $model->instance(
root_class_name => 'CdsWithFile',
instance_name => 'cds_with_file_inst',
- root_dir => $root3,
+ root_dir => $root3->stringify,
);
ok( $cdswf, "Created instance to load custom cds file" );
@@ -489,14 +486,13 @@ is( $cdswf->config_root->dump_tree, $expect, "check dump"
);
$cdswf->write_back;
-my $toto_conf = "$root3/$conf_dir/toto.conf";
-copy( "$root3/$conf_dir/scratch_inst.cds", $toto_conf )
+my $toto_conf = $root3->child("$conf_dir/scratch_inst.cds")->copy(
$root3->child("$conf_dir/toto.conf"))
or die "can't copy scratch_inst.cds to toto.conf:$!";
my $ctoto = $model->instance(
root_class_name => 'SimpleRW',
instance_name => 'custom_toto',
- root_dir => $root3,
+ root_dir => $root3->stringify,
);
ok( $ctoto, "Created instance to load custom custom toto file" );
@@ -520,7 +516,7 @@ my $scratch_conf = 'etc/test/scratch_inst.cds';
my $cdswnf = $model->instance(
root_class_name => 'CdsWithNoFile',
instance_name => 'cds_with_no_file_inst',
- root_dir => $root3,
+ root_dir => $root3->stringify,
config_file => $scratch_conf,
);
ok( $cdswnf, "Created instance to load overridden cds config file" );
diff --git a/t/dump_load_model.pm b/t/dump_load_model.pm
index 0b26d99..a872d41 100644
--- a/t/dump_load_model.pm
+++ b/t/dump_load_model.pm
@@ -127,6 +127,13 @@
cargo_type => 'leaf',
cargo_args => { value_type => 'string' },
},
+ ordered_hash_of_node => {
+ type => 'hash',
+ index_type => 'string',
+ ordered => 1,
+ cargo_type => 'node',
+ config_class_name => 'SubSlave2',
+ },
olist => {
type => 'list',
cargo_type => 'node',
diff --git a/t/hash_id_of_values.t b/t/hash_id_of_values.t
index 6d692c0..ebc5dd8 100644
--- a/t/hash_id_of_values.t
+++ b/t/hash_id_of_values.t
@@ -368,8 +368,18 @@ $oh->move_after( 'd', 'e' );
eq_or_diff( [ $oh->fetch_all_indexes ],
[qw/a z x e d/], "check index order of ordered_hash after move_after(d e)"
);
+$oh->sort;
+eq_or_diff( [ $oh->fetch_all_indexes ],
+ [qw/a d e x z/], "check index order of ordered_hash after sort" );
+
+$oh->insort('v')->store('v val');
+eq_or_diff( [ $oh->fetch_all_indexes ],
+ [qw/a d e v x z/], "check index order of ordered_hash after insort" );
+is($oh->fetch_with_id('v')->fetch,'v val',"check value entered with insort");
+
$inst->clear_changes;
$oh->clear;
+
is( $inst->needs_save, 1, "verify instance needs_save status after clear" );
eq_or_diff([$inst->list_changes],['ordered_hash: cleared all entries'],"check
change message after clear");
eq_or_diff( [ $oh->fetch_all_indexes ], [], "check index order of ordered_hash
after clear" );
diff --git a/t/load.t b/t/load.t
index 5877070..ad1ae3f 100644
--- a/t/load.t
+++ b/t/load.t
@@ -400,6 +400,15 @@ eq_or_diff( [$oh->fetch_all_indexes()],[qw/b a/], "check
unsorted keys") ;
$root->load('ordered_hash:.sort') ;
eq_or_diff( [$oh->fetch_all_indexes()],[qw/a b/], "check sorted keys") ;
+# test insort on ordered hash
+$root->load('ordered_hash:.insort(d,"dv")') ;
+eq_or_diff( [$oh->fetch_all_indexes()],[qw/a b d/], "check sorted keys after
insort") ;
+
+# test insort on ordered hash of node
+my $ohon = $root->fetch_element('ordered_hash_of_node');
+$root->load('ordered_hash_of_node:g aa2="g aa2 val" -
ordered_hash_of_node:.insort(d) aa2="d aa2 val"');
+eq_or_diff( [$ohon->fetch_all_indexes()],[qw/d g/], "check sorted keys") ;
+
# test combination of annotation plus load and some utf8
$step = 'std_id#std_id_note ! std_id:ab#std_id_ab_note X=Bv X#X_note
- std_id:bc X=Av X#X2_note '
diff --git a/t/model_tests.d/multi-ini-examples/max-overflow/etc/bar.conf
b/t/model_tests.d/multi-ini-examples/max-overflow/etc/bar.conf
new file mode 100644
index 0000000..d6cf8ff
--- /dev/null
+++ b/t/model_tests.d/multi-ini-examples/max-overflow/etc/bar.conf
@@ -0,0 +1 @@
+int_with_max=100
\ No newline at end of file
diff --git a/t/model_tests.d/multi-ini-test-conf.pl
b/t/model_tests.d/multi-ini-test-conf.pl
new file mode 100644
index 0000000..5da431b
--- /dev/null
+++ b/t/model_tests.d/multi-ini-test-conf.pl
@@ -0,0 +1,71 @@
+#
+# This file is part of Config-Model
+#
+# This software is Copyright (c) 2005-2016 by Dominique Dumont.
+#
+# This is free software, licensed under:
+#
+# The GNU Lesser General Public License, Version 2.1, February 1999
+#
+
+# test inifile backend with multiple ini files
+
+# specify the name of the class to test
+$model_to_test = "MultiMiniIni";
+
+# create minimal model to test ini file backend.
+
+# this class is used by MultiMiniIni class below
+$model->create_config_class(
+ name => 'MultiIniTest::Class',
+ element => [
+ int_with_max => {qw/type leaf value_type integer max 10/},
+ ],
+ read_config => [{
+ backend => 'IniFile',
+ config_dir => '/etc/',
+ file => '&index.conf',
+ auto_create => 1,
+ }],
+);
+
+$model->create_config_class(
+ name => 'MultiMiniIni',
+ element => [
+ service => {
+ type => 'hash',
+ index_type => 'string',
+ # require to trigger load of bar.conf
+ default_keys => 'bar',
+ cargo => {
+ type => 'node',
+ config_class_name => 'MultiIniTest::Class'
+ }
+ },
+ ],
+ read_config => [{
+ backend => 'Yaml',
+ config_dir => '/etc/',
+ file => 'service.yml',
+ auto_create => 1,
+ }],
+);
+
+
+# the test suite
+@tests = (
+ {
+ name => 'max-overflow',
+ # work only with Config::Model > 2.094 because of an obscure
+ # initialisation bug occuring while loading a bad value in
+ # a sub-node (thanks systemd)
+ load => 'service:bar int_with_max=9',
+ file_check_sub => sub {
+ my $list_ref = shift ;
+ # file added because of default bar key
+ push @$list_ref, "/etc/service.yml" ;
+ },
+ },
+);
+
+1;
--
Alioth's /usr/local/bin/git-commit-notice on
/srv/git.debian.org/git/pkg-perl/packages/libconfig-model-perl.git
_______________________________________________
Pkg-perl-cvs-commits mailing list
Pkg-perl-cvs-commits@lists.alioth.debian.org
http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits
