1use strict; 2use warnings; 3use Test::More; 4use Data::Dumper; 5use vars qw/%Has/; 6BEGIN { 7 $Has{diff}=!!eval "use Algorithm::Diff qw(sdiff diff); 1"; 8 $Has{sortkeys}=!!eval "Data::Dumper->new([1])->Sortkeys(1)->Dump()"; 9} 10 11#$Id: test_helper.pl 26 2006-04-16 15:18:52Z demerphq $# 12 13# all of this is acumulated junk used for making the various test easier. 14# as a close inspection shows, this all derives from different periods of 15# the module and is pretty nasty/hacky to look at. Slowly id like to convert 16# everything over to test_dump() and get rid of same(). 17 18sub string_diff { 19 my ( $str1, $str2, $title1, $title2 ) = @_; 20 $title1 ||= "Got"; 21 $title2 ||= "Expected"; 22 23 my $line = ( caller(2) )[2]; 24 25 #print $str1,"\n---\n",$str2; 26 my $seq1 = ( ref $str1 ) ? $str1 : [ split /\n/, $str1 ]; 27 my $seq2 = ( ref $str2 ) ? $str2 : [ split /\n/, $str2 ]; 28 29 # im sure theres a more elegant way to do all this as well 30 my @array; 31 my $are_diff; 32 Algorithm::Diff::traverse_sequences( 33 $seq1, $seq2, 34 { 35 MATCH => sub { 36 my ( $t, $u ) = @_; 37 push @array, [ '=', $seq1->[$t], $t, $u ]; 38 }, 39 DISCARD_A => sub { 40 my ( $t, $u ) = @_; 41 push @array, [ '-', $seq1->[$t], $t, $u ]; 42 $are_diff++; 43 }, 44 DISCARD_B => sub { 45 my ( $t, $u ) = @_; 46 push @array, [ '+', $seq2->[$u], $t, $u ]; 47 $are_diff++; 48 }, 49 } 50 ); 51 return "" unless $are_diff; 52 my $return = "-$title1\n+$title2\n"; 53 54 #especially this bit. 55 my ( $last, $skipped ) = ( "=", 1 ); 56 foreach ( 0 .. $#array ) { 57 my $elem = $array[$_]; 58 my ( $do, $str, $pos, $eq ) = @$elem; 59 60 if ( $do eq $last 61 && $do eq '=' 62 && ( $_ < $#array && $array[ $_ + 1 ][0] eq "=" || $_ == $#array ) ) 63 { 64 $skipped = 1; 65 next; 66 } 67 68 $str .= "\n" unless $str =~ /\n\z/; 69 if ($skipped) { 70 $return .= sprintf( "\@%d,%d (%d)\n", $eq + 1, $pos + 1, $line + $eq + 1 ); 71 $skipped = 0; 72 } 73 $last = $do; 74 $return .= join ( "", $do, " ", $str ); 75 } 76 return $return; 77} 78 79sub capture { \@_ } 80 81sub _similar { 82 my ( $str1, $str2, $name, $obj ) = @_; 83 84 s/\s+$//gm for $str1, $str2; 85 s/\r\n/\n/g for $str1, $str2; 86 s/\(0x[0-9a-xA-X]+\)/(0xdeadbeef)/g for $str1, $str2; 87 my @vars = $str2 =~ m/^(?:my\s*)?(\$\w+)\s*=/gm; 88 89 #warn "@vars"; 90 my $text = "\n" . $str1; 91 my $pat = "\n" . $str2; 92 93 unless ( like( $text, $pat ) ) { 94 if ( $] >= 5.012 ) { 95 eval qq{ 96 use re qw( Debug EXECUTE ); 97 \$text =~ \$pat; 98 1; 99 } 100 or die $@; 101 } 102 $obj->diag; 103 } 104} 105sub _same { 106 my ( $str1, $str2, $name, $obj ) = @_; 107 108 s/\s+$//gm for $str1, $str2; 109 s/\r\n/\n/g for $str1, $str2; 110 s/\(0x[0-9a-xA-X]+\)/(0xdeadbeef)/g for $str1, $str2; 111 my @vars = $str2 =~ m/^(?:my\s*)?(\$\w+)\s*=/gm; 112 113 for ($str1, $str2) { 114 s/^\s+# use warnings;\n//mg; 115 s/^\s+# use strict[^;]*;\n//mg; 116 s/# ;/#/g; 117 } 118 119 #warn "@vars"; 120 unless ( ok( "\n" . $str1 eq "\n" . $str2, $name ) ) { 121 if ( $str2 =~ /\S/ ) { 122 eval { 123 print string_diff( "\n" . $str2, "\n" . $str1, "Expected", "Result" ); 124 print "Got:\n" . $str1 . "\n"; 125 1; 126 } 127 or do { 128 print "Expected:\n$str2\nGot:\n$str1\n"; 129 } 130 } else { 131 print $str1, "\n"; 132 } 133 $obj->diag; 134 } 135} 136{ 137 my $version=""; 138 my %errors; 139 my @errors=(''); 140 141sub _dumper { 142 my ($todump)=@_; 143 my $dump; 144 my $error= ""; 145 foreach my $use_perl (1) { 146 my $warned=""; 147 local $SIG{__WARN__}=sub { my $err=join ('',@_); $warned.=$err unless $err=~/^Subroutine|Encountered/}; 148 $dump=eval { scalar Data::Dumper->new( $todump )->Purity(1)->Sortkeys(1)->Quotekeys(1)->Useperl($use_perl)->Dump() }; 149 if ( !$@ ) { 150 normalize($dump); 151 return ($dump, $error . $warned); 152 } else { 153 unless ($version) { 154 $version="\tSomething is wrong with Data::Dumper v" . Data::Dumper->VERSION . "\n"; 155 $error= $version; 156 } 157 my $msg=$@.$warned; 158 unless ($errors{$msg}) { 159 (my $err=$msg)=~s/^/\t/g; 160 push @errors,$msg; 161 $errors{$msg}=$#errors; 162 $error.=sprintf "\tData::Dumper (Useperl==$use_perl) Error(%#d):\n\t%s", 163 $#errors,$err; 164 } else { 165 $error.=sprintf "\tData::Dumper (Useperl==$use_perl) Error %#d\n",$errors{$msg}; 166 } 167 next 168 } 169 } 170 #warn $error; 171 return ($dump,$error); 172} 173} 174 175sub vstr {Data::Dump::Streamer::__vstr(@_)} 176 177our $Clean; 178 179sub normalize { 180 my @x=@_; 181 foreach (@x) { 182 #warn "<before>\n$_</before>\n"; 183 s/^\s*(no|use).*\n//gm; 184 s/^\s*BEGIN\s*\{.*\}\n//gm; 185 s/\A(?:\s*(?:#\*\.*)?\n)+//g; 186 if (/^\s+(#\s*)/) { 187 my $ind=$1; 188 s/^\s+$ind//gm; 189 } 190 s/\(0x[0-9a-fA-F]+\)/(0xdeadbeef)/g; 191 s/\r\n/\n/g; 192 s/\s+$//gm; 193 s{\\\\undef}{\\do { my \$v = \\do { my \$v = undef } }}g 194 if $] < 5.020; 195 $_.="\n"; 196 197 #warn "<after>\n$_</after>\n"; 198 } 199 unless (defined wantarray) { 200 $_[$_-1]=$x[$_-1] for 1..@_; 201 } 202 wantarray ? @x : $x[0] 203} 204 205sub similar { 206 goto &_similar unless ref( $_[1] ); 207 my $name = shift; 208 my $obj = shift; 209 my ($expect,$result) = normalize(shift, scalar $obj->Data(@_)->Out()); 210 211 my $main_pass = like( "\n$result", "\n$expect" ); 212 if ( ! $main_pass ) { 213 $obj->diag; 214 } 215 216 my @declare=grep { /^[\$\@\%]/ } @{$obj->{declare}}; 217 218 my @dump =map { /^[\@\%\&]/ ? "\\$_" : $_ } @{$obj->{out_names}}; 219 my $dumpvars=join ( ",", @dump ); 220 221 print $result,"\n" if $name=~/Test/; 222 223 my ($dumper,$error) = _dumper(\@_); 224 if ($error) { 225 diag( "$name\n$error" ) if $ENV{TEST_VERBOSE}; 226 } 227 if ($dumper) { 228 229 my $result2_eval = $result . "\n" . 'scalar( $obj->Data(' . $dumpvars . ")->Out())\n"; 230 my $dd_result_eval = 231 $result . "\nscalar(Data::Dumper->new(" 232 . 'sub{\@_}->(' . $dumpvars . ")" 233 . ")->Purity(1)->Sortkeys(1)->Quotekeys(1)->" 234 . "Useperl(1)->Dump())\n"; 235 unless ( $obj->Declare ) { 236 $dd_result_eval = "my(" . join ( ",", @declare ) . ");\n" . $dd_result_eval; 237 $result2_eval = "my(" . join ( ",", @declare ) . ");\n" . $result2_eval; 238 } 239 foreach my $test ( [ "Data::Dumper", $dd_result_eval, $dumper ], 240 [ "Data::Dump::Streamer", $result2_eval, $result ] ) { 241 my ( $test_name, $eval, $orig ) = @$test; 242 243 my ($warned,$res); 244 { 245 local $SIG{__WARN__}=sub { my $err=join ('',@_); $warned.=$err unless $err=~/^Subroutine|Encountered/}; 246 $res = eval $eval; 247 if ($warned) { print "Eval $test_name produced warnings:$warned\n$eval" }; 248 } 249 normalize($res); 250 my $fail = 0; 251 if ($@) { 252 print join "\n", "Failed $test_name eval()", $eval, $@, ""; 253 $fail = 1; 254 } elsif ( $res ne $orig ) { 255 print "Failed $test_name second time\n"; 256 eval { print string_diff( $orig, $res, "Orig", "Result" ) }; 257 print "Orig:\n$orig\nResult:\n$res\nEval:\n$eval\n"; 258 $fail = 1; 259 } 260 $obj->diag if $fail; 261 return fail($name) if $fail; 262 } 263 #print join "\n",$result,$result2,$dumper,$dd_result,""; 264 } 265 ok( $main_pass, $name ) 266} 267 268sub same { 269 goto &_same unless ref( $_[1] ); 270 my $name = shift; 271 my $obj = shift; 272 my ($expect,$result) = normalize(shift, scalar $obj->Data(@_)->Out()); 273 274 my $main_pass; 275 276 { 277 my $r=$result; 278 my $e=$expect; 279 280 281 #warn "@vars"; 282 $main_pass="\n" . $r eq "\n" . $e; 283 284 unless ( $main_pass ) { 285 if ( $e =~ /\S/ ) { 286 eval { 287 print string_diff( "\n" . $e, "\n" . $r, "Expected", "Result" ); 288 print "$name Got:\n" . $r . "\nEXPECT\n"; 289 } 290 or do { 291 print "$name Expected:\n$e\nGot:\n$r\n"; 292 } 293 } else { 294 print $r, "\n"; 295 } 296 $obj->diag; 297 } 298 } 299 300 301 my @declare=grep { /^[\$\@\%]/ } @{$obj->{declare}}; 302 303 my @dump =map { /^[\@\%\&]/ ? "\\$_" : $_ } @{$obj->{out_names}}; 304 my $dumpvars=join ( ",", @dump ); 305 306 print $result,"\n" if $name=~/Test/; 307 308 my ($dumper,$error) = _dumper(\@_); 309 if ($error) { 310 diag( "$name\n$error" ) if $ENV{TEST_VERBOSE}; 311 } 312 if ($dumper) { 313 314 my $result2_eval = $result . "\n" . 'scalar( $obj->Data(' . $dumpvars . ")->Out())\n"; 315 my $dd_result_eval = 316 $result . "\nscalar(Data::Dumper->new(" 317 . 'sub{\@_}->(' . $dumpvars . ")" 318 . ")->Purity(1)->Sortkeys(1)->Quotekeys(1)->" 319 . "Useperl(1)->Dump())\n"; 320 unless ( $obj->Declare ) { 321 $dd_result_eval = "my(" . join ( ",", @declare ) . ");\n" . $dd_result_eval; 322 $result2_eval = "my(" . join ( ",", @declare ) . ");\n" . $result2_eval; 323 } 324 foreach my $test ( [ "Data::Dumper", $dd_result_eval, $dumper ], 325 [ "Data::Dump::Streamer", $result2_eval, $result ] ) { 326 my ( $test_name, $eval, $orig ) = @$test; 327 328 my ($warned,$res); 329 { 330 local $SIG{__WARN__}=sub { my $err=join ('',@_); $warned.=$err unless $err=~/^Subroutine|Encountered/}; 331 $res = eval $eval; 332 if ($warned) { print "Eval $test_name produced warnings:$warned\n$eval" }; 333 } 334 normalize($res); 335 my $fail = 0; 336 if ($@) { 337 print join "\n", "Failed $test_name eval()", $eval, $@, ""; 338 $fail = 1; 339 } elsif ( $res ne $orig ) { 340 print "Failed $test_name second time\n"; 341 eval { print string_diff( $orig, $res, "Orig", "Result" ) }; 342 print "Orig:\n$orig\nResult:\n$res\nEval:\n$eval\n"; 343 $fail = 1; 344 } 345 $obj->diag if $fail; 346 return fail($name) if $fail; 347 } 348 #print join "\n",$result,$result2,$dumper,$dd_result,""; 349 } 350 ok( $main_pass, $name ) 351} 352 353 354 355=pod 356 357test_dump( 358 "Name", $obj, 359 @vars, 360 $expect 361 ) 362 363 364=cut 365 366my %Methods=( 367 'Data::Dumper'=>'->new(sub{\\@_}->(@_))'. 368 '->Purity(1)'. 369 '->Sortkeys(1)'. 370 '->Quotekeys(1)'. 371 '->Useperl(1)'. 372 '->Dump()', 373 'Data::Dump::Streamer'=>'->Data(@_)->Out()', 374 ); 375 376use constant NO_EVAL=>''; 377 378sub _dmp { 379 my $obj=shift; 380 my $eval=shift; 381 382 my $class=ref($obj) || $obj; 383 my $objname=ref($obj) ? '$obj' : $obj; 384 385 my @lines; 386 my $method=$Methods{$class}; 387 388 if ($eval) { 389 return @$eval if @$eval!=1; 390 my ($names,$declare,%arg)=@_; 391 392 my @declare= grep { /^[\$\@\%]/ } @$declare; 393 my @to_dump= map { /^[\@\%\&]/ ? "\\$_" : $_ } @$names; 394 my $decl=@$declare ? "my(" . join ( ",", @declare ) . ");" : ""; 395 396 push @lines,$decl,$arg{pre_eval},$eval->[0],$arg{post_eval}; 397 $method=~s/\(\@_\)/"(".join (", ",@to_dump).")"/ge; 398 } 399 400 push @lines,"normalize ( scalar $objname$method )"; 401 402 my $eval_str=join ";\n",map { !$_ ? () : (s/[\s;]+\z//g || 1) && $_ } @lines; 403 #print "\n---\n",$eval_str,"\n---\n"; 404 my $res; 405 { 406 my @w; 407 { 408 local $SIG{__WARN__}=sub { push @w,join "",@_; ""}; 409 $res=eval $eval_str; 410 } 411 warn "Test $class$method produced warnings. Code:\n$eval_str\nWarnings:\n".join("\n",@w)."\n" 412 if @w; 413 return ($res,"$class$method failed dump:\n$eval_str\n$@") 414 if $@; 415 } 416 return ($res); 417} 418 419my %ldchar=(u=>'=','+'=>'+','-'=>'-','c'=>'!'); 420my %mdchar=(u=>'|','+'=>'>','-'=>'<','c'=>'*'); 421 422sub _my_diff { 423 my ($e,$g,$mode)=@_; 424 425 unless ($Has{diff}) { 426 if ($e ne $g) { 427 return join "\n","Expected:",$e,"Got:",$g,"" 428 } else { 429 return 430 } 431 } 432 433 434 my @exp=split /\n/,$e; 435 my @got=split /\n/,$g; 436 437 438 my $line=0; 439 my $diff=0; 440 my $lw=length('Expected'); 441 my $u=3; 442 my @buff; 443 my @lines=map{ 444 if ($_->[0]ne'u') { 445 $diff=1; 446 $u=0; 447 } else { 448 $u++; 449 } 450 $lw=length $_->[1] if $lw < length $_->[1]; 451 unshift @$_,$line++; 452 if ($u<3) { 453 my @r=$u==0 && @buff ? (@buff,$_) : ($_); 454 @buff=() unless $u; 455 @r 456 } else { 457 shift @buff if @buff>=2; 458 push @buff,$_; 459 (); 460 } 461 } sdiff(\@exp,\@got); 462 my $as_str=join("\n", 463 sprintf("%7s%*s%3s%s",'',-$lw,'Expected','','Result'), 464 map { 465 sprintf "%4d %1s %*s %1s %s", 466 $_->[0],$ldchar{$_->[1]}, 467 -$lw,$_->[2]||'',$mdchar{$_->[1]}, 468 $_->[3]||'' 469 } @lines)."\n"; 470 return $diff ? $as_str : ''; 471} 472 473sub _eq { 474 my ($exp,$res,$test,$name)=@_; 475 my ($exp_err,$res_err); 476 # if they are arrays then they from tests involving _dmp 477 # but if they are empty then the test isnt performed and 478 # we can forget it 479 return 1 if ref $exp and !@$exp or ref($res) and !@$res; 480 ($exp,$exp_err)=@$exp if ref $exp; 481 ($res,$res_err)=@$res if ref $res; 482 # the thing we are trying to compare against was a failure 483 # so assume we suceed. (or rather the test cant be counted) 484 return 1 if $exp_err; 485 # result was a failure 486 if ($res_err) { 487 if ($test->{verbose}) { 488 diag "Error:\n$test->{name} subtest $name:\n",$res_err; 489 } 490 return 0 491 } 492 # finally both $exp and $res should hold results 493 my $diff=_my_diff($exp,$res); 494 if ($diff && $test->{verbose}) { 495 diag "Error:\n$test->{name} subtest $name failed to return the expected result:\n", 496 $diff 497 } 498 return !$diff; 499} 500 501# eventually id like to move everything over to this. 502 503# test_dump( {name=>"merlyns test 2", 504# verbose=>1}, $o, ( \\@a ), 505# <<'EXPECT', ); 506$::Pre_Eval = ""; 507$::Post_Eval = ""; 508$::No_Dumper = 0; 509$::No_Redump = 0; 510 511sub test_dump { 512 my $test = shift; 513 my $obj = shift; 514 my $exp = normalize(pop @_); 515 # vars are now left in @_ 516 517 $test = { 518 name => $test, 519 } 520 unless ref $test; 521 522 $test->{pre_eval}= $::Pre_Eval unless exists $test->{pre_eval}; 523 $test->{post_eval}= $::Post_Eval unless exists $test->{post_eval}; 524 $test->{no_dumper}= $::No_Dumper unless exists $test->{no_dumper}; 525 $test->{no_redump}= $::No_Redump unless exists $test->{no_redump}; 526 527 $test->{verbose} = 1 528 if not exists $test->{verbose} and $ENV{TEST_VERBOSE}; 529 530 $test->{no_dumper} = 1 if !$Has{sortkeys}; 531 532 my @res=_dmp($obj,NO_EVAL,@_); 533 534 if (@res==2) { 535 diag "Error:\n",$res[1]; 536 fail($test->{name}); 537 return 538 } 539 540 my $to_dump=$obj->{out_names}; 541 my $to_decl=$obj->Declare ? [] : $obj->{declare}||[]; 542 543 544 my @dmp =!$test->{no_dumper} 545 ? _dmp('Data::Dumper',NO_EVAL,@_) 546 : (); 547 548 if (@dmp==2 and $test->{verbose}) { 549 diag "Error:\n",$dmp[1]; 550 } 551 552 my @reres=!$test->{no_redump} 553 ? _dmp($obj,\@res,$to_dump,$to_decl,pre_eval=>$test->{pre_eval},post_eval=>$test->{post_eval}) 554 : (); 555 556 my @redmp=!$test->{no_redump} && !$test->{no_dumper} 557 ? _dmp('Data::Dumper',\@res,$to_dump,$to_decl,pre_eval=>$test->{pre_eval},post_eval=>$test->{post_eval}) 558 : (); 559 560 my $ok= @dmp<2 && 561 _eq($exp, \@res,$test,"Expected") && 562 _eq($exp, \@reres,$test,"Second time") && 563 _eq(\@dmp,\@redmp,$test,"Both Dumper's same "); 564 565 unless ($ok) { 566 warn "Got <<'EXPECT';\n$res[0]\nEXPECT\n"; 567 } 568 ok( $ok, $test->{name} ); 569} 570 571 572 573 5741; 575