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