ext/B/t/concise.t

   1 #!./perl
   2
   3 BEGIN {
   4     unshift @INC, 't';
   5     require Config;
   6     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
   7         print "1..0 # Skip -- Perl configured without B module\n";
   8         exit 0;
   9     }
  10     require 'test.pl';          # we use runperl from 'test.pl', so can't use Test::More
  11 }
  12
  13 plan tests => 163;
  14
  15 require_ok("B::Concise");
  16
  17 $out = runperl(switches => ["-MO=Concise"], prog => '$a', stderr => 1);
  18
  19 # If either of the next two tests fail, it probably means you need to
  20 # fix the section labeled 'fragile kludge' in Concise.pm
  21
  22 ($op_base) = ($out =~ /^(\d+)\s*<0>\s*enter/m);
  23
  24 is($op_base, 1, "Smallest OP sequence number");
  25
  26 ($op_base_p1, $cop_base)
  27   = ($out =~ /^(\d+)\s*<;>\s*nextstate\(main (-?\d+) /m);
  28
  29 is($op_base_p1, 2, "Second-smallest OP sequence number");
  30
  31 is($cop_base, 1, "Smallest COP sequence number");
  32
  33 # test that with -exec B::Concise navigates past logops (bug #18175)
  34
  35 $out = runperl(
  36     switches => ["-MO=Concise,-exec"],
  37     prog => q{$a=$b && print q/foo/},
  38     stderr => 1,
  39 );
  40 #diag($out);
  41 like($out, qr/print/, "'-exec' option output has print opcode");
  42
  43 ######## API tests v.60
  44
  45 use Config;     # used for perlio check
  46 B::Concise->import(qw( set_style set_style_standard add_callback
  47                        add_style walk_output reset_sequence ));
  48
  49 ## walk_output argument checking
  50
  51 # test that walk_output rejects non-HANDLE args
  52 foreach my $foo ("string", [], {}) {
  53     eval {  walk_output($foo) };
  54     isnt ($@, '', "walk_output() rejects arg '$foo'");
  55     $@=''; # clear the fail for next test
  56 }
  57 # test accessor mode when arg undefd or 0
  58 foreach my $foo (undef, 0) {
  59     my $handle = walk_output($foo);
  60     is ($handle, \*STDOUT, "walk_output set to STDOUT (default)");
  61 }
  62
  63 {   # any object that can print should be ok for walk_output
  64     package Hugo;
  65     sub new { my $foo = bless {} };
  66     sub print { CORE::print @_ }
  67 }
  68 my $foo = new Hugo;     # suggested this API fix
  69 eval {  walk_output($foo) };
  70 is ($@, '', "walk_output() accepts obj that can print");
  71
  72 # test that walk_output accepts a HANDLE arg
  73 SKIP: {
  74     skip("no perlio in this build", 4)
  75         unless $Config::Config{useperlio};
  76
  77     foreach my $foo (\*STDOUT, \*STDERR) {
  78         eval {  walk_output($foo) };
  79         is ($@, '', "walk_output() accepts STD* " . ref $foo);
  80     }
  81
  82     # now test a ref to scalar
  83     eval {  walk_output(\my $junk) };
  84     is ($@, '', "walk_output() accepts ref-to-sprintf target");
  85
  86     $junk = "non-empty";
  87     eval {  walk_output(\$junk) };
  88     is ($@, '', "walk_output() accepts ref-to-non-empty-scalar");
  89 }
  90
  91 ## add_style
  92 my @stylespec;
  93 $@='';
  94 eval { add_style ('junk_B' => @stylespec) };
  95 like ($@, qr/expecting 3 style-format args/,
  96     "add_style rejects insufficient args");
  97
  98 @stylespec = (0,0,0); # right length, invalid values
  99 $@='';
 100 eval { add_style ('junk' => @stylespec) };
 101 is ($@, '', "add_style accepts: stylename => 3-arg-array");
 102
 103 $@='';
 104 eval { add_style (junk => @stylespec) };
 105 like ($@, qr/style 'junk' already exists, choose a new name/,
 106     "add_style correctly disallows re-adding same style-name" );
 107
 108 # test new arg-checks on set_style
 109 $@='';
 110 eval { set_style (@stylespec) };
 111 is ($@, '', "set_style accepts 3 style-format args");
 112
 113 @stylespec = (); # bad style
 114
 115 eval { set_style (@stylespec) };
 116 like ($@, qr/expecting 3 style-format args/,
 117       "set_style rejects bad style-format args");
 118
 119 #### for content with doc'd options
 120
 121 our($a, $b);
 122 my $func = sub{ $a = $b+42 };   # canonical example asub
 123
 124 sub render {
 125     walk_output(\my $out);
 126     eval { B::Concise::compile(@_)->() };
 127     # diag "rendering $@\n";
 128     return ($out, $@) if wantarray;
 129     return $out;
 130 }
 131
 132 SKIP: {
 133     # tests output to GLOB, using perlio feature directly
 134     skip "no perlio on this build", 127
 135         unless $Config::Config{useperlio};
 136
 137     set_style_standard('concise');  # MUST CALL before output needed
 138
 139     @options = qw(
 140                   -basic -exec -tree -compact -loose -vt -ascii
 141                   -base10 -bigendian -littleendian
 142                   );
 143     foreach $opt (@options) {
 144         ($out) = render($opt, $func);
 145         isnt($out, '', "got output with option $opt");
 146     }
 147
 148     ## test output control via walk_output
 149
 150     my $treegen = B::Concise::compile('-basic', $func); # reused
 151
 152     { # test output into a package global string (sprintf-ish)
 153         our $thing;
 154         walk_output(\$thing);
 155         $treegen->();
 156         ok($thing, "walk_output to our SCALAR, output seen");
 157     }
 158
 159     # test walkoutput acceptance of a scalar-bound IO handle
 160     open (my $fh, '>', \my $buf);
 161     walk_output($fh);
 162     $treegen->();
 163     ok($buf, "walk_output to GLOB, output seen");
 164
 165     ## test B::Concise::compile error checking
 166
 167     # call compile on non-CODE ref items
 168     if (0) {
 169         # pending STASH splaying
 170
 171         foreach my $ref ([], {}) {
 172             my $typ = ref $ref;
 173             walk_output(\my $out);
 174             eval { B::Concise::compile('-basic', $ref)->() };
 175             like ($@, qr/^err: not a coderef: $typ/,
 176                   "compile detects $typ-ref where expecting subref");
 177             is($out,'', "no output when errd"); # announcement prints
 178         }
 179     }
 180
 181     # test against a bogus autovivified subref.
 182     # in debugger, it should look like:
 183     #  1  CODE(0x84840cc)
 184     #      -> &CODE(0x84840cc) in ???
 185
 186     my ($res,$err);
 187     TODO: {
 188         #local $TODO = "\tdoes this handling make sense ?";
 189
 190         sub declared_only;
 191         ($res,$err) = render('-basic', \&declared_only);
 192         like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
 193               "'sub decl_only' seen as having no START");
 194
 195         sub defd_empty {};
 196         ($res,$err) = render('-basic', \&defd_empty);
 197         my @lines = split(/\n/, $res);
 198         is(scalar @lines, 3,
 199            "'sub defd_empty {}' seen as 3 liner");
 200
 201         is(1, $res =~ /leavesub/ && $res =~ /(next|db)state/,
 202            "'sub defd_empty {}' seen as 2 ops: leavesub,nextstate");
 203
 204         ($res,$err) = render('-basic', \&not_even_declared);
 205         like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
 206               "'\&not_even_declared' seen as having no START");
 207
 208         {
 209             package Bar;
 210             our $AUTOLOAD = 'garbage';
 211             sub AUTOLOAD { print "# in AUTOLOAD body: $AUTOLOAD\n" }
 212         }
 213         ($res,$err) = render('-basic', Bar::auto_func);
 214         like ($res, qr/unknown function \(Bar::auto_func\)/,
 215               "Bar::auto_func seen as unknown function");
 216
 217         ($res,$err) = render('-basic', \&Bar::auto_func);
 218         like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/,
 219               "'\&Bar::auto_func' seen as having no START");
 220
 221         ($res,$err) = render('-basic', \&Bar::AUTOLOAD);
 222         like ($res, qr/in AUTOLOAD body: /, "found body of Bar::AUTOLOAD");
 223
 224     }
 225     ($res,$err) = render('-basic', Foo::bar);
 226     like ($res, qr/unknown function \(Foo::bar\)/,
 227           "BC::compile detects fn-name as unknown function");
 228
 229     # v.62 tests
 230
 231     pass ("TEST POST-COMPILE OPTION-HANDLING IN WALKER SUBROUTINE");
 232
 233     my $sample;
 234
 235     my $walker = B::Concise::compile('-basic', $func);
 236     walk_output(\$sample);
 237     $walker->('-exec');
 238     like($sample, qr/goto/m, "post-compile -exec");
 239
 240     walk_output(\$sample);
 241     $walker->('-basic');
 242     unlike($sample, qr/goto/m, "post-compile -basic");
 243
 244
 245     # bang at it combinatorically
 246     my %combos;
 247     my @modes = qw( -basic -exec );
 248     my @styles = qw( -concise -debug -linenoise -terse );
 249
 250     # prep samples
 251     for $style (@styles) {
 252         for $mode (@modes) {
 253             walk_output(\$sample);
 254             reset_sequence();
 255             $walker->($style, $mode);
 256             $combos{"$style$mode"} = $sample;
 257         }
 258     }
 259     # crosscheck that samples are all text-different
 260     @list = sort keys %combos;
 261     for $i (0..$#list) {
 262         for $j ($i+1..$#list) {
 263             isnt ($combos{$list[$i]}, $combos{$list[$j]},
 264                   "combos for $list[$i] and $list[$j] are different, as expected");
 265         }
 266     }
 267
 268     # add samples with styles in different order
 269     for $mode (@modes) {
 270         for $style (@styles) {
 271             reset_sequence();
 272             walk_output(\$sample);
 273             $walker->($mode, $style);
 274             $combos{"$mode$style"} = $sample;
 275         }
 276     }
 277     # test commutativity of flags, ie that AB == BA
 278     for $mode (@modes) {
 279         for $style (@styles) {
 280             is ( $combos{"$style$mode"},
 281                  $combos{"$mode$style"},
 282                  "results for $style$mode vs $mode$style are the same" );
 283         }
 284     }
 285
 286     my %save = %combos;
 287     %combos = ();       # outputs for $mode=any($order) and any($style)
 288
 289     # add more samples with switching modes & sticky styles
 290     for $style (@styles) {
 291         walk_output(\$sample);
 292         reset_sequence();
 293         $walker->($style);
 294         for $mode (@modes) {
 295             walk_output(\$sample);
 296             reset_sequence();
 297             $walker->($mode);
 298             $combos{"$style/$mode"} = $sample;
 299         }
 300     }
 301     # crosscheck that samples are all text-different
 302     @nm = sort keys %combos;
 303     for $i (0..$#nm) {
 304         for $j ($i+1..$#nm) {
 305             isnt ($combos{$nm[$i]}, $combos{$nm[$j]},
 306                   "results for $nm[$i] and $nm[$j] are different, as expected");
 307         }
 308     }
 309
 310     # add samples with switching styles & sticky modes
 311     for $mode (@modes) {
 312         walk_output(\$sample);
 313         reset_sequence();
 314         $walker->($mode);
 315         for $style (@styles) {
 316             walk_output(\$sample);
 317             reset_sequence();
 318             $walker->($style);
 319             $combos{"$mode/$style"} = $sample;
 320         }
 321     }
 322     # test commutativity of flags, ie that AB == BA
 323     for $mode (@modes) {
 324         for $style (@styles) {
 325             is ( $combos{"$style/$mode"},
 326                  $combos{"$mode/$style"},
 327                  "results for $style/$mode vs $mode/$style are the same" );
 328         }
 329     }
 330
 331
 332     #now do double crosschecks: commutativity across stick / nostick
 333     %combos = (%combos, %save);
 334
 335     # test commutativity of flags, ie that AB == BA
 336     for $mode (@modes) {
 337         for $style (@styles) {
 338
 339             is ( $combos{"$style$mode"},
 340                  $combos{"$style/$mode"},
 341                  "$style$mode VS $style/$mode are the same" );
 342
 343             is ( $combos{"$mode$style"},
 344                  $combos{"$mode/$style"},
 345                  "$mode$style VS $mode/$style are the same" );
 346
 347             is ( $combos{"$style$mode"},
 348                  $combos{"$mode/$style"},
 349                  "$style$mode VS $mode/$style are the same" );
 350
 351             is ( $combos{"$mode$style"},
 352                  $combos{"$style/$mode"},
 353                  "$mode$style VS $style/$mode are the same" );
 354         }
 355     }
 356 }
 357
 358
 359 # test proper NULLING of pointer, derefd by CvSTART, when a coderef is
 360 # undefd.  W/o this, the pointer can dangle into freed and reused
 361 # optree mem, which no longer points to opcodes.
 362
 363 # Using B::Concise to render Config::AUTOLOAD's optree at BEGIN-time
 364 # triggers this obscure bug, cuz AUTOLOAD has a bootstrap version,
 365 # which is used at load-time then undeffed.  It is normally
 366 # re-vivified later, but not in time for this (BEGIN/CHECK)-time
 367 # rendering.
 368
 369 $out = runperl ( switches => ["-MO=Concise,Config::AUTOLOAD"],
 370                  prog => 'use Config; BEGIN { $Config{awk} }',
 371                  stderr => 1 );
 372
 373 like($out, qr/Config::AUTOLOAD exists in stash, but has no START/,
 374     "coderef properly undefined");
 375
 376 $out = runperl ( switches => ["-MO=Concise,Config::AUTOLOAD"],
 377                  prog => 'use Config; CHECK { $Config{awk} }',
 378                  stderr => 1 );
 379
 380 like($out, qr/Config::AUTOLOAD exists in stash, but has no START/,
 381     "coderef properly undefined");
 382
 383 # test -stash and -src rendering
 384 # todo: stderr=1 puts '-e syntax OK' into $out,
 385 # conceivably fouling one of the lines that are tested
 386 $out = runperl ( switches => ["-MO=Concise,-stash=B::Concise,-src"],
 387                  prog => '-e 1', stderr => 1 );
 388
 389 like($out, qr/FUNC: \*B::Concise::concise_cv_obj/,
 390      "stash rendering of B::Concise includes Concise::concise_cv_obj");
 391
 392 like($out, qr/FUNC: \*B::Concise::walk_output/,
 393      "stash rendering includes Concise::walk_output");
 394
 395 like($out, qr/\# 4\d\d: \s+ \$l->concise\(\$level\);/,
 396      "src-line rendering works");
 397
 398 $out = runperl ( switches => ["-MStorable", "-MO=Concise,-stash=Storable,-src"],
 399                  prog => '-e 1', stderr => 1 );
 400
 401 like($out, qr/FUNC: \*Storable::BIN_MAJOR/,
 402      "stash rendering includes constant sub: PAD_FAKELEX_MULTI");
 403
 404 like($out, qr/BIN_MAJOR is a constant sub, optimized to a IV/,
 405      "stash rendering identifies it as constant");
 406
 407 $out = runperl ( switches => ["-MO=Concise,-stash=ExtUtils::Mksymlists,-src,-exec"],
 408                  prog => '-e 1', stderr => 1 );
 409
 410 like($out, qr/FUNC: \*ExtUtils::Mksymlists::_write_vms/,
 411      "stash rendering loads package as needed");
 412
 413 $out = runperl ( switches => ["-MO=Concise,-stash=Data::Dumper,-src,-exec"],
 414                  prog => '-e 1', stderr => 1 );
 415
 416 SKIP: {
 417     skip "Data::Dumper is statically linked", 1
 418         if $Config{static_ext} =~ m|\bData/Dumper\b|;
 419     like($out, qr/FUNC: \*Data::Dumper::format_refaddr/,
 420         "stash rendering loads package as needed");
 421 }
 422
 423 my $prog = q{package FOO; sub bar { print q{bar} } package main; FOO::bar(); };
 424
 425 # this would fail if %INC used for -stash test
 426 $out = runperl ( switches => ["-MO=Concise,-src,-stash=FOO,-main"],
 427                  prog => $prog, stderr => 1 );
 428
 429 like($out, qr/FUNC: \*FOO::bar/,
 430      "stash rendering works on inlined package");
 431
 432 # Test that consecutive nextstate ops are not nulled out when PERLDBf_NOOPT
 433 # is set.
 434 # XXX Does this test belong here?
 435
 436 $out = runperl ( switches => ["-MO=Concise"],
 437                  prog => 'BEGIN{$^P = 0x04} 1 if 0; print',
 438                  stderr => 1 );
 439 like $out, qr/nextstate.*nextstate/s,
 440   'nulling of nextstate-nextstate happeneth not when $^P | PERLDBf_NOOPT';
 441
 442
 443 # A very basic test for -tree output
 444 $out =
 445  runperl(
 446   switches => ["-MO=Concise,-tree"], prog => 'print', stderr => 1
 447  );
 448 ok index $out=~s/\r\n/\n/gr=~s/gvsv\(\*_\)/gvsv[*_]/r, <<'end'=~s/\r\n/\n/gr =>>= 0, '-tree output';
 449 <6>leave[1 ref]-+-<1>enter
 450                 |-<2>nextstate(main 1 -e:1)
 451                 `-<5>print-+-<3>pushmark
 452                            `-ex-rv2sv---<4>gvsv[*_]
 453 end
 454
 455 # -nobanner
 456 $out =
 457  runperl(
 458   switches => ["-MO=Concise,-nobanner,foo"], prog=>'sub foo{}', stderr => 1
 459  );
 460 unlike $out, qr/main::foo/, '-nobanner';
 461
 462 # glob
 463 $out =
 464  runperl(
 465   switches => ["-MO=Concise"], prog=>'glob(q{.})', stderr => 1
 466  );
 467 like $out, qr/\*<none>::/, 'glob(q{.})';
 468
 469 # Test op_other in -debug
 470 $out = runperl(
 471     switches => ["-MO=Concise,-debug,xx"],
 472     prog => q{sub xx { if ($a) { return $b } }},
 473     stderr => 1,
 474 );
 475
 476 $out =~s/\r\n/\n/g;
 477
 478 # Look for OP_AND
 479 $end = <<'EOF';
 480 LOGOP \(0x\w+\)
 481         op_next         0x\w+
 482         op_other        (0x\w+)
 483         op_sibling      0
 484         op_ppaddr       PL_ppaddr\[OP_AND\]
 485 EOF
 486
 487 $end =~ s/\r\n/\n/g;
 488
 489 like $out, qr/$end/, 'OP_AND has op_other';
 490
 491 # like(..) above doesn't fill in $1
 492 $out =~ $end;
 493 my $next = $1;
 494
 495 # Check it points to a PUSHMARK
 496 $end = <<'EOF';
 497 OP \(<NEXT>\)
 498         op_next         0x\w+
 499         op_sibling      0x\w+
 500         op_ppaddr       PL_ppaddr\[OP_PUSHMARK\]
 501 EOF
 502
 503 $end =~ s/<NEXT>/$next/;
 504
 505 like $out, qr/$end/, 'OP_AND->op_other points correctly';
 506
 507 __END__