7 @INC = qw(: ::lib ::macos:lib);
16 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
17 print "1..0 # Skip -- Perl configured without B module\n";
25 # BEGIN block is acutally a subroutine :-)
26 return unless $] > 5.009;
28 feature->import(':5.10');
30 use Test::More tests => 66;
33 my $deparse = B::Deparse->new();
36 # Tell B::Deparse about our ambient pragmas
37 { my ($hint_bits, $warning_bits, $hinthash);
38 BEGIN { ($hint_bits, $warning_bits, $hinthash) = ($^H, ${^WARNING_BITS}, \%^H); }
39 $deparse->ambient_pragmas (
40 hint_bits => $hint_bits,
41 warning_bits => $warning_bits,
50 # This code is pinched from the t/lib/common.pl for TODO.
51 # It's not clear how to avoid duplication
52 my ($skip, $skip_reason);
53 s/^#\s*SKIP\s*(.*)\n//m and $skip_reason = $1;
54 # If the SKIP reason starts ? then it's taken as a code snippet to evaluate
55 # This provides the flexibility to have conditional SKIPs
56 if ($skip_reason && $skip_reason =~ s/^\?//) {
57 my $temp = eval $skip_reason;
59 die "# In SKIP code reason:\n# $skip_reason\n$@";
65 my ($num, $testname) = $1 =~ m/(\d+)\s*(.*)/;
68 # Like this to avoid needing a label SKIP:
69 Test::More->builder->skip($skip_reason);
73 my ($input, $expected);
74 if (/(.*)\n>>>>\n(.*)/s) {
75 ($input, $expected) = ($1, $2);
78 ($input, $expected) = ($_, $_);
81 my $coderef = eval "sub {$input}";
84 diag("$num deparsed: $@");
88 my $deparsed = $deparse->coderef2text( $coderef );
89 my $regex = $expected;
90 $regex =~ s/(\S+)/\Q$1/g;
91 $regex =~ s/\s+/\\s+/g;
92 $regex = '^\{\s*' . $regex . '\s*\}$';
93 like($deparsed, qr/$regex/, $testname);
97 use constant 'c', 'stuff';
98 is((eval "sub ".$deparse->coderef2text(\&c))->(), 'stuff');
101 is("{\n (-1) ** \$a;\n}", $deparse->coderef2text(sub{(-1) ** $a }));
103 use constant cr => ['hello'];
104 my $string = "sub " . $deparse->coderef2text(\&cr);
105 my $val = (eval $string)->() or diag $string;
106 is(ref($val), 'ARRAY');
107 is($val->[0], 'hello');
109 my $Is_VMS = $^O eq 'VMS';
110 my $Is_MacOS = $^O eq 'MacOS';
112 my $path = join " ", map { qq["-I$_"] } @INC;
113 $path .= " -MMac::err=unix" if $Is_MacOS;
114 my $redir = $Is_MacOS ? "" : "2>&1";
116 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
117 $a =~ s/-e syntax OK\n//g;
118 $a =~ s/.*possible typo.*\n//; # Remove warning line
119 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
120 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
122 BEGIN { $^I = ".bak"; }
124 BEGIN { $/ = "\n"; $\ = "\n"; }
125 LINE: while (defined($_ = <ARGV>)) {
127 our(@F) = split(' ', $_, 0);
131 $b =~ s/(LINE:)/sub BEGIN {
132 'MacPerl'->bootstrap;
139 #Re: perlbug #35857, patch #24505
140 #handle warnings::register-ed packages properly.
141 package B::Deparse::Wrapper;
144 use warnings::register;
146 my $deparser = B::Deparse->new();
147 return $deparser->coderef2text(shift);
155 my $res = B::Deparse::Wrapper::getcode($val);
156 like( $res, qr/use warnings/);
159 my $x=sub { ++$q,++$p };
161 eval <<EOFCODE and test($x);
165 use warnings::register;
183 ++$test and $test /= 2;
186 $test /= 2 if ++$test;
193 my $test = sub : lvalue {
201 my $test = sub : method {
209 my $test = sub : locked method {
237 $_ .= <ARGV> . <$foo>;
240 my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
245 # 16 - various lypes of loop
259 for (my $i = 0; $i < 2;) {
264 for (my $i = 0; $i < 2; ++$i) {
269 for (my $i = 0; $i < 2; ++$i) {
275 while ($i) { my $z = 1; } continue { $i = 99; }
278 foreach my $i (1, 2) {
290 foreach my $i (1, 2) {
295 foreach my $i (1, 2) {
300 foreach our $i (1, 2) {
306 foreach our $i (1, 2) {
312 print reverse sort(@x);
316 print((sort {$b cmp $a} @x));
320 print((reverse sort {$b <=> $a} @x));
324 print $_ foreach (reverse @a);
328 print $_ foreach (reverse 1, 2..5);
332 @ary = split(' ', 'foo', 0);
338 do { my $x = 1; $x };
340 # 37 <20061012113037.GJ25805@c4.convolution.nl>
367 # SKIP ?$] < 5.010 && "say not implemented on this Perl version"
371 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
375 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
376 # 47 state var assignment
378 my $y = (state $x = 42);
381 # SKIP ?$] < 5.010 && "state vars not implemented on this Perl version"
382 # 48 state vars in anoymous subroutines
389 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
394 # SKIP ?$] < 5.011 && 'each @array not implemented on this Perl version'
395 # 50 keys @array; values @array
396 keys @$a if keys @ARGV;
397 values @ARGV if values @$a;
399 # 51 Anonymous arrays and hashes, and references to them
405 # SKIP ?$] < 5.010 && "smartmatch and given/when not implemented on this Perl version"
406 # 52 implicit smartmatch in given/when
408 when ('bar') { continue; }
409 when ($_ ~~ 'quux') { continue; }
413 # 53 conditions in elsifs (regression in change #33710 which fixed bug #37302)
416 elsif ($a and $b) { x(); }
417 elsif ($a or $b) { x(); }
420 # 54 interpolation in regexps
424 # SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO new undocumented cpan-bug #33708"
425 # 55 (cpan-bug #33708)
428 # SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO hash constants not yet fixed"
429 # 56 (cpan-bug #33708)
430 use constant H => { "#" => 1 }; H->{"#"}
432 # SKIP ?$B::Deparse::VERSION <= 0.87 && "TODO optimized away 0 not yet fixed"
433 # 57 (cpan-bug #33708)
434 foreach my $i (@_) { 0 }
436 # 58 tests with not, not optimized
439 x() if not $a and $b;
440 x() if $a and not $b;
441 x() unless not $a and $b;
442 x() unless $a and not $b;
445 x() unless not $a or $b;
446 x() unless $a or not $b;
447 x() if $a and not $b and $c;
448 x() if not $a and $b and not $c;
449 x() unless $a and not $b and $c;
450 x() unless not $a and $b and not $c;
451 x() if $a or not $b or $c;
452 x() if not $a or $b or not $c;
453 x() unless $a or not $b or $c;
454 x() unless not $a or $b or not $c;
456 # 59 tests with not, optimized
460 x() if not $a and not $b;
461 x() unless not $a and not $b;
462 x() if not $a or not $b;
463 x() unless not $a or not $b;
464 x() if not $a and not $b and $c;
465 x() unless not $a and not $b and $c;
466 x() if not $a or not $b or $c;
467 x() unless not $a or not $b or $c;
468 x() if not $a and not $b and not $c;
469 x() unless not $a and not $b and not $c;
470 x() if not $a or not $b or not $c;
471 x() unless not $a or not $b or not $c;
472 x() unless not $a or not $b or not $c;
479 x() unless $a and $b;
481 x() if not $a || $b and $c;
482 x() unless not $a || $b and $c;
483 x() if not $a && $b or $c;
484 x() unless not $a && $b or $c;
485 x() unless $a or $b or $c;
486 x() if $a or $b or $c;
487 x() unless $a and $b and $c;
488 x() if $a and $b and $c;
489 x() unless not $a && $b && $c;