libconfig-model-perl 2.097-2 / usr / share / perl5 / Config / Model / Loader.pm

#
# 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::Loader;
$Config::Model::Loader::VERSION = '2.097';
use Carp;
use strict;
use warnings;
use 5.10.1;

use Config::Model::Exception;
use Log::Log4perl qw(get_logger :levels);

my $logger = get_logger("Loader");

## load stuff, similar to grab, but used to set items in the tree
## starting from this node

sub new {
    bless {}, shift;
}

sub load {
    my $self = shift;

    my %args = @_;

    my $node = delete $args{node};

    croak "load error: missing 'node' parameter" unless defined $node;

    my $steps = delete $args{steps} // delete $args{step};
    croak "load error: missing 'steps' parameter" unless defined $steps;

    if (delete $args{experience}) {
        carp "load: experience parameter is deprecated";
    }

    my $inst = $node->instance;

    # tune value checking
    my $check = delete $args{check} || 'yes';
    croak __PACKAGE__, "load: unexpected check $check" unless $check =~ /yes|no|skip/;

    # accept commands
    my $huge_string = ref $steps ? join( ' ', @$steps ) : $steps;

    # do a split on ' ' but take quoted string into account
    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    # 'g' means that all commands are fed into @command array
    );         #"asdf ;

    #print "command is ",join('+',@command),"\n" ;

    my $current_node = $node;
    my $ret;
    do {
        $ret = $self->_load( $current_node, $check, \@command, 1 );
        $logger->debug("_load returned $ret");

        # found '!' command
        if ( $ret eq 'root' ) {
            $logger->debug("Setting current_node to root node");
            $current_node = $current_node->root;
        }
    } while ( $ret eq 'root' );

    if (@command) {
        my $str = "Error: could not execute the required command, ";
        if ($command[0] =~ m!^/([\w-]+)!) {
            $str .=  "the searched item '$1' was not found" ;
        }
        else {
            $str .= "you may have specified too many '-' in your command";
        }
        Config::Model::Exception::Load->throw(
            command => $command[0],
            error  => $str,
            object => $node
        ) if $check eq 'yes';
    }

    if (%args) {
        Config::Model::Exception::Internal->throw(
            error => __PACKAGE__ . " load: unexpected parameters: " . join( ', ', keys %args ) );
    }

    return $ret;
}

