1package Test2::Compare::Base;
2use strict;
3use warnings;
4
5our $VERSION = '0.000143';
6
7use Carp qw/confess croak/;
8use Scalar::Util qw/blessed/;
9
10use Sub::Info qw/sub_info/;
11use Test2::Compare::Delta();
12
13sub MAX_CYCLES() { 75 }
14
15use Test2::Util::HashBase qw{builder _file _lines _info called};
16use Test2::Util::Ref qw/render_ref/;
17
18{
19    no warnings 'once';
20    *set_lines = \&set__lines;
21    *set_file  = \&set__file;
22}
23
24sub clone {
25    my $self = shift;
26    my $class = blessed($self);
27
28    # Shallow copy is good enough for all the current compare types.
29    return bless({%$self}, $class);
30}
31
32sub init {
33    my $self = shift;
34    $self->{+_LINES} = delete $self->{lines} if exists $self->{lines};
35    $self->{+_FILE}  = delete $self->{file}  if exists $self->{file};
36}
37
38sub file {
39    my $self = shift;
40    return $self->{+_FILE} if $self->{+_FILE};
41
42    if ($self->{+BUILDER}) {
43        $self->{+_INFO} ||= sub_info($self->{+BUILDER});
44        return $self->{+_INFO}->{file};
45    }
46    elsif ($self->{+CALLED}) {
47        return $self->{+CALLED}->[1];
48    }
49
50    return undef;
51}
52
53sub lines {
54    my $self = shift;
55    return $self->{+_LINES} if $self->{+_LINES};
56
57    if ($self->{+BUILDER}) {
58        $self->{+_INFO} ||= sub_info($self->{+BUILDER});
59        return $self->{+_INFO}->{lines} if @{$self->{+_INFO}->{lines}};
60    }
61    if ($self->{+CALLED}) {
62        return [$self->{+CALLED}->[2]];
63    }
64    return [];
65}
66
67sub delta_class { 'Test2::Compare::Delta' }
68
69sub deltas { () }
70sub got_lines { () }
71
72sub stringify_got { 0 }
73
74sub operator { '' }
75sub verify   { confess "unimplemented" }
76sub name     { confess "unimplemented" }
77
78sub render {
79    my $self = shift;
80    return $self->name;
81}
82
83sub run {
84    my $self = shift;
85    my %params = @_;
86
87    my $id      = $params{id};
88    my $convert = $params{convert} or confess "no convert sub provided";
89    my $seen    = $params{seen} ||= {};
90
91    $params{exists} = exists $params{got} ? 1 : 0
92        unless exists $params{exists};
93
94    my $exists = $params{exists};
95    my $got = $exists ? $params{got} : undef;
96
97    my $gotname = render_ref($got);
98
99    # Prevent infinite cycles
100    if (defined($got) && ref $got) {
101        die "Cycle detected in comparison, aborting"
102            if $seen->{$gotname} && $seen->{$gotname} >= MAX_CYCLES;
103        $seen->{$gotname}++;
104    }
105
106    my $ok = $self->verify(%params);
107    my @deltas = $ok ? $self->deltas(%params) : ();
108
109    $seen->{$gotname}-- if defined $got && ref $got;
110
111    return if $ok && !@deltas;
112
113    return $self->delta_class->new(
114        verified => $ok,
115        id       => $id,
116        got      => $got,
117        check    => $self,
118        children => \@deltas,
119        $exists ? () : (dne => 'got'),
120    );
121}
122
1231;
124
125__END__
126
127=pod
128
129=encoding UTF-8
130
131=head1 NAME
132
133Test2::Compare::Base - Base class for comparison classes.
134
135=head1 DESCRIPTION
136
137All comparison classes for Test2::Compare should inherit from this base class.
138
139=head1 SYNOPSIS
140
141    package Test2::Compare::MyCheck;
142    use strict;
143    use warnings;
144
145    use base 'Test2::Compare::Base';
146    use Test2::Util::HashBase qw/stuff/;
147
148    sub name { 'STUFF' }
149
150    sub operator {
151        my $self = shift;
152        my ($got) = @_;
153        return 'eq';
154    }
155
156    sub verify {
157        my $self = shift;
158        my $params = @_;
159
160        # Always check if $got exists! This method must return false if no
161        # value at all was received.
162        return 0 unless $params{exists};
163
164        my $got = $params{got};
165
166        # Returns true if both values match. This includes undef, 0, and other
167        # false-y values!
168        return $got eq $self->stuff;
169    }
170
171=head1 METHODS
172
173Some of these must be overridden, others can be.
174
175=over 4
176
177=item $dclass = $check->delta_class
178
179Returns the delta subclass that should be used. By default
180L<Test2::Compare::Delta> is used.
181
182=item @deltas = $check->deltas(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen)
183
184Should return child deltas.
185
186=item @lines = $check->got_lines($got)
187
188This is your chance to provide line numbers for errors in the C<$got>
189structure.
190
191=item $op = $check->operator()
192
193=item $op = $check->operator($got)
194
195Returns the operator that was used to compare the check with the received data
196in C<$got>. If there was no value for got then there will be no arguments,
197undef will only be an argument if undef was seen in C<$got>. This is how you
198can tell the difference between a missing value and an undefined one.
199
200=item $bool = $check->verify(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen)
201
202Return true if there is a shallow match, that is both items are arrayrefs, both
203items are the same string or same number, etc. This should not recurse, as deep
204checks are done in C<< $check->deltas() >>.
205
206=item $name = $check->name
207
208Get the name of the check.
209
210=item $display = $check->render
211
212What should be displayed in a table for this check, usually the name or value.
213
214=item $delta = $check->run(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen)
215
216This is where the checking is done, first a shallow check using
217C<< $check->verify >>, then checking C<< $check->deltas() >>. C<\%seen> is used
218to prevent cycles.
219
220=back
221
222=head1 SOURCE
223
224The source code repository for Test2-Suite can be found at
225F<https://github.com/Test-More/Test2-Suite/>.
226
227=head1 MAINTAINERS
228
229=over 4
230
231=item Chad Granum E<lt>exodist@cpan.orgE<gt>
232
233=back
234
235=head1 AUTHORS
236
237=over 4
238
239=item Chad Granum E<lt>exodist@cpan.orgE<gt>
240
241=back
242
243=head1 COPYRIGHT
244
245Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
246
247This program is free software; you can redistribute it and/or
248modify it under the same terms as Perl itself.
249
250See F<http://dev.perl.org/licenses/>
251
252=cut
253