File Coverage

blib/lib/Test/Stream/Compare/Object.pm
Criterion Covered Total %
statement 79 79 100.0
branch 28 28 100.0
condition 13 17 76.4
subroutine 19 19 100.0
pod 9 10 90.0
total 148 153 96.7


line stmt bran cond sub pod time code
1             package Test::Stream::Compare::Object;
2 100     100   1058 use strict;
  100         192  
  100         2486  
3 100     100   494 use warnings;
  100         192  
  100         2724  
4              
5 100     100   525 use Test::Stream::Util qw/try/;
  100         184  
  100         775  
6              
7 100     100   534 use Test::Stream::Compare;
  100         346  
  100         633  
8 100     100   54956 use Test::Stream::Compare::Meta;
  100         257  
  100         754  
9             use Test::Stream::HashBase(
10 100         580 base => 'Test::Stream::Compare',
11             accessors => [qw/calls meta refcheck ending/],
12 100     100   603 );
  100         195  
13              
14 100     100   535 use Carp qw/croak confess/;
  100         251  
  100         5090  
15 100     100   512 use Scalar::Util qw/reftype blessed/;
  100         188  
  100         82363  
16              
17             sub init {
18 425     425 0 664 my $self = shift;
19 425   100     2001 $self->{+CALLS} ||= [];
20 425         1330 $self->SUPER::init();
21             }
22              
23 18     18 1 59 sub name { '' }
24              
25 112     112 1 404 sub meta_class { 'Test::Stream::Compare::Meta' }
26 145     145 1 556 sub object_base { 'UNIVERSAL' }
27              
28             sub verify {
29 442     442 1 610 my $self = shift;
30 442         1516 my %params = @_;
31 442         909 my ($got, $exists) = @params{qw/got exists/};
32              
33 442 100       969 return 0 unless $exists;
34 441 100       896 return 0 unless $got;
35 440 100       955 return 0 unless ref($got);
36 437 100       1419 return 0 unless blessed($got);
37 435 100       1324 return 0 unless $got->isa($self->object_base);
38 434         1485 return 1;
39             }
40              
41             sub add_prop {
42 502     502 1 673 my $self = shift;
43 502   66     2229 $self->{+META} ||= $self->meta_class->new;
44 502         1767 $self->{+META}->add_prop(@_);
45             }
46              
47             sub add_field {
48 76     76 1 123 my $self = shift;
49 76   66     301 $self->{+REFCHECK} ||= Test::Stream::Compare::Hash->new;
50              
51             croak "Underlying reference does not have fields"
52 76 100       468 unless $self->{+REFCHECK}->can('add_field');
53              
54 75         234 $self->{+REFCHECK}->add_field(@_);
55             }
56              
57             sub add_item {
58 8     8 1 35 my $self = shift;
59 8   66     47 $self->{+REFCHECK} ||= Test::Stream::Compare::Array->new;
60              
61             croak "Underlying reference does not have items"
62 8 100       153 unless $self->{+REFCHECK}->can('add_item');
63              
64 7         28 $self->{+REFCHECK}->add_item(@_);
65             }
66              
67             sub add_call {
68 1060     1060 1 1307 my $self = shift;
69 1060         1551 my ($meth, $check, $name) = @_;
70 1060 100 66     4206 $name ||= ref $meth ? '\&CODE' : $meth;
71 1060         1241 push @{$self->{+CALLS}} => [$meth, $check, $name];
  1060         4512  
72             }
73              
74             sub deltas {
75 435     435 1 625 my $self = shift;
76 435         1387 my %params = @_;
77 435         893 my ($got, $convert, $seen) = @params{qw/got convert seen/};
78              
79 435         503 my @deltas;
80 435         712 my $meta = $self->{+META};
81 435         657 my $refcheck = $self->{+REFCHECK};
82              
83 435 100       2213 push @deltas => $meta->deltas(%params) if $meta;
84              
85 435         764 for my $call (@{$self->{+CALLS}}) {
  435         1088  
86 1098         2698 my ($meth, $check, $name)= @$call;
87              
88 1098         2996 $check = $convert->($check);
89              
90 1098   100     5796 my $exists = ref($meth) || $got->can($meth);
91 1098         1379 my $val;
92 1098 100   1098   5473 my ($ok, $err) = try { $val = $exists ? $got->$meth : undef };
  1098         4056  
93              
94 1098 100       4314 if (!$ok) {
95 2         15 push @deltas => $self->delta_class->new(
96             verified => undef,
97             id => [METHOD => $name],
98             got => undef,
99             check => $check,
100             exception => $err,
101             );
102             }
103             else {
104 1096 100       5117 push @deltas => $check->run(
105             id => [METHOD => $name],
106             convert => $convert,
107             seen => $seen,
108             exists => $exists,
109             $exists ? (got => $val) : (),
110             );
111             }
112             }
113              
114 435 100       1633 return @deltas unless $refcheck;
115              
116 228         1063 $refcheck->set_ending($self->{+ENDING});
117              
118 228 100       1717 if ($refcheck->verify(%params)) {
119 225         937 push @deltas => $refcheck->deltas(%params);
120             }
121             else {
122 3         13 push @deltas => $self->delta_class->new(
123             verified => undef,
124             id => [META => 'Object Ref'],
125             got => $got,
126             check => $refcheck,
127             );
128             }
129              
130 228         974 return @deltas;
131             }
132              
133             1;
134              
135             __END__