our
$VERSION
=
'1.302209'
;
use
Carp
qw/croak confess/
;
sub
init {
my
$self
=
shift
;
if
(
defined
(
my
$ref
=
$self
->{+INREF} ) ) {
croak
"Cannot specify both 'inref' and 'items'"
if
$self
->{+ITEMS};
croak
"Cannot specify both 'inref' and 'order'"
if
$self
->{+ORDER};
$self
->{+ITEMS} = {
%$ref
};
$self
->{+ORDER} = [
sort
keys
%$ref
];
}
else
{
$self
->{+ITEMS} =
$self
->{+ITEMS} ? {%{
$self
->{+ITEMS}}} : {};
if
(
$self
->{+ORDER}) {
my
@all
=
keys
%{
$self
->{+ITEMS}};
my
%have
=
map
{
$_
=> 1 } @{
$self
->{+ORDER}};
my
@missing
=
grep
{ !
$have
{
$_
} }
@all
;
croak
"Keys are missing from the 'order' array: "
.
join
(
', '
,
sort
@missing
)
if
@missing
;
}
else
{
$self
->{+ORDER} = [
sort
keys
%{
$self
->{+ITEMS}}];
}
}
$self
->{+FOR_EACH_KEY} ||= [];
$self
->{+FOR_EACH_VAL} ||= [];
$self
->SUPER::init();
}
sub
name {
'<HASH>'
}
sub
meta_class {
'Test2::Compare::Meta'
}
sub
verify {
my
$self
=
shift
;
my
%params
=
@_
;
my
(
$got
,
$exists
) =
@params
{
qw/got exists/
};
return
0
unless
$exists
;
return
0
unless
defined
$got
;
return
0
unless
ref
(
$got
);
return
0
unless
reftype(
$got
) eq
'HASH'
;
return
1;
}
sub
add_prop {
my
$self
=
shift
;
$self
->{+META} =
$self
->meta_class->new
unless
defined
$self
->{+META};
$self
->{+META}->add_prop(
@_
);
}
sub
add_field {
my
$self
=
shift
;
my
(
$name
,
$check
) =
@_
;
croak
"field name is required"
unless
defined
$name
;
croak
"field '$name' has already been specified"
if
exists
$self
->{+ITEMS}->{
$name
};
push
@{
$self
->{+ORDER}} =>
$name
;
$self
->{+ITEMS}->{
$name
} =
$check
;
}
sub
add_for_each_key {
my
$self
=
shift
;
push
@{
$self
->{+FOR_EACH_KEY}} =>
@_
;
}
sub
add_for_each_val {
my
$self
=
shift
;
push
@{
$self
->{+FOR_EACH_VAL}} =>
@_
;
}
sub
deltas {
my
$self
=
shift
;
my
%params
=
@_
;
my
(
$got
,
$convert
,
$seen
) =
@params
{
qw/got convert seen/
};
my
@deltas
;
my
$items
=
$self
->{+ITEMS};
my
$each_key
=
$self
->{+FOR_EACH_KEY};
my
$each_val
=
$self
->{+FOR_EACH_VAL};
my
%fields
=
%$got
;
my
$meta
=
$self
->{+META};
push
@deltas
=>
$meta
->deltas(
%params
)
if
defined
$meta
;
for
my
$key
(@{
$self
->{+ORDER}}) {
my
$check
=
$convert
->(
$items
->{
$key
});
my
$exists
=
exists
$fields
{
$key
};
my
$val
=
delete
$fields
{
$key
};
if
(
$exists
) {
for
my
$kcheck
(
@$each_key
) {
$kcheck
=
$convert
->(
$kcheck
);
push
@deltas
=>
$kcheck
->run(
id
=> [
HASHKEY
=>
$key
],
convert
=>
$convert
,
seen
=>
$seen
,
exists
=>
$exists
,
got
=>
$key
,
);
}
for
my
$vcheck
(
@$each_val
) {
$vcheck
=
$convert
->(
$vcheck
);
push
@deltas
=>
$vcheck
->run(
id
=> [
HASH
=>
$key
],
convert
=>
$convert
,
seen
=>
$seen
,
exists
=>
$exists
,
got
=>
$val
,
);
}
}
push
@deltas
=>
$check
->run(
id
=> [
HASH
=>
$key
],
convert
=>
$convert
,
seen
=>
$seen
,
exists
=>
$exists
,
$exists
? (
got
=>
$val
) : (),
);
}
if
(
keys
%fields
) {
for
my
$key
(
sort
keys
%fields
) {
my
$val
=
$fields
{
$key
};
for
my
$kcheck
(
@$each_key
) {
$kcheck
=
$convert
->(
$kcheck
);
push
@deltas
=>
$kcheck
->run(
id
=> [
HASHKEY
=>
$key
],
convert
=>
$convert
,
seen
=>
$seen
,
got
=>
$key
,
exists
=> 1,
);
}
for
my
$vcheck
(
@$each_val
) {
$vcheck
=
$convert
->(
$vcheck
);
push
@deltas
=>
$vcheck
->run(
id
=> [
HASH
=>
$key
],
convert
=>
$convert
,
seen
=>
$seen
,
got
=>
$val
,
exists
=> 1,
);
}
if
(
$self
->{+ENDING}) {
push
@deltas
=>
$self
->delta_class->new(
dne
=>
'check'
,
verified
=>
undef
,
id
=> [
HASH
=>
$key
],
got
=>
$val
,
check
=>
undef
,
$self
->{+ENDING} eq
'implicit'
? (
note
=>
'implicit end'
) : (),
);
}
}
}
return
@deltas
;
}
1;