1package Test2::Compare::Delta; 2use strict; 3use warnings; 4 5our $VERSION = '0.000143'; 6 7use Test2::Util::HashBase qw{verified id got chk children dne exception note}; 8 9use Test2::EventFacet::Info::Table; 10 11use Test2::Util::Table(); 12use Test2::API qw/context/; 13 14use Test2::Util::Ref qw/render_ref rtype/; 15use Carp qw/croak/; 16 17# 'CHECK' constant would not work, but I like exposing 'check()' to people 18# using this class. 19BEGIN { 20 no warnings 'once'; 21 *check = \&chk; 22 *set_check = \&set_chk; 23} 24 25my @COLUMN_ORDER = qw/PATH GLNs GOT OP CHECK CLNs/; 26my %COLUMNS = ( 27 GOT => {name => 'GOT', value => sub { $_[0]->render_got }, no_collapse => 1}, 28 CHECK => {name => 'CHECK', value => sub { $_[0]->render_check }, no_collapse => 1}, 29 OP => {name => 'OP', value => sub { $_[0]->table_op } }, 30 PATH => {name => 'PATH', value => sub { $_[1] } }, 31 32 'GLNs' => {name => 'GLNs', alias => 'LNs', value => sub { $_[0]->table_got_lines } }, 33 'CLNs' => {name => 'CLNs', alias => 'LNs', value => sub { $_[0]->table_check_lines }}, 34); 35{ 36 my $i = 0; 37 $COLUMNS{$_}->{id} = $i++ for @COLUMN_ORDER; 38} 39 40sub remove_column { 41 my $class = shift; 42 my $header = shift; 43 @COLUMN_ORDER = grep { $_ ne $header } @COLUMN_ORDER; 44 delete $COLUMNS{$header} ? 1 : 0; 45} 46 47sub add_column { 48 my $class = shift; 49 my $name = shift; 50 51 croak "Column name is required" 52 unless $name; 53 54 croak "Column '$name' is already defined" 55 if $COLUMNS{$name}; 56 57 my %params; 58 if (@_ == 1) { 59 %params = (value => @_, name => $name); 60 } 61 else { 62 %params = (@_, name => $name); 63 } 64 65 my $value = $params{value}; 66 67 croak "You must specify a 'value' callback" 68 unless $value; 69 70 croak "'value' callback must be a CODE reference" 71 unless rtype($value) eq 'CODE'; 72 73 if ($params{prefix}) { 74 unshift @COLUMN_ORDER => $name; 75 } 76 else { 77 push @COLUMN_ORDER => $name; 78 } 79 80 $COLUMNS{$name} = \%params; 81} 82 83sub set_column_alias { 84 my ($class, $name, $alias) = @_; 85 86 croak "Tried to alias a non-existent column" 87 unless exists $COLUMNS{$name}; 88 89 croak "Missing alias" unless defined $alias; 90 91 $COLUMNS{$name}->{alias} = $alias; 92} 93 94sub init { 95 my $self = shift; 96 97 croak "Cannot specify both 'check' and 'chk' as arguments" 98 if exists($self->{check}) && exists($self->{+CHK}); 99 100 # Allow 'check' as an argument 101 $self->{+CHK} ||= delete $self->{check} 102 if exists $self->{check}; 103} 104 105sub render_got { 106 my $self = shift; 107 108 my $exp = $self->{+EXCEPTION}; 109 if ($exp) { 110 chomp($exp = "$exp"); 111 $exp =~ s/\n.*$//g; 112 return "<EXCEPTION: $exp>"; 113 } 114 115 my $dne = $self->{+DNE}; 116 return '<DOES NOT EXIST>' if $dne && $dne eq 'got'; 117 118 my $got = $self->{+GOT}; 119 return '<UNDEF>' unless defined $got; 120 121 my $check = $self->{+CHK}; 122 my $stringify = defined( $check ) && $check->stringify_got; 123 124 return render_ref($got) if ref $got && !$stringify; 125 126 return "$got"; 127} 128 129sub render_check { 130 my $self = shift; 131 132 my $dne = $self->{+DNE}; 133 return '<DOES NOT EXIST>' if $dne && $dne eq 'check'; 134 135 my $check = $self->{+CHK}; 136 return '<UNDEF>' unless defined $check; 137 138 return $check->render; 139} 140 141sub _full_id { 142 my ($type, $id) = @_; 143 return "<$id>" if !$type || $type eq 'META'; 144 return $id if $type eq 'SCALAR'; 145 return "{$id}" if $type eq 'HASH'; 146 return "{$id} <KEY>" if $type eq 'HASHKEY'; 147 return "[$id]" if $type eq 'ARRAY'; 148 return "$id()" if $type eq 'METHOD'; 149 return "$id" if $type eq 'DEREF'; 150 return "<$id>"; 151} 152 153sub _arrow_id { 154 my ($path, $type) = @_; 155 return '' unless $path; 156 157 return ' ' if !$type || $type eq 'META'; # Meta gets a space, not an arrow 158 159 return '->' if $type eq 'METHOD'; # Method always needs an arrow 160 return '->' if $type eq 'SCALAR'; # Scalar always needs an arrow 161 return '->' if $type eq 'DEREF'; # deref always needs arrow 162 return '->' if $path =~ m/(>|\(\))$/; # Need an arrow after meta, or after a method 163 return '->' if $path eq '$VAR'; # Need an arrow after the initial ref 164 165 # Hash and array need an arrow unless they follow another hash/array 166 return '->' if $type =~ m/^(HASH|ARRAY)$/ && $path !~ m/(\]|\})$/; 167 168 # No arrow needed 169 return ''; 170} 171 172sub _join_id { 173 my ($path, $parts) = @_; 174 my ($type, $key) = @$parts; 175 176 my $id = _full_id($type, $key); 177 my $join = _arrow_id($path, $type); 178 179 return "${path}${join}${id}"; 180} 181 182sub should_show { 183 my $self = shift; 184 return 1 unless $self->verified; 185 defined( my $check = $self->check ) || return 0; 186 return 0 unless $check->lines; 187 my $file = $check->file || return 0; 188 189 my $ctx = context(); 190 my $cfile = $ctx->trace->file; 191 $ctx->release; 192 return 0 unless $file eq $cfile; 193 194 return 1; 195} 196 197sub filter_visible { 198 my $self = shift; 199 200 my @deltas; 201 my @queue = (['', $self]); 202 203 while (my $set = shift @queue) { 204 my ($path, $delta) = @$set; 205 206 push @deltas => [$path, $delta] if $delta->should_show; 207 208 my $children = $delta->children || next; 209 next unless @$children; 210 211 my @new; 212 for my $child (@$children) { 213 my $cpath = _join_id($path, $child->id); 214 push @new => [$cpath, $child]; 215 } 216 unshift @queue => @new; 217 } 218 219 return \@deltas; 220} 221 222sub table_header { [map {$COLUMNS{$_}->{alias} || $_} @COLUMN_ORDER] } 223 224sub table_op { 225 my $self = shift; 226 227 defined( my $check = $self->{+CHK} ) || return '!exists'; 228 229 return $check->operator($self->{+GOT}) 230 unless $self->{+DNE} && $self->{+DNE} eq 'got'; 231 232 return $check->operator(); 233} 234 235sub table_check_lines { 236 my $self = shift; 237 238 defined( my $check = $self->{+CHK} ) || return ''; 239 my $lines = $check->lines || return ''; 240 241 return '' unless @$lines; 242 243 return join ', ' => @$lines; 244} 245 246sub table_got_lines { 247 my $self = shift; 248 249 defined( my $check = $self->{+CHK} ) || return ''; 250 return '' if $self->{+DNE} && $self->{+DNE} eq 'got'; 251 252 my @lines = $check->got_lines($self->{+GOT}); 253 return '' unless @lines; 254 255 return join ', ' => @lines; 256} 257 258sub table_rows { 259 my $self = shift; 260 261 my $deltas = $self->filter_visible; 262 263 my @rows; 264 for my $set (@$deltas) { 265 my ($id, $d) = @$set; 266 267 my @row; 268 for my $col (@COLUMN_ORDER) { 269 my $spec = $COLUMNS{$col}; 270 my $val = $spec->{value}->($d, $id); 271 $val = '' unless defined $val; 272 push @row => $val; 273 } 274 275 push @rows => \@row; 276 } 277 278 return \@rows; 279} 280 281sub table { 282 my $self = shift; 283 284 my @diag; 285 my $header = $self->table_header; 286 my $rows = $self->table_rows; 287 288 my $render_rows = [@$rows]; 289 my $max = exists $ENV{TS_MAX_DELTA} ? $ENV{TS_MAX_DELTA} : 25; 290 if ($max && @$render_rows > $max) { 291 @$render_rows = map { [@$_] } @{$render_rows}[0 .. ($max - 1)]; 292 @diag = ( 293 "************************************************************", 294 sprintf("* Stopped after %-42.42s *", "$max differences."), 295 "* Set the TS_MAX_DELTA environment var to raise the limit. *", 296 "* Set it to 0 for no limit. *", 297 "************************************************************", 298 ); 299 } 300 301 my @dne; 302 for my $row (@$render_rows) { 303 my $got = $row->[$COLUMNS{GOT}->{id}] || ''; 304 my $chk = $row->[$COLUMNS{CHECK}->{id}] || ''; 305 if ($got eq '<DOES NOT EXIST>') { 306 push @dne => "$row->[$COLUMNS{PATH}->{id}]: DOES NOT EXIST"; 307 } 308 elsif ($chk eq '<DOES NOT EXIST>') { 309 push @dne => "$row->[$COLUMNS{PATH}->{id}]: SHOULD NOT EXIST"; 310 } 311 } 312 313 if (@dne) { 314 unshift @dne => '==== Summary of missing/extra items ===='; 315 push @dne => '== end summary of missing/extra items =='; 316 } 317 318 my $table_args = { 319 header => $header, 320 collapse => 1, 321 sanitize => 1, 322 mark_tail => 1, 323 no_collapse => [grep { $COLUMNS{$COLUMN_ORDER[$_]}->{no_collapse} } 0 .. $#COLUMN_ORDER], 324 }; 325 326 my $render = join "\n" => ( 327 Test2::Util::Table::table(%$table_args, rows => $render_rows), 328 @dne, 329 @diag, 330 ); 331 332 my $table = Test2::EventFacet::Info::Table->new( 333 %$table_args, 334 rows => $rows, 335 as_string => $render, 336 ); 337 338 return $table; 339} 340 341sub diag { shift->table } 342 3431; 344 345__END__ 346 347=pod 348 349=encoding UTF-8 350 351=head1 NAME 352 353Test2::Compare::Delta - Representation of differences between nested data 354structures. 355 356=head1 DESCRIPTION 357 358This is used by L<Test2::Compare>. When data structures are compared a 359delta will be returned. Deltas are a tree data structure that represent all the 360differences between two other data structures. 361 362=head1 METHODS 363 364=head2 CLASS METHODS 365 366=over 4 367 368=item $class->add_column($NAME => sub { ... }) 369 370=item $class->add_column($NAME, %PARAMS) 371 372This can be used to add columns to the table that it produced when a comparison 373fails. The first argument should always be the column name, which must be 374unique. 375 376The first form simply takes a coderef that produces the value that should be 377displayed in the column for any given delta. The arguments passed into the sub 378are the delta, and the row ID. 379 380 Test2::Compare::Delta->add_column( 381 Foo => sub { 382 my ($delta, $id) = @_; 383 return $delta->... ? 'foo' : 'bar' 384 }, 385 ); 386 387The second form allows you some extra options. The C<'value'> key is required, 388and must be a coderef. All other keys are optional. 389 390 Test2::Compare::Delta->add_column( 391 'Foo', # column name 392 value => sub { ... }, # how to get the cell value 393 alias => 'FOO', # Display name (used in table header) 394 no_collapse => $bool, # Show column even if it has no values? 395 ); 396 397=item $bool = $class->remove_column($NAME) 398 399This will remove the specified column. This will return true if the column 400existed and was removed. This will return false if the column did not exist. No 401exceptions are thrown. If a missing column is a problem then you need to check 402the return yourself. 403 404=item $class->set_column_alias($NAME, $ALIAS) 405 406This can be used to change the table header, overriding the default column 407names with new ones. 408 409=back 410 411=head2 ATTRIBUTES 412 413=over 4 414 415=item $bool = $delta->verified 416 417=item $delta->set_verified($bool) 418 419This will be true if the delta itself matched, if the delta matched then the 420problem is in the delta's children, not the delta itself. 421 422=item $aref = $delta->id 423 424=item $delta->set_id([$type, $name]) 425 426ID for the delta, used to produce the path into the data structure. An 427example is C<< ['HASH' => 'foo'] >> which means the delta is in the path 428C<< ...->{'foo'} >>. Valid types are C<HASH>, C<ARRAY>, C<SCALAR>, C<META>, and 429C<METHOD>. 430 431=item $val = $delta->got 432 433=item $delta->set_got($val) 434 435Deltas are produced by comparing a received data structure 'got' against a 436check data structure 'check'. The 'got' attribute contains the value that was 437received for comparison. 438 439=item $check = $delta->chk 440 441=item $check = $delta->check 442 443=item $delta->set_chk($check) 444 445=item $delta->set_check($check) 446 447Deltas are produced by comparing a received data structure 'got' against a 448check data structure 'check'. The 'check' attribute contains the value that was 449expected in the comparison. 450 451C<check> and C<chk> are aliases for the same attribute. 452 453=item $aref = $delta->children 454 455=item $delta->set_children([$delta1, $delta2, ...]) 456 457A Delta may have child deltas. If it does then this is an arrayref with those 458children. 459 460=item $dne = $delta->dne 461 462=item $delta->set_dne($dne) 463 464Sometimes a comparison results in one side or the other not existing at all, in 465which case this is set to the name of the attribute that does not exist. This 466can be set to 'got' or 'check'. 467 468=item $e = $delta->exception 469 470=item $delta->set_exception($e) 471 472This will be set to the exception in cases where the comparison failed due to 473an exception being thrown. 474 475=back 476 477=head2 OTHER 478 479=over 4 480 481=item $string = $delta->render_got 482 483Renders the string that should be used in a table to represent the received 484value in a comparison. 485 486=item $string = $delta->render_check 487 488Renders the string that should be used in a table to represent the expected 489value in a comparison. 490 491=item $bool = $delta->should_show 492 493This will return true if the delta should be shown in the table. This is 494normally true for any unverified delta. This will also be true for deltas that 495contain extra useful debug information. 496 497=item $aref = $delta->filter_visible 498 499This will produce an arrayref of C<< [ $path => $delta ] >> for all deltas that 500should be displayed in the table. 501 502=item $aref = $delta->table_header 503 504This returns an array ref of the headers for the table. 505 506=item $string = $delta->table_op 507 508This returns the operator that should be shown in the table. 509 510=item $string = $delta->table_check_lines 511 512This returns the defined lines (extra debug info) that should be displayed. 513 514=item $string = $delta->table_got_lines 515 516This returns the generated lines (extra debug info) that should be displayed. 517 518=item $aref = $delta->table_rows 519 520This returns an arrayref of table rows, each row is itself an arrayref. 521 522=item @table_lines = $delta->table 523 524Returns all the lines of the table that should be displayed. 525 526=back 527 528=head1 SOURCE 529 530The source code repository for Test2-Suite can be found at 531F<https://github.com/Test-More/Test2-Suite/>. 532 533=head1 MAINTAINERS 534 535=over 4 536 537=item Chad Granum E<lt>exodist@cpan.orgE<gt> 538 539=back 540 541=head1 AUTHORS 542 543=over 4 544 545=item Chad Granum E<lt>exodist@cpan.orgE<gt> 546 547=back 548 549=head1 COPYRIGHT 550 551Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>. 552 553This program is free software; you can redistribute it and/or 554modify it under the same terms as Perl itself. 555 556See F<http://dev.perl.org/licenses/> 557 558=cut 559