# returns elt action id subaction value
sub _split_cmd {
    my $cmd = shift;
    $logger->debug("split on: ->$cmd<-");

    my $quoted_string = qr/"(?: \\" | [^"] )* "/x;    # quoted string

    # do a split on ' ' but take quoted string into account
    my @command = (
        $cmd =~ m!^
	 (\w[\w-]*)? # element name can be alone
	 (?:
            (:~|:-[=~]?|:=~|:\.\w+|:[=<>@]?|~)       # action
            (?:
                  (?: \( ( $quoted_string | [^)]+ ) \) )  # capture parameters between braces
                | (
                    /[^/]+/      # regexp
                    | (?:
                       $quoted_string
                       | [^#=\.<>]+    # non action chars
                      )+
                  )
            )?
         )?
	 (?:
            (=~|.=|[=<>])          # apply regexp or assign or append
	    (
              (?:
                $quoted_string
                | [^#\s]                # or non whitespace
              )+                       # many
            )
	 )?
	 (?:
            \#              # optional annotation
	    (
              (?:
                 $quoted_string
                | [^\s]                # or non whitespace
              )+                       # many
            )
	 )?
     (.*)    # leftover
    !gx
    );

    my $leftout = pop @command;

    if ($leftout) {
        Config::Model::Exception::Load->throw(
            command => $cmd,
            error   => "Syntax error: spurious char at command end: '$leftout'. Did you forget double quotes ?"
        );
    }
    return wantarray ? @command : \@command;
}

my %load_dispatch = (
    node        => \&_walk_node,
    warped_node => \&_walk_node,
    hash        => \&_load_hash,
    check_list  => \&_load_check_list,
    list        => \&_load_list,
    leaf        => \&_load_leaf,
);

# return 'done', 'root', 'up', 'error'
sub _load {
    my ( $self, $node, $check, $cmdref, $at_top_level ) = @_;
    $at_top_level ||= 0;
    my $node_name = "'" . $node->name . "'";
    $logger->debug("_load: called on node $node_name");

    my $inst = $node->instance;

    my $cmd;
    while ( $cmd = shift @$cmdref ) {
        if ( $logger->is_debug ) {
            my $msg = $cmd;
            $msg =~ s/\n/\\n/g;
            $logger->debug("_load: Executing cmd '$msg' on node $node_name");
        }

        next if $cmd =~ /^\s*$/;

        if ( $cmd eq '!' ) {
            $logger->debug("_load: going to root, at_top_level is $at_top_level");

            # Do not change current node as we don't want to mess up =~ commands
            return 'root';
        }

        if ( $cmd eq '-' ) {
            $logger->debug("_load: going up");
            return 'up';
        }

        if ( $cmd =~ m!^/([\w-]+)! ) {
            my $search = $1;
            if ($node->has_element($search)) {
                $logger->debug("_load: search found node with element $search");
                $cmd =~ s!^/!! ;
            } else {
                $logger->debug("_load: searching node with element $search, going up");
                unshift @$cmdref, $cmd;
                return 'up';
            }
        }

        my @instructions = _split_cmd($cmd);
        my ( $element_name, $action, $function_param, $id, $subaction, $value, $note ) =
            @instructions;

        if ( $logger->is_debug ) {
            my @disp = map { defined $_ ? "'$_'" : '<undef>' } @instructions;
            $logger->debug("_load instructions: @disp (left: $cmd)");
        }

        if ( not defined $element_name and not defined $note ) {
            Config::Model::Exception::Load->throw(
                command => $cmd,
                error   => 'Syntax error: cannot find ' . 'element in command'
            );
        }

        unless ( defined $node ) {
            Config::Model::Exception::Load->throw(
                command => $cmd,
                error   => "Error: Got undefined node"
            );
        }

        unless ( $node->isa("Config::Model::Node")
            or $node->isa("Config::Model::WarpedNode") ) {
            Config::Model::Exception::Load->throw(
                command => $cmd,
                error   => "Error: Expected a node (even a warped node), got '" . $node->name . "'"
            );

            # below, has_element method from WarpedNode will raise
            # exception if warped_node is not available
        }

        if ( not defined $element_name and defined $note ) {
            $node->annotation($note);
            next;
        }

        unless ( $node->has_element($element_name) ) {
            Config::Model::Exception::UnknownElement->throw(
                object  => $node,
                element => $element_name,
            ) if $check eq 'yes';
            unshift @$cmdref, $cmd;
            return 'error';
        }

        unless ( $node->is_element_available( name => $element_name ) ) {
            Config::Model::Exception::UnavailableElement->throw(
                object  => $node,
                element => $element_name
            ) if $check eq 'yes';
            unshift @$cmdref, $cmd;
            return 'error';
        }

        unless ( $node->is_element_available( name => $element_name ) ) {
            Config::Model::Exception::RestrictedElement->throw(
                object  => $node,
                element => $element_name,
            ) if $check eq 'yes';
            unshift @$cmdref, $cmd;
            return 'error';
        }

        my $element_type = $node->element_type($element_name);

        my $method = $load_dispatch{$element_type};

        croak "_load: unexpected element type '$element_type' for $element_name"
            unless defined $method;

        $logger->debug("_load: calling $element_type loader on element $element_name");
        my $ret = $self->$method( $node, $check, \@instructions, $cmdref );
        $logger->debug("_load: $element_type loader on element $element_name returned $ret");
        die "Internal error: method dispatched for $element_type returned an undefined value "
            unless defined $ret;

        if ( $ret eq 'error' or $ret eq 'done' ) {
            $logger->debug("_load return: $node_name got $ret");
            return $ret;
        }
        if ( $ret eq 'root' and not $at_top_level ) {
            $logger->debug("_load return: $node_name got $ret");
            return 'root';
        }

        # ret eq up or ok -> go on with the loop
    }

    return 'done';
}

sub _load_note {
    my ( $self, $target_obj, $note, $instructions, $cmdref ) = @_;

    unquote($note);

    # apply note on target object
    if ( defined $note ) {
        if ( defined $target_obj ) {
            $target_obj->annotation($note);
        }
        else {
            Config::Model::Exception::Load->throw(
                command => $$cmdref,
                error   => "Error: cannot set annotation with '"
                    . join( "','", grep { defined $_ } @$instructions ) . "'"
            );
        }
    }
}

sub _walk_node {
    my ( $self, $node, $check, $inst, $cmdref ) = @_;

    my $element_name = shift @$inst;
    my $note         = pop @$inst;
    my $element      = $node->fetch_element($element_name);
    $self->_load_note( $element, $note, $inst, $cmdref );

    my @left = grep { defined $_ } @$inst;
    if (@left) {
        Config::Model::Exception::Load->throw(
            command => $inst,
            error   => "Don't know what to do with '@left' "
                . "for node element "
                . $element->element_name
        );
    }

    $logger->info( "Opening node element ", $element->name );

    return $self->_load( $element, $check, $cmdref );
}

sub unquote {
    map {
        if (defined $_) {
            s/(?<!\\)\\n/\n/g;
            s/\\\\/\\/g;
            s/^"// && s/"$// && s!\\"!"!g;
        }
    } @_;
}

sub _load_check_list {
    my ( $self, $node, $check, $inst, $cmdref ) = @_;
    my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst;

    my $element = $node->fetch_element( name => $element_name, check => $check );

    if ( defined $note and not defined $action and not defined $subaction ) {
        $self->_load_note( $element, $note, $inst, $cmdref );
        return 'ok';
    }

    if ( defined $subaction and $subaction eq '=' ) {
        $logger->debug("_load_check_list: set whole list");

        # valid for check_list or list
        $logger->info( "Setting check_list element ", $element->name, " with value ", $value );
        $element->load( $value, check => $check );
        $self->_load_note( $element, $note, $inst, $cmdref );
        return 'ok';
    }

    if ( not defined $action and defined $subaction ) {
        Config::Model::Exception::Load->throw(
            object  => $element,
            command => join( '', grep ( defined $_, @$inst ) ),
            error   => "Wrong assignment with '$subaction' on check_list"
        );
    }

    my $a_str = defined $action ? $action : '<undef>';

    Config::Model::Exception::Load->throw(
        object  => $element,
        command => join( '', map { $_ || '' } @$inst ),
        error   => "Wrong assignment with '$a_str' on check_list"
    );

}

# sub is called with  ( $self, $element, $check, $instance, @function_args )
# function_args are the arguments passed to the load command
my %dispatch_action = (
    list_leaf => {
        ':.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( $_[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; 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,
        ':-~' => \&_remove_matched_value,
        ':=~' => \&_substitute_value,
    },
    fallback => {
        ':-' => \&_remove_by_id,
        '~'  => \&_remove_by_id,
    }
);

my @equiv = qw/:@ :.sort :< :.push :> :.unshift/;
while (@equiv) {
    my ( $to, $from ) = splice @equiv, 0, 2;
    $dispatch_action{list_leaf}{$to} = $dispatch_action{list_leaf}{$from};
}

sub _insert_before {
    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, $cmdref, $id ) = @_;
    $logger->debug("_remove_by_id: removing id '$id'");
    $element->remove($id);
    return 'ok';
}

sub _remove_by_value {
    my ( $self, $element, $check, $inst, $cmdref, $rm_val ) = @_;

    $logger->debug("_remove_by_value value $rm_val");
    foreach my $idx ( $element->fetch_all_indexes ) {
        my $v = $element->fetch_with_id($idx)->fetch;
        $element->delete($idx) if defined $v and $v eq $rm_val;
    }

    return 'ok';
}

sub _remove_matched_value {
    my ( $self, $element, $check, $inst, $cmdref, $rm_val ) = @_;

    $logger->debug("_remove_matched_value $rm_val");

    $rm_val =~ s!^/|/$!!g;

    foreach my $idx ( $element->fetch_all_indexes ) {
        my $v = $element->fetch_with_id($idx)->fetch;
        $element->delete($idx) if defined $v and $v =~ /$rm_val/;
    }

    return 'ok';
}

sub _substitute_value {
    my ( $self, $element, $check, $inst, $cmdref, $s_val ) = @_;

    $logger->debug("_substitute_value $s_val");

    foreach my $idx ( $element->fetch_all_indexes ) {
        my $l = $element->fetch_with_id($idx);
        $self->_load_value( $l, $check, '=~', $s_val, $inst );
    }

    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;

    my $element = $node->fetch_element( name => $element_name, check => $check );

    my @f_args = grep { defined } ( ( $f_arg // $id // '' ) =~ /([^,"]+)|"([^"]+)"/g );

    my $elt_type   = $node->element_type($element_name);
    my $cargo_type = $element->cargo_type;

    if ( defined $note and not defined $action and not defined $subaction ) {
        $self->_load_note( $element, $note, $inst, $cmdref );
        return 'ok';
    }

    if ( defined $action and $action eq ':=' and $cargo_type eq 'leaf' ) {
        $logger->debug("_load_list: set whole list with ':=' action");

        # valid for check_list or list
        $logger->info( "Setting $elt_type element ", $element->name, " with '$id'" );
        $element->load( $id, check => $check );
        $self->_load_note( $element, $note, $inst, $cmdref );
        return 'ok';
    }

    # compat mode for list=a,b,c,d commands
    if (    not defined $action
        and defined $subaction
        and $subaction eq '='
        and $cargo_type eq 'leaf' ) {
        $logger->debug("_load_list: set whole list with '=' subaction'");

        # valid for check_list or list
        $logger->info( "Setting $elt_type element ", $element->name, " with '$value'" );
        $element->load( $value, check => $check );
        $self->_load_note( $element, $note, $inst, $cmdref );
        return 'ok';
    }

    unquote( $id, $value, $note );

    if ( defined $action ) {
        my $dispatch =
               $dispatch_action{ 'list_' . $cargo_type }{$action}
            || $dispatch_action{ 'list_*'}{$action}
            || $dispatch_action{$cargo_type}{$action}
            || $dispatch_action{'fallback'}{$action};
        if ($dispatch) {
            return $dispatch->( $self, $element, $check, $inst, $cmdref, @f_args );
        }
    }

    if ( not defined $action and defined $subaction ) {
        Config::Model::Exception::Load->throw(
            object  => $element,
            command => join( '', grep ( defined $_, @$inst ) ),
            error   => "Wrong assignment with '$subaction' on "
                . "element type: $elt_type, cargo_type: $cargo_type"
        );
    }

    if ( defined $action and $action eq ':' ) {
        unquote($id);
        my $obj = $element->fetch_with_id( index => $id, check => $check );
        $self->_load_note( $obj, $note, $inst, $cmdref );

        if ( $cargo_type =~ /node/ ) {

            # remove possible leading or trailing quote
            $logger->debug("_load_list: calling _load on node id $id");
            return $self->_load( $obj, $check, $cmdref );
        }

        return 'ok' unless defined $subaction;

        if ( $cargo_type =~ /leaf/ ) {
            $logger->debug("_load_list: calling _load_value on $cargo_type id $id");
            $self->_load_value( $obj, $check, $subaction, $value )
                and return 'ok';
        }
    }

    my $a_str = defined $action ? $action : '<undef>';

    Config::Model::Exception::Load->throw(
        object  => $element,
        command => join( '', map { $_ || '' } @$inst ),
        error   => "Wrong assignment with '$a_str' on "
            . "element type: $elt_type, cargo_type: $cargo_type"
    );

}

sub _load_hash {
    my ( $self, $node, $check, $inst, $cmdref ) = @_;
    my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst;

    unquote( $id, $value, $note );

    my $element = $node->fetch_element( name => $element_name, check => $check );
    my $cargo_type = $element->cargo_type;

    if ( defined $note and not defined $action ) {
        $self->_load_note( $element, $note, $inst, $cmdref );
        return 'ok';
    }

    if ( not defined $action ) {
        Config::Model::Exception::Load->throw(
            object  => $element,
            command => join( '', map { $_ || '' } @$inst ),
            error   => "Missing key (e.g. '$element_name:some_key') on hash element, cargo_type: $cargo_type"
        );
    }

    if ( $action eq ':~' ) {
        my @keys = $element->fetch_all_indexes;
        my $ret  = 'ok';
        $id =~ s!^/|/$!!g if $id;
        my @loop_on = $id ? grep { /$id/ } @keys : @keys;
        if ($logger->is_debug) {
            my $str = $id ? " with regex /$id/" : '';
            $logger->debug("_load_hash: looping$str on keys @loop_on");
        }

        my @saved_cmd = @$cmdref;
        foreach my $loop_id ( @loop_on ) {
            @$cmdref = @saved_cmd;    # restore command before loop
            $logger->debug("_load_hash: loop on id $loop_id");
            my $sub_elt = $element->fetch_with_id($loop_id);
            if ( $cargo_type =~ /node/ ) {

                # remove possible leading or trailing quote
                $ret = $self->_load( $sub_elt, $check, $cmdref );
            }
            elsif ( $cargo_type =~ /leaf/ ) {
                $ret = $self->_load_value( $sub_elt, $check, $subaction, $value );
            }
            else {
                Config::Model::Exception::Load->throw(
                    object  => $element,
                    command => join( '', @$inst ),
                    error   => "Hash assignment with '$action' on unexpected "
                        . "cargo_type: $cargo_type"
                );
            }

            $logger->debug("_load_hash: loop on id $loop_id returned $ret (left cmd: @$cmdref)");
            if ( $ret eq 'error') { return $ret; }
        }
        return $ret;
    }

    my @f_args = grep { defined } ( ( $f_arg // $id // '' ) =~ /([^,"]+)|"([^"]+)"/g );

    if ( defined $action ) {
        my $dispatch =
               $dispatch_action{ 'hash_' . $cargo_type }{$action}
            || $dispatch_action{ 'hash_*'}{$action}
            || $dispatch_action{$cargo_type}{$action}
            || $dispatch_action{'fallback'}{$action};
        if ($dispatch) {
            # todo missing arguments
            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 );

    if ( $action eq ':' and $cargo_type =~ /node/ ) {

        # remove possible leading or trailing quote
        $logger->debug("_load_hash: calling _load on node $id");
        if ( defined $subaction ) {
            Config::Model::Exception::Load->throw(
                object  => $element,
                command => join( '', @$inst ),
                error   => qq!Hash assignment with '$action"$id"$subaction"$value"' on unexpected !
                    . "cargo_type: $cargo_type"
            );
        }
        return $self->_load( $obj, $check, $cmdref );
    }
    elsif ( $action eq ':' and defined $subaction and $cargo_type =~ /leaf/ ) {
        $logger->debug("_load_hash: calling _load_value on leaf $id");
        $self->_load_value( $obj, $check, $subaction, $value )
            and return 'ok';
    }
    elsif ( $action eq ':' and defined $note ) {

        # action was just to store annotation
        return 'ok';
    }
    elsif ($action) {
        Config::Model::Exception::Load->throw(
            object  => $element,
            command => join( '', grep { defined $_ } @$inst ),
            error   => "Hash assignment with '$action' on unexpected " . "cargo_type: $cargo_type"
        );
    }
}

sub _load_leaf {
    my ( $self, $node, $check, $inst, $cmdref ) = @_;
    my ( $element_name, $action, $f_arg, $id, $subaction, $value, $note ) = @$inst;

    unquote( $id, $value );

    my $element = $node->fetch_element( name => $element_name, check => $check );
    $self->_load_note( $element, $note, $inst, $cmdref );

    if ( defined $action and $element->isa('Config::Model::Value')) {
        if ($action eq '~') {
            $logger->debug("_load_leaf: action '$action' deleting value");
            $element->store(value => undef, check => $check);
        }
        elsif ($action eq ':') {
            Config::Model::Exception::Load->throw(
                object  => $element,
                command => $inst,
                error   => "Error: list or hash command (':') detected on a leaf."
                . "(element '" . $element->name . "')"
            );
        }
        else {
            Config::Model::Exception::Load->throw(
                object  => $element,
                command => $inst,
                error   => "Load error on leaf with "
                . "'$element_name$action$id' command "
                . "(element '" . $element->name . "')"
            );
        }
    }

    return 'ok' unless defined $subaction;

    if ( $logger->is_debug ) {
        my $msg = defined $value ? $value : '<undef>';
        $msg =~ s/\n/\\n/g;
        $logger->debug("_load_leaf: action '$subaction' value '$msg'");
    }

    my $res = $self->_load_value( $element, $check, $subaction, $value, $inst );

    return $res if $res ;

    Config::Model::Exception::Load->throw(
        object  => $element,
        command => $inst,
        error   => "Load error on leaf with "
            . "'$element_name$subaction$value' command "
            . "(element '"
            . $element->name . "')"
    );
}

sub _load_value {
    my ( $self, $element, $check, $subaction, $value, $inst ) = @_;

    $logger->debug("_load_value: action '$subaction' value '$value' check $check");
    if ( $subaction eq '=' and $element->isa('Config::Model::Value') ) {
        $element->store( value => $value, check => $check );
    }
    elsif ( $subaction eq '.=' and $element->isa('Config::Model::Value') ) {
        my $orig = $element->fetch( check => $check );
        $element->store( value => $orig . $value, check => $check );
    }
    elsif ( $subaction eq '=~' and $element->isa('Config::Model::Value') ) {
        my $orig = $element->fetch( check => $check );
        if ( defined $orig ) {
            eval("\$orig =~ $value;");
            if ($@) {
                Config::Model::Exception::Load->throw(
                    object  => $element,
                    command => $inst,
                    error => "Failed regexp '$value' on " . "element '" . $element->name . "' : $@"
                );
            }
            $element->store( value => $orig, check => $check );
        }
    }
    else {
        return undef;
    }

    $logger->debug("_load_value: done returns ok");
    return 'ok';
}

1;

# ABSTRACT: Load serialized data into config tree

__END__

=pod

=encoding UTF-8

=head1 NAME

Config::Model::Loader - Load serialized data into config tree

=head1 VERSION

version 2.097

=head1 SYNOPSIS

 use Config::Model;

 # define configuration tree object
 my $model = Config::Model->new;
  $model->create_config_class(
    name    => "Foo",
    element => [
        [qw/foo bar/] => {
            type       => 'leaf',
            value_type => 'string'
        },
    ]
 );

 $model ->create_config_class (
    name => "MyClass",

    element => [

        [qw/foo bar/] => {
            type       => 'leaf',
            value_type => 'string'
        },
        hash_of_nodes => {
            type       => 'hash',     # hash id
            index_type => 'string',
            cargo      => {
                type              => 'node',
                config_class_name => 'Foo'
            },
        },
        [qw/lista listb/] => {
			      type => 'list',
			      cargo =>  {type => 'leaf',
					 value_type => 'string'
					}
			      },
    ],
 ) ;

 my $inst = $model->instance(root_class_name => 'MyClass' );

 my $root = $inst->config_root ;

 # put data
 my $steps = 'foo=FOO hash_of_nodes:fr foo=bonjour -
   hash_of_nodes:en foo=hello
   ! lista=foo,bar lista:2=baz
     listb:0=foo listb:1=baz';
 $root->load( steps => $steps );

 print $root->describe,"\n" ;
 # name         value        type         comment
 # foo          FOO          string
 # bar          [undef]      string
 # hash_of_nodes <Foo>        node hash    keys: "en" "fr"
 # lista        foo,bar,baz  list
 # listb        foo,baz      list


 # delete some data
 $root->load( steps => 'lista~2' );

 print $root->describe(element => 'lista'),"\n" ;
 # name         value        type         comment
 # lista        foo,bar      list

 # append some data
 $root->load( steps => q!hash_of_nodes:en foo.=" world"! );

 print $root->grab('hash_of_nodes:en')->describe(element => 'foo'),"\n" ;
 # name         value        type         comment
 # foo          "hello world" string

=head1 DESCRIPTION

This module is used directly by L<Config::Model::Node> to load
serialized configuration data into the configuration tree.

Serialized data can be written by the user or produced by
L<Config::Model::Dumper> while dumping data from a configuration tree.

=head1 CONSTRUCTOR

=head2 new ( )

No parameter. The constructor should be used only by
L<Config::Model::Node>.

=head1 load string syntax

The string is made of the following items (also called C<actions>)
separated by spaces. These actions can be divided in 4 groups:

=over

=item *

navigation: moving up and down the configuration tree.

=item *

list and hash operation: select, add or delete hash or list item (also
known as C<id> items)

=item *

leaf operation: select, modify or delecte leaf value

=item *

annotation: modify or delete configuration annotation (aka comment)

=back

=head2 navigation

=over 8

=item -

Go up one node

=item !

Go to the root node of the configuration tree.

=item xxx

Go down using C<xxx> element. (For C<node> type element)

=item /xxx

Go up until the element C<xxx> is found. This search can be combined with one of the
command specified below, e.g C</a_string="foo bar">

=back

=head2 list and hash operation

=over

=item xxx:yy

Go down using C<xxx> element and id C<yy> (For C<hash> or C<list>
element with C<node> cargo_type). Literal C<\n> are replaced by
real C<\n> (LF in Unix).

=item xxx:~yy

Go down using C<xxx> element and loop over the ids that match the regex
specified by C<yy>. (For C<hash>).

For instance, with C<OpenSsh> model, you could do

 Host:~"/.*.debian.org/" user='foo-guest'

to set "foo-user" users for all your debian accounts.

The leading and trailing '/' may be omitted. Be sure to surround the
regexp with double quote if space are embedded in the regex.

Note that the loop ends when the load command goes above the element
where the loop is executed. For instance, the instruction below
tries to execute C<DX=BV> and C<int_v=9> for all elements of C<std_id> hash:

 std_id:~/^\w+$/ DX=Bv int_v=9

In the examples below only C<DX=BV> is executed by the loop:

 std_id:~/^\w+$/ DX=Bv - int_v=9
 std_id:~/^\w+$/ DX=Bv ! int_v=9

The loop is done on all elements of the hash when no value is passed
after "C<:~>" (mnemonic: an empty regexp matches any value).

=item xxx:-yy

Delete item referenced by C<xxx> element and id C<yy>. For a list,
this is equivalent to C<splice xxx,yy,1>. This command does not go
down in the tree (since it has just deleted the element). I.e. a
'C<->' is generally not needed afterwards.

=item xxx:-=yy

Remove the element whose value is C<yy>. For list or hash of leaves.
Does not not complain if the value to delete is not found.

=item xxx:-~/yy/

Remove the element whose value matches C<yy>. For list or hash of leaves.
Does not not complain if no value were deleted.

=item xxx:=~s/yy/zz/

Substitute a value with another. Perl switches can be used(e.g. C<xxx:=~s/yy/zz/gi>)

=item xxx:<yy or xxx:.push(yy)

Push C<yy> value on C<xxx> list

=item xxx:>yy or xxx:.unshift(yy)

Unshift C<yy> value on C<xxx> list

=item xxx:@ or xxx:.sort

Sort the list

=item xxx:.insert_at(yy,zz)

Insert C<zz> value on C<xxx> list before B<index> C<yy>.

=item xxx:.insert_before(yy,zz)

Insert C<zz> value on C<xxx> list before B<value> C<yy>.

=item xxx:.insert_before(/yy/,zz)

Insert C<zz> value on C<xxx> list before B<value> matching C<yy>.

=item xxx:.insort(zz)

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
values, and C<""> for empty values.

I.e, for a list C<('a',undef,'','c')>, use C<a,,"",c>.

=item xxx:yy=zz

For C<hash> element containing C<leaf> cargo_type. Set the leaf
identified by key C<yy> to value C<zz>.

Using C<xxx:~/yy/=zz> is also possible.

=item xxx:.copy(yy,zz)

copy item C<yy> in C<zz> (hash or list).

=item xxx:.clear

Clear the hash or list.

=back

=head2 leaf operation

=over

=item xxx=zz

Set element C<xxx> to value C<yy>. load also accepts to set elements
with a quoted string. (For C<leaf> element) Literal C<\n> are replaced by
real C<\n> (LF in Unix). Literal C<\\> are replaced by C<\>.

For instance C<foo="a quoted string"> or C<foo="\"bar\" and \"baz\"">.

=item xxx=~s/foo/bar/

Apply the substitution to the value of xxx. C<s/foo/bar/> is the standard Perl C<s>
substitution pattern.

Patterns with white spaces must be surrounded by quotes:

  xxx=~"s/foo bar/bar baz/"

Perl pattern modifiers are accepted

  xxx=~s/FOO/bar/i

=item xxx~

Undef element C<xxx>

=item xxx.=zzz

Appends C<zzz> value to current value (valid for C<leaf> elements).

=back

=head2 annotation

=over

=item xxx#zzz or xxx:yyy#zzz

Element annotation. Can be quoted or not quoted. Note that annotations are
always placed at the end of an action item.

I.e. C<foo#comment>, C<foo:bar#comment> or C<foo:bar=baz#comment> are valid.
C<foo#comment:bar> is B<not> valid.

=back

=head2 Quotes

You can surround indexes and values with double quotes. E.g.:

  a_string="\"foo\" and \"bar\""

=head1 Examples

You can use L<cme> to modify configuration with C<cme modify> command.

For instance, if L<Config::Model::Ssh> is installed, you can run:

 cme modify ssh 'ControlMaster=auto ControlPath="~/.ssh/master-%r@%n:%p"'

To delete C<Host *> entry:

 cme modify ssh 'Host:-"*"'

To specify 2 C<Host> with a single command:

 cme modify ssh 'Host:"foo* bar*" ForwardX11=yes HostName="foo.com" - Host:baz HostName="baz.com"'

Note the 'C<->' used to go up one node before "C<Host:baz>". In this
case, "up one node" leads to the "root node", so "C<!>" could also be
used instead of "C<->":

 cme modify ssh 'Host:"foo* bar*" ForwardX11=yes HostName="foo.com" ! Host:baz HostName="baz.com"'

Let's modify now the host name of using a C<.org> domain instead of
C<.com>. The C<:~> operator uses a regexp to loop over several Host
entries:

 cme modify ssh 'Host:~/ba[rz]/ HostName=~s/.com$/.org/'

Now that ssh config is mucked up with dummy entries, let's clean up:

 cme modify ssh 'Host:-"baz" Host:-"foo* bar*"'

=head1 Methods

=head2 load ( ... )

Load data into the node tree (from the node passed with C<node>)
and fill values as we go following the instructions passed with
C<steps>.  (C<steps> can also be an array ref).

Parameters are:

=over

=item node

node ref of the root of the tree (of sub-root) to start the load from.

=item steps (or step)

A string or an array ref containing the steps to load. See
L<above/"load string syntax"> for a description of the string.

=item check

Whether to check values while loading. Either C<yes> (default), C<no> or C<skip>.
Bad values are discarded when C<check> is set to C<skip>.

=back

=head1 AUTHOR

Dominique Dumont, (ddumont at cpan dot org)

=head1 SEE ALSO

L<Config::Model>,L<Config::Model::Node>,L<Config::Model::Dumper>

=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