#
# This file is part of Config-Model
#
# This software is Copyright (c) 2014 by Dominique Dumont.
#
# This is free software, licensed under:
#
# The GNU Lesser General Public License, Version 2.1, February 1999
#
package Config::Model::AnyThing;
$Config::Model::AnyThing::VERSION = '2.057';
use Mouse;
# FIXME: must cleanup warp mechanism to implement this
# use MouseX::StrictConstructor;
use Pod::POM;
use Carp;
use Log::Log4perl qw(get_logger :levels);
use 5.10.1;
my $logger = get_logger("Anything");
my $change_logger = get_logger("Anything::Change");
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 );
# 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 );
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 .= '[truncated...]' if @idx;
return $idx ;
}
## 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} = '';
}
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( step => $path )->annotation($note);
}
}
}
## 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 ( $step, $mode, $autoadd, $type, $grab_non_available, $check ) =
( undef, 'strict', 1, undef, 0, 'yes' );
my %args = @_ > 1 ? @_ : ( step => $_[0] );
$step = 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: step parameter must be a string " . "or an array ref" )
unless ref $step eq 'ARRAY' || not ref $step;
# accept commands, grep remove empty items left by spurious spaces
my $huge_string = ref $step ? join( ' ', @$step ) : $step;
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') ) {
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($arg) if defined $action;
push @found, $next_obj;
}
# check element type
if ( defined $type ) {
while ( @found and $found[-1]->get_type ne $type ) {
Config::Model::Exception::WrongType->throw(
object => $found[-1],
function => 'grab',
got_type => $found[-1]->get_type,
expected_type => $type,
info => "requested with step '$step'"
) 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 ? ( step => $_[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 ? ( step => $_[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
);
}
}
}
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
=encoding UTF-8
=head1 NAME
Config::Model::AnyThing - Base class for configuration tree item
=head1 VERSION
version 2.057
=head1 SYNOPSIS
# internal class
=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 composite_name
Return the element name with its index (if any). I.e. returns C<foo:bar> or
C<foo>.
=head1 Annotation
Annotation is a way to store miscellaneous information associated to
each node. (Yeah... comments) These comments will be saved outside of
the configuration file and restored the next time the command is run.
=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(...)
Grab an object from the configuration tree.
Parameters are:
=over
=item 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> will throw an exception if no object is found
using the passed string. When set to C<adaptative>, the object found at last will
be returned. For instance, for the step C<good_step wrong_step>, only
the object held by C<good_step> will be returned. When set to C<loose>, grab
will return undef in case of problem. (default is C<strict>)
=item C<type>
Either C<node>, C<leaf>, C<hash> or C<list>. Returns only an object of
requested type. Depending on C<strict> value, C<grab> will either
throw an exception or return the last found object of requested type.
(optional, default to C<undef>, which means any type of object)
=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 will return an object even if this one is not
available. I.e. even if this element was warped out. (default is 0).
=back
The C<step> 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 will return the value of a leaf or check_list object, not
just the leaf object.
Will raise an exception if following the steps ends on anything but a
leaf or a check_list.
=head2 grab_annotation(...)
Like L</grab(...)>, but will return 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:
=over 8
=item old
old value.
=item new
new value
=item path
Location of the changed parameter starting from root node. Default to C<$self->location>.
=item name
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 msg
change message. When not empty, old and new values are not shown.
=item note
note displayed along the changed values (or message)
=item really
When set to 1, force recording of change even if in initial load phase.
=item needs_save
internal parameter.
=back
=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
Dominique Dumont, (ddumont at cpan dot org)
=head1 SEE ALSO
L<Config::Model>,
L<Config::Model::Instance>,
L<Config::Model::Node>,
L<Config::Model::Loader>,
L<Config::Model::Dumper>
=head1 AUTHOR
Dominique Dumont
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2014 by Dominique Dumont.
This is free software, licensed under:
The GNU Lesser General Public License, Version 2.1, February 1999
=cut