$Config::Model::Role::Grab::VERSION
=
'2.108'
;
my
$logger
= get_logger(
"Grab"
);
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};
$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
;
my
$huge_string
=
ref
$steps
?
join
(
' '
,
@$steps
) :
$steps
;
my
@command
= (
$huge_string
=~ m/
(
(?:
[^\s"]+
(?:
"
(?:
\\"
|
[^"]
)*
"
)
?
)+
)
/gx
);
my
@saved
=
@command
;
$logger
->trace(
"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
->trace(
"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/^\?//;
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/^"//;
$arg
=~ s/"$//;
}
{
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
);
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
;
}
$next_obj
=
$next_obj
->fetch_with_id(
index
=>
$arg
,
check
=>
$check
)
if
defined
$action
;
push
@found
,
$next_obj
;
}
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
);
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
;
}
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
) ) {
return
$obj
;
}
elsif
(
defined
$obj
->parent ) {
$obj
=
$obj
->parent;
}
else
{
Config::Model::Exception::Model->throw(
object
=>
$self
,
error
=>
"Error: cannot grab '?$search'"
.
"from "
.
$self
->name
);
}
}
}