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