This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix -tree test for non-threaded perl
[perl5.git] / ext / B / t / concise.t
CommitLineData
c517cc47
SM
1#!./perl
2
3BEGIN {
74517a3a 4 unshift @INC, 't';
9cd8f857
NC
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 }
c0939cee 10 require 'test.pl'; # we use runperl from 'test.pl', so can't use Test::More
c517cc47
SM
11}
12
9f47963d 13plan tests => 159;
c517cc47
SM
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
c33fe613 22($op_base) = ($out =~ /^(\d+)\s*<0>\s*enter/m);
c517cc47 23
c33fe613 24is($op_base, 1, "Smallest OP sequence number");
c517cc47 25
c27ea44e
SM
26($op_base_p1, $cop_base)
27 = ($out =~ /^(\d+)\s*<;>\s*nextstate\(main (-?\d+) /m);
c517cc47 28
c33fe613
SM
29is($op_base_p1, 2, "Second-smallest OP sequence number");
30
31is($cop_base, 1, "Smallest COP sequence number");
62e36f8a
SM
32
33# test that with -exec B::Concise navigates past logops (bug #18175)
34
35$out = runperl(
36 switches => ["-MO=Concise,-exec"],
cc02ea56 37 prog => q{$a=$b && print q/foo/},
62e36f8a
SM
38 stderr => 1,
39);
c0939cee 40#diag($out);
724aa791
JC
41like($out, qr/print/, "'-exec' option output has print opcode");
42
43######## API tests v.60
44
45use Config; # used for perlio check
cc02ea56
JC
46B::Concise->import(qw( set_style set_style_standard add_callback
47 add_style walk_output reset_sequence ));
724aa791
JC
48
49## walk_output argument checking
50
724aa791 51# test that walk_output rejects non-HANDLE args
cc02ea56 52foreach my $foo ("string", [], {}) {
724aa791
JC
53 eval { walk_output($foo) };
54 isnt ($@, '', "walk_output() rejects arg '$foo'");
55 $@=''; # clear the fail for next test
56}
cc02ea56
JC
57# test accessor mode when arg undefd or 0
58foreach my $foo (undef, 0) {
59 my $handle = walk_output($foo);
60 is ($handle, \*STDOUT, "walk_output set to STDOUT (default)");
61}
724aa791
JC
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}
68my $foo = new Hugo; # suggested this API fix
69eval { walk_output($foo) };
70is ($@, '', "walk_output() accepts obj that can print");
71
2ce64696
JC
72# test that walk_output accepts a HANDLE arg
73SKIP: {
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}
724aa791
JC
90
91## add_style
92my @stylespec;
93$@='';
94eval { add_style ('junk_B' => @stylespec) };
95like ($@, 'expecting 3 style-format args',
96 "add_style rejects insufficient args");
97
98@stylespec = (0,0,0); # right length, invalid values
99$@='';
100eval { add_style ('junk' => @stylespec) };
101is ($@, '', "add_style accepts: stylename => 3-arg-array");
102
103$@='';
104eval { add_style (junk => @stylespec) };
105like ($@, 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$@='';
110eval { set_style (@stylespec) };
111is ($@, '', "set_style accepts 3 style-format args");
112
113@stylespec = (); # bad style
114
115eval { set_style (@stylespec) };
116like ($@, qr/expecting 3 style-format args/,
c0939cee 117 "set_style rejects bad style-format args");
724aa791 118
724aa791 119#### for content with doc'd options
2ce64696 120
5638aaac 121our($a, $b);
cc02ea56 122my $func = sub{ $a = $b+42 }; # canonical example asub
2ce64696 123
c0939cee
JC
124sub 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
cc02ea56
JC
132SKIP: {
133 # tests output to GLOB, using perlio feature directly
28380c63 134 skip "no perlio on this build", 127
cc02ea56
JC
135 unless $Config::Config{useperlio};
136
137 set_style_standard('concise'); # MUST CALL before output needed
138
2ce64696 139 @options = qw(
cc02ea56 140 -basic -exec -tree -compact -loose -vt -ascii
2ce64696
JC
141 -base10 -bigendian -littleendian
142 );
143 foreach $opt (@options) {
c0939cee 144 ($out) = render($opt, $func);
2ce64696
JC
145 isnt($out, '', "got output with option $opt");
146 }
cc02ea56 147
2ce64696 148 ## test output control via walk_output
cc02ea56 149
2ce64696 150 my $treegen = B::Concise::compile('-basic', $func); # reused
cc02ea56 151
2ce64696
JC
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
cc02ea56 159 # test walkoutput acceptance of a scalar-bound IO handle
724aa791
JC
160 open (my $fh, '>', \my $buf);
161 walk_output($fh);
162 $treegen->();
163 ok($buf, "walk_output to GLOB, output seen");
cc02ea56 164
c0939cee 165 ## test B::Concise::compile error checking
cc02ea56 166
2ce64696 167 # call compile on non-CODE ref items
cc02ea56
JC
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");
c0939cee 177 is($out,'', "no output when errd"); # announcement prints
cc02ea56 178 }
2ce64696 179 }
cc02ea56 180
2ce64696
JC
181 # test against a bogus autovivified subref.
182 # in debugger, it should look like:
183 # 1 CODE(0x84840cc)
184 # -> &CODE(0x84840cc) in ???
c0939cee
JC
185
186 my ($res,$err);
187 TODO: {
e75702e9 188 #local $TODO = "\tdoes this handling make sense ?";
c0939cee
JC
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);
dd48e7ab
NC
197 my @lines = split(/\n/, $res);
198 is(scalar @lines, 3,
c0939cee
JC
199 "'sub defd_empty {}' seen as 3 liner");
200
9e0f9750 201 is(1, $res =~ /leavesub/ && $res =~ /(next|db)state/,
c0939cee
JC
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';
e75702e9 211 sub AUTOLOAD { print "# in AUTOLOAD body: $AUTOLOAD\n" }
c0939cee
JC
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);
e75702e9 222 like ($res, qr/in AUTOLOAD body: /, "found body of Bar::AUTOLOAD");
c0939cee 223
2ce64696 224 }
c0939cee
JC
225 ($res,$err) = render('-basic', Foo::bar);
226 like ($res, qr/unknown function \(Foo::bar\)/,
227 "BC::compile detects fn-name as unknown function");
cc02ea56
JC
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;
5638aaac 287 %combos = (); # outputs for $mode=any($order) and any($style)
cc02ea56
JC
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
5638aaac 333 %combos = (%combos, %save);
cc02ea56
JC
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 }
724aa791 356}
cc02ea56 357
e75702e9
JC
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
373like($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
380like($out, qr/Config::AUTOLOAD exists in stash, but has no START/,
381 "coderef properly undefined");
382
9e0f9750
JC
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
389like($out, qr/FUNC: \*B::Concise::concise_cv_obj/,
390 "stash rendering of B::Concise includes Concise::concise_cv_obj");
391
392like($out, qr/FUNC: \*B::Concise::walk_output/,
393 "stash rendering includes Concise::walk_output");
394
c6036734
NC
395like($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
401like($out, qr/FUNC: \*Storable::BIN_MAJOR/,
9e0f9750
JC
402 "stash rendering includes constant sub: PAD_FAKELEX_MULTI");
403
c6036734 404like($out, qr/BIN_MAJOR is a constant sub, optimized to a IV/,
9e0f9750
JC
405 "stash rendering identifies it as constant");
406
4d3af52d 407$out = runperl ( switches => ["-MO=Concise,-stash=ExtUtils::Mksymlists,-src,-exec"],
9e0f9750
JC
408 prog => '-e 1', stderr => 1 );
409
4d3af52d 410like($out, qr/FUNC: \*ExtUtils::Mksymlists::_write_vms/,
9e0f9750
JC
411 "stash rendering loads package as needed");
412
4d3af52d
NC
413$out = runperl ( switches => ["-MO=Concise,-stash=Data::Dumper,-src,-exec"],
414 prog => '-e 1', stderr => 1 );
415
f667a15a
NC
416like($out, qr/FUNC: \*Data::Dumper::format_refaddr/,
417 "stash rendering loads package as needed");
4d3af52d 418
3d7a9343 419my $prog = q{package FOO; sub bar { print q{bar} } package main; FOO::bar(); };
bcfa18ea 420
9e0f9750
JC
421# this would fail if %INC used for -stash test
422$out = runperl ( switches => ["-MO=Concise,-src,-stash=FOO,-main"],
423 prog => $prog, stderr => 1 );
424
425like($out, qr/FUNC: \*FOO::bar/,
426 "stash rendering works on inlined package");
427
bcc76ee3
FC
428# Test that consecutive nextstate ops are not nulled out when PERLDBf_NOOPT
429# is set.
430# XXX Does this test belong here?
431
432$out = runperl ( switches => ["-MO=Concise"],
433 prog => 'BEGIN{$^P = 0x04} 1 if 0; print',
434 stderr => 1 );
435like $out, qr/nextstate.*nextstate/s,
436 'nulling of nextstate-nextstate happeneth not when $^P | PERLDBf_NOOPT';
437
9f47963d
FC
438
439# A very basic test for -tree output
440$out =
441 runperl(
442 switches => ["-MO=Concise,-tree"], prog => 'print', stderr => 1
443 );
b6aa14cd 444ok index $out=~s/\r\n/\n/gr=~s/gvsv\(\*_\)/gvsv[*_]/r, <<'end'=~s/\r\n/\n/gr =>>= 0, '-tree output';
9f47963d
FC
445<6>leave[1 ref]-+-<1>enter
446 |-<2>nextstate(main 1 -e:1)
447 `-<5>print-+-<3>pushmark
448 `-ex-rv2sv---<4>gvsv[*_]
449end
450
9e0f9750 451__END__