7 @INC = qw(: ::lib ::macos:lib);
16 if (($Config::Config{'extensions'} !~ /\bB\b/) ){
17 print "1..0 # Skip -- Perl configured without B module\n";
30 my $deparse = B::Deparse->new() or print "not ";
32 print "ok " . $i++ . "\n";
35 # Tell B::Deparse about our ambient pragmas
36 { my ($hint_bits, $warning_bits);
37 BEGIN { ($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS}); }
38 $deparse->ambient_pragmas (
39 hint_bits => $hint_bits,
40 warning_bits => $warning_bits,
50 my ($input, $expected);
51 if (/(.*)\n>>>>\n(.*)/s) {
52 ($input, $expected) = ($1, $2);
55 ($input, $expected) = ($_, $_);
58 my $coderef = eval "sub {$input}";
61 print "not ok " . $i++ . "\n";
65 my $deparsed = $deparse->coderef2text( $coderef );
66 my $regex = quotemeta($expected);
69 $regex =~ s/\s+/\s+/g;
72 my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/);
73 print (($ok ? "ok " : "not ok ") . $i++ . "\n");
75 print "# EXPECTED:\n";
80 $deparsed =~ s/^/# /mg;
86 use constant 'c', 'stuff';
87 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
88 print "ok " . $i++ . "\n";
91 print "not " if "{\n (-1) ** \$a;\n}"
92 ne $deparse->coderef2text(sub{(-1) ** $a });
93 print "ok " . $i++ . "\n";
95 use constant cr => ['hello'];
96 my $string = "sub " . $deparse->coderef2text(\&cr);
97 my $val = (eval $string)->();
98 print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
99 print "ok " . $i++ . "\n";
102 my $Is_VMS = $^O eq 'VMS';
103 my $Is_MacOS = $^O eq 'MacOS';
105 my $path = join " ", map { qq["-I$_"] } @INC;
106 $path .= " -MMac::err=unix" if $Is_MacOS;
107 my $redir = $Is_MacOS ? "" : "2>&1";
109 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
110 $a =~ s/-e syntax OK\n//g;
111 $a =~ s/.*possible typo.*\n//; # Remove warning line
112 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
113 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
115 BEGIN { $^I = ".bak"; }
117 BEGIN { $/ = "\n"; $\ = "\n"; }
118 LINE: while (defined($_ = <ARGV>)) {
120 our(@F) = split(" ", $_, 0);
124 $b =~ s/(LINE:)/sub BEGIN {
125 'MacPerl'->bootstrap;
130 print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
131 print "ok " . $i++ . "\n";
133 #Re: perlbug #35857, patch #24505
134 #handle warnings::register-ed packages properly.
135 package B::Deparse::Wrapper;
138 use warnings::register;
140 my $deparser = B::Deparse->new();
141 return $deparser->coderef2text(shift);
149 my $res = B::Deparse::Wrapper::getcode($val);
150 print $res =~ /use warnings/ ? '' : 'not ', 'ok ', $i++, "\n";
153 my $x=sub { ++$q,++$p };
155 eval <<EOFCODE and test($x);
159 use warnings::register;
177 ++$test and $test /= 2;
180 $test /= 2 if ++$test;
187 my $test = sub : lvalue {
195 my $test = sub : method {
203 my $test = sub : locked method {
231 $_ .= <ARGV> . <$foo>;
234 my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
239 # 16 - various lypes of loop
253 for (my $i = 0; $i < 2;) {
258 for (my $i = 0; $i < 2; ++$i) {
263 for (my $i = 0; $i < 2; ++$i) {
269 while ($i) { my $z = 1; } continue { $i = 99; }
284 foreach my $i (1, 2) {
289 foreach my $i (1, 2) {
294 foreach our $i (1, 2) {
300 foreach our $i (1, 2) {
306 print reverse sort(@x);
310 print((sort {$b cmp $a} @x));
314 print((reverse sort {$b <=> $a} @x));
318 print $_ foreach (reverse @a);
322 print $_ foreach (reverse 1, 2..5);