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