libconfig-model-perl 2.061-1 / usr / share / perl5 / Config / Model / AnyThing.pm

#
# 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.061';
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 // ''; # 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} = '';
}

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.061

=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