Commit | Line | Data |
---|---|---|
c517cc47 SM |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
5638aaac SM |
4 | if ($ENV{PERL_CORE}){ |
5 | chdir('t') if -d 't'; | |
6 | @INC = ('.', '../lib'); | |
7 | } else { | |
8 | unshift @INC, 't'; | |
9 | push @INC, "../../t"; | |
10 | } | |
9cd8f857 NC |
11 | require Config; |
12 | if (($Config::Config{'extensions'} !~ /\bB\b/) ){ | |
13 | print "1..0 # Skip -- Perl configured without B module\n"; | |
14 | exit 0; | |
15 | } | |
c0939cee JC |
16 | require 'test.pl'; # we use runperl from 'test.pl', so can't use Test::More |
17 | sub diag { print "# @_\n" } # but this is still handy | |
c517cc47 SM |
18 | } |
19 | ||
e75702e9 | 20 | plan tests => 149; |
c517cc47 SM |
21 | |
22 | require_ok("B::Concise"); | |
23 | ||
24 | $out = runperl(switches => ["-MO=Concise"], prog => '$a', stderr => 1); | |
25 | ||
26 | # If either of the next two tests fail, it probably means you need to | |
27 | # fix the section labeled 'fragile kludge' in Concise.pm | |
28 | ||
c33fe613 | 29 | ($op_base) = ($out =~ /^(\d+)\s*<0>\s*enter/m); |
c517cc47 | 30 | |
c33fe613 | 31 | is($op_base, 1, "Smallest OP sequence number"); |
c517cc47 | 32 | |
c27ea44e SM |
33 | ($op_base_p1, $cop_base) |
34 | = ($out =~ /^(\d+)\s*<;>\s*nextstate\(main (-?\d+) /m); | |
c517cc47 | 35 | |
c33fe613 SM |
36 | is($op_base_p1, 2, "Second-smallest OP sequence number"); |
37 | ||
38 | is($cop_base, 1, "Smallest COP sequence number"); | |
62e36f8a SM |
39 | |
40 | # test that with -exec B::Concise navigates past logops (bug #18175) | |
41 | ||
42 | $out = runperl( | |
43 | switches => ["-MO=Concise,-exec"], | |
cc02ea56 | 44 | prog => q{$a=$b && print q/foo/}, |
62e36f8a SM |
45 | stderr => 1, |
46 | ); | |
c0939cee | 47 | #diag($out); |
724aa791 JC |
48 | like($out, qr/print/, "'-exec' option output has print opcode"); |
49 | ||
50 | ######## API tests v.60 | |
51 | ||
52 | use Config; # used for perlio check | |
cc02ea56 JC |
53 | B::Concise->import(qw( set_style set_style_standard add_callback |
54 | add_style walk_output reset_sequence )); | |
724aa791 JC |
55 | |
56 | ## walk_output argument checking | |
57 | ||
724aa791 | 58 | # test that walk_output rejects non-HANDLE args |
cc02ea56 | 59 | foreach my $foo ("string", [], {}) { |
724aa791 JC |
60 | eval { walk_output($foo) }; |
61 | isnt ($@, '', "walk_output() rejects arg '$foo'"); | |
62 | $@=''; # clear the fail for next test | |
63 | } | |
cc02ea56 JC |
64 | # test accessor mode when arg undefd or 0 |
65 | foreach my $foo (undef, 0) { | |
66 | my $handle = walk_output($foo); | |
67 | is ($handle, \*STDOUT, "walk_output set to STDOUT (default)"); | |
68 | } | |
724aa791 JC |
69 | |
70 | { # any object that can print should be ok for walk_output | |
71 | package Hugo; | |
72 | sub new { my $foo = bless {} }; | |
73 | sub print { CORE::print @_ } | |
74 | } | |
75 | my $foo = new Hugo; # suggested this API fix | |
76 | eval { walk_output($foo) }; | |
77 | is ($@, '', "walk_output() accepts obj that can print"); | |
78 | ||
2ce64696 JC |
79 | # test that walk_output accepts a HANDLE arg |
80 | SKIP: { | |
81 | skip("no perlio in this build", 4) | |
82 | unless $Config::Config{useperlio}; | |
83 | ||
84 | foreach my $foo (\*STDOUT, \*STDERR) { | |
85 | eval { walk_output($foo) }; | |
86 | is ($@, '', "walk_output() accepts STD* " . ref $foo); | |
87 | } | |
88 | ||
89 | # now test a ref to scalar | |
90 | eval { walk_output(\my $junk) }; | |
91 | is ($@, '', "walk_output() accepts ref-to-sprintf target"); | |
92 | ||
93 | $junk = "non-empty"; | |
94 | eval { walk_output(\$junk) }; | |
95 | is ($@, '', "walk_output() accepts ref-to-non-empty-scalar"); | |
96 | } | |
724aa791 JC |
97 | |
98 | ## add_style | |
99 | my @stylespec; | |
100 | $@=''; | |
101 | eval { add_style ('junk_B' => @stylespec) }; | |
102 | like ($@, 'expecting 3 style-format args', | |
103 | "add_style rejects insufficient args"); | |
104 | ||
105 | @stylespec = (0,0,0); # right length, invalid values | |
106 | $@=''; | |
107 | eval { add_style ('junk' => @stylespec) }; | |
108 | is ($@, '', "add_style accepts: stylename => 3-arg-array"); | |
109 | ||
110 | $@=''; | |
111 | eval { add_style (junk => @stylespec) }; | |
112 | like ($@, qr/style 'junk' already exists, choose a new name/, | |
113 | "add_style correctly disallows re-adding same style-name" ); | |
114 | ||
115 | # test new arg-checks on set_style | |
116 | $@=''; | |
117 | eval { set_style (@stylespec) }; | |
118 | is ($@, '', "set_style accepts 3 style-format args"); | |
119 | ||
120 | @stylespec = (); # bad style | |
121 | ||
122 | eval { set_style (@stylespec) }; | |
123 | like ($@, qr/expecting 3 style-format args/, | |
c0939cee | 124 | "set_style rejects bad style-format args"); |
724aa791 | 125 | |
724aa791 | 126 | #### for content with doc'd options |
2ce64696 | 127 | |
5638aaac | 128 | our($a, $b); |
cc02ea56 | 129 | my $func = sub{ $a = $b+42 }; # canonical example asub |
2ce64696 | 130 | |
c0939cee JC |
131 | sub render { |
132 | walk_output(\my $out); | |
133 | eval { B::Concise::compile(@_)->() }; | |
134 | # diag "rendering $@\n"; | |
135 | return ($out, $@) if wantarray; | |
136 | return $out; | |
137 | } | |
138 | ||
cc02ea56 JC |
139 | SKIP: { |
140 | # tests output to GLOB, using perlio feature directly | |
28380c63 | 141 | skip "no perlio on this build", 127 |
cc02ea56 JC |
142 | unless $Config::Config{useperlio}; |
143 | ||
144 | set_style_standard('concise'); # MUST CALL before output needed | |
145 | ||
2ce64696 | 146 | @options = qw( |
cc02ea56 | 147 | -basic -exec -tree -compact -loose -vt -ascii |
2ce64696 JC |
148 | -base10 -bigendian -littleendian |
149 | ); | |
150 | foreach $opt (@options) { | |
c0939cee | 151 | ($out) = render($opt, $func); |
2ce64696 JC |
152 | isnt($out, '', "got output with option $opt"); |
153 | } | |
cc02ea56 | 154 | |
2ce64696 | 155 | ## test output control via walk_output |
cc02ea56 | 156 | |
2ce64696 | 157 | my $treegen = B::Concise::compile('-basic', $func); # reused |
cc02ea56 | 158 | |
2ce64696 JC |
159 | { # test output into a package global string (sprintf-ish) |
160 | our $thing; | |
161 | walk_output(\$thing); | |
162 | $treegen->(); | |
163 | ok($thing, "walk_output to our SCALAR, output seen"); | |
164 | } | |
165 | ||
cc02ea56 | 166 | # test walkoutput acceptance of a scalar-bound IO handle |
724aa791 JC |
167 | open (my $fh, '>', \my $buf); |
168 | walk_output($fh); | |
169 | $treegen->(); | |
170 | ok($buf, "walk_output to GLOB, output seen"); | |
cc02ea56 | 171 | |
c0939cee | 172 | ## test B::Concise::compile error checking |
cc02ea56 | 173 | |
2ce64696 | 174 | # call compile on non-CODE ref items |
cc02ea56 JC |
175 | if (0) { |
176 | # pending STASH splaying | |
177 | ||
178 | foreach my $ref ([], {}) { | |
179 | my $typ = ref $ref; | |
180 | walk_output(\my $out); | |
181 | eval { B::Concise::compile('-basic', $ref)->() }; | |
182 | like ($@, qr/^err: not a coderef: $typ/, | |
183 | "compile detects $typ-ref where expecting subref"); | |
c0939cee | 184 | is($out,'', "no output when errd"); # announcement prints |
cc02ea56 | 185 | } |
2ce64696 | 186 | } |
cc02ea56 | 187 | |
2ce64696 JC |
188 | # test against a bogus autovivified subref. |
189 | # in debugger, it should look like: | |
190 | # 1 CODE(0x84840cc) | |
191 | # -> &CODE(0x84840cc) in ??? | |
c0939cee JC |
192 | |
193 | my ($res,$err); | |
194 | TODO: { | |
e75702e9 | 195 | #local $TODO = "\tdoes this handling make sense ?"; |
c0939cee JC |
196 | |
197 | sub declared_only; | |
198 | ($res,$err) = render('-basic', \&declared_only); | |
199 | like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/, | |
200 | "'sub decl_only' seen as having no START"); | |
201 | ||
202 | sub defd_empty {}; | |
203 | ($res,$err) = render('-basic', \&defd_empty); | |
204 | is(scalar split(/\n/, $res), 3, | |
205 | "'sub defd_empty {}' seen as 3 liner"); | |
206 | ||
207 | is(1, $res =~ /leavesub/ && $res =~ /nextstate/, | |
208 | "'sub defd_empty {}' seen as 2 ops: leavesub,nextstate"); | |
209 | ||
210 | ($res,$err) = render('-basic', \¬_even_declared); | |
211 | like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/, | |
212 | "'\¬_even_declared' seen as having no START"); | |
213 | ||
214 | { | |
215 | package Bar; | |
216 | our $AUTOLOAD = 'garbage'; | |
e75702e9 | 217 | sub AUTOLOAD { print "# in AUTOLOAD body: $AUTOLOAD\n" } |
c0939cee JC |
218 | } |
219 | ($res,$err) = render('-basic', Bar::auto_func); | |
220 | like ($res, qr/unknown function \(Bar::auto_func\)/, | |
221 | "Bar::auto_func seen as unknown function"); | |
222 | ||
223 | ($res,$err) = render('-basic', \&Bar::auto_func); | |
224 | like ($res, qr/coderef CODE\(0x[0-9a-fA-F]+\) has no START/, | |
225 | "'\&Bar::auto_func' seen as having no START"); | |
226 | ||
227 | ($res,$err) = render('-basic', \&Bar::AUTOLOAD); | |
e75702e9 | 228 | like ($res, qr/in AUTOLOAD body: /, "found body of Bar::AUTOLOAD"); |
c0939cee | 229 | |
2ce64696 | 230 | } |
c0939cee JC |
231 | ($res,$err) = render('-basic', Foo::bar); |
232 | like ($res, qr/unknown function \(Foo::bar\)/, | |
233 | "BC::compile detects fn-name as unknown function"); | |
cc02ea56 JC |
234 | |
235 | # v.62 tests | |
236 | ||
237 | pass ("TEST POST-COMPILE OPTION-HANDLING IN WALKER SUBROUTINE"); | |
238 | ||
239 | my $sample; | |
240 | ||
241 | my $walker = B::Concise::compile('-basic', $func); | |
242 | walk_output(\$sample); | |
243 | $walker->('-exec'); | |
244 | like($sample, qr/goto/m, "post-compile -exec"); | |
245 | ||
246 | walk_output(\$sample); | |
247 | $walker->('-basic'); | |
248 | unlike($sample, qr/goto/m, "post-compile -basic"); | |
249 | ||
250 | ||
251 | # bang at it combinatorically | |
252 | my %combos; | |
253 | my @modes = qw( -basic -exec ); | |
254 | my @styles = qw( -concise -debug -linenoise -terse ); | |
255 | ||
256 | # prep samples | |
257 | for $style (@styles) { | |
258 | for $mode (@modes) { | |
259 | walk_output(\$sample); | |
260 | reset_sequence(); | |
261 | $walker->($style, $mode); | |
262 | $combos{"$style$mode"} = $sample; | |
263 | } | |
264 | } | |
265 | # crosscheck that samples are all text-different | |
266 | @list = sort keys %combos; | |
267 | for $i (0..$#list) { | |
268 | for $j ($i+1..$#list) { | |
269 | isnt ($combos{$list[$i]}, $combos{$list[$j]}, | |
270 | "combos for $list[$i] and $list[$j] are different, as expected"); | |
271 | } | |
272 | } | |
273 | ||
274 | # add samples with styles in different order | |
275 | for $mode (@modes) { | |
276 | for $style (@styles) { | |
277 | reset_sequence(); | |
278 | walk_output(\$sample); | |
279 | $walker->($mode, $style); | |
280 | $combos{"$mode$style"} = $sample; | |
281 | } | |
282 | } | |
283 | # test commutativity of flags, ie that AB == BA | |
284 | for $mode (@modes) { | |
285 | for $style (@styles) { | |
286 | is ( $combos{"$style$mode"}, | |
287 | $combos{"$mode$style"}, | |
288 | "results for $style$mode vs $mode$style are the same" ); | |
289 | } | |
290 | } | |
291 | ||
292 | my %save = %combos; | |
5638aaac | 293 | %combos = (); # outputs for $mode=any($order) and any($style) |
cc02ea56 JC |
294 | |
295 | # add more samples with switching modes & sticky styles | |
296 | for $style (@styles) { | |
297 | walk_output(\$sample); | |
298 | reset_sequence(); | |
299 | $walker->($style); | |
300 | for $mode (@modes) { | |
301 | walk_output(\$sample); | |
302 | reset_sequence(); | |
303 | $walker->($mode); | |
304 | $combos{"$style/$mode"} = $sample; | |
305 | } | |
306 | } | |
307 | # crosscheck that samples are all text-different | |
308 | @nm = sort keys %combos; | |
309 | for $i (0..$#nm) { | |
310 | for $j ($i+1..$#nm) { | |
311 | isnt ($combos{$nm[$i]}, $combos{$nm[$j]}, | |
312 | "results for $nm[$i] and $nm[$j] are different, as expected"); | |
313 | } | |
314 | } | |
315 | ||
316 | # add samples with switching styles & sticky modes | |
317 | for $mode (@modes) { | |
318 | walk_output(\$sample); | |
319 | reset_sequence(); | |
320 | $walker->($mode); | |
321 | for $style (@styles) { | |
322 | walk_output(\$sample); | |
323 | reset_sequence(); | |
324 | $walker->($style); | |
325 | $combos{"$mode/$style"} = $sample; | |
326 | } | |
327 | } | |
328 | # test commutativity of flags, ie that AB == BA | |
329 | for $mode (@modes) { | |
330 | for $style (@styles) { | |
331 | is ( $combos{"$style/$mode"}, | |
332 | $combos{"$mode/$style"}, | |
333 | "results for $style/$mode vs $mode/$style are the same" ); | |
334 | } | |
335 | } | |
336 | ||
337 | ||
338 | #now do double crosschecks: commutativity across stick / nostick | |
5638aaac | 339 | %combos = (%combos, %save); |
cc02ea56 JC |
340 | |
341 | # test commutativity of flags, ie that AB == BA | |
342 | for $mode (@modes) { | |
343 | for $style (@styles) { | |
344 | ||
345 | is ( $combos{"$style$mode"}, | |
346 | $combos{"$style/$mode"}, | |
347 | "$style$mode VS $style/$mode are the same" ); | |
348 | ||
349 | is ( $combos{"$mode$style"}, | |
350 | $combos{"$mode/$style"}, | |
351 | "$mode$style VS $mode/$style are the same" ); | |
352 | ||
353 | is ( $combos{"$style$mode"}, | |
354 | $combos{"$mode/$style"}, | |
355 | "$style$mode VS $mode/$style are the same" ); | |
356 | ||
357 | is ( $combos{"$mode$style"}, | |
358 | $combos{"$style/$mode"}, | |
359 | "$mode$style VS $style/$mode are the same" ); | |
360 | } | |
361 | } | |
724aa791 | 362 | } |
cc02ea56 | 363 | |
e75702e9 JC |
364 | |
365 | # test proper NULLING of pointer, derefd by CvSTART, when a coderef is | |
366 | # undefd. W/o this, the pointer can dangle into freed and reused | |
367 | # optree mem, which no longer points to opcodes. | |
368 | ||
369 | # Using B::Concise to render Config::AUTOLOAD's optree at BEGIN-time | |
370 | # triggers this obscure bug, cuz AUTOLOAD has a bootstrap version, | |
371 | # which is used at load-time then undeffed. It is normally | |
372 | # re-vivified later, but not in time for this (BEGIN/CHECK)-time | |
373 | # rendering. | |
374 | ||
375 | $out = runperl ( switches => ["-MO=Concise,Config::AUTOLOAD"], | |
376 | prog => 'use Config; BEGIN { $Config{awk} }', | |
377 | stderr => 1 ); | |
378 | ||
379 | like($out, qr/Config::AUTOLOAD exists in stash, but has no START/, | |
380 | "coderef properly undefined"); | |
381 | ||
382 | $out = runperl ( switches => ["-MO=Concise,Config::AUTOLOAD"], | |
383 | prog => 'use Config; CHECK { $Config{awk} }', | |
384 | stderr => 1 ); | |
385 | ||
386 | like($out, qr/Config::AUTOLOAD exists in stash, but has no START/, | |
387 | "coderef properly undefined"); | |
388 | ||
cc02ea56 JC |
389 | __END__ |
390 |