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