ext/B/t/deparse.t

   1 #!./perl
   2
   3 BEGIN {
   4     if ($ENV{PERL_CORE}){
   5         chdir('t') if -d 't';
   6         if ($^O eq 'MacOS') {
   7             @INC = qw(: ::lib ::macos:lib);
   8         } else {
   9             @INC = '.';
  10             push @INC, '../lib';
  11         }
  12     } else {
  13         unshift @INC, 't';
  14     }
  15     require Config;
  16     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
  17         print "1..0 # Skip -- Perl configured without B module\n";
  18         exit 0;
  19     }
  20 }
  21
  22 $|  = 1;
  23 use warnings;
  24 use strict;
  25 use Config;
  26
  27 print "1..39\n";
  28
  29 use B::Deparse;
  30 my $deparse = B::Deparse->new() or print "not ";
  31 my $i=1;
  32 print "ok " . $i++ . "\n";
  33
  34
  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,
  41      '$['         => 0 + $[
  42  );
  43 }
  44
  45 $/ = "\n####\n";
  46 while (<DATA>) {
  47     chomp;
  48     s/#.*$//mg;
  49
  50     my ($input, $expected);
  51     if (/(.*)\n>>>>\n(.*)/s) {
  52         ($input, $expected) = ($1, $2);
  53     }
  54     else {
  55         ($input, $expected) = ($_, $_);
  56     }
  57
  58     my $coderef = eval "sub {$input}";
  59
  60     if ($@) {
  61         print "not ok " . $i++ . "\n";
  62         print "# $@";
  63     }
  64     else {
  65         my $deparsed = $deparse->coderef2text( $coderef );
  66         my $regex = quotemeta($expected);
  67         do {
  68             no warnings 'misc';
  69             $regex =~ s/\s+/\s+/g;
  70         };
  71
  72         my $ok = ($deparsed =~ /^\{\s*$regex\s*\}$/);
  73         print (($ok ? "ok " : "not ok ") . $i++ . "\n");
  74         if (!$ok) {
  75             print "# EXPECTED:\n";
  76             $regex =~ s/^/# /mg;
  77             print "$regex\n";
  78
  79             print "\n# GOT: \n";
  80             $deparsed =~ s/^/# /mg;
  81             print "$deparsed\n";
  82         }
  83     }
  84 }
  85
  86 use constant 'c', 'stuff';
  87 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
  88 print "ok " . $i++ . "\n";
  89
  90 $a = 0;
  91 print "not " if "{\n    (-1) ** \$a;\n}"
  92                 ne $deparse->coderef2text(sub{(-1) ** $a });
  93 print "ok " . $i++ . "\n";
  94
  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";
 100
 101 my $a;
 102 my $Is_VMS = $^O eq 'VMS';
 103 my $Is_MacOS = $^O eq 'MacOS';
 104
 105 my $path = join " ", map { qq["-I$_"] } @INC;
 106 $path .= " -MMac::err=unix" if $Is_MacOS;
 107 my $redir = $Is_MacOS ? "" : "2>&1";
 108
 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'
 114 $b = <<'EOF';
 115 BEGIN { $^I = ".bak"; }
 116 BEGIN { $^W = 1; }
 117 BEGIN { $/ = "\n"; $\ = "\n"; }
 118 LINE: while (defined($_ = <ARGV>)) {
 119     chomp $_;
 120     our(@F) = split(" ", $_, 0);
 121     '???';
 122 }
 123 EOF
 124 $b =~ s/(LINE:)/sub BEGIN {
 125     'MacPerl'->bootstrap;
 126     'OSA'->bootstrap;
 127     'XL'->bootstrap;
 128 }
 129 $1/ if $Is_MacOS;
 130 print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
 131 print "ok " . $i++ . "\n";
 132
 133 #Re: perlbug #35857, patch #24505
 134 #handle warnings::register-ed packages properly.
 135 package B::Deparse::Wrapper;
 136 use strict;
 137 use warnings;
 138 use warnings::register;
 139 sub getcode {
 140    my $deparser = B::Deparse->new();
 141    return $deparser->coderef2text(shift);
 142 }
 143
 144 package main;
 145 use strict;
 146 use warnings;
 147 sub test {
 148    my $val = shift;
 149    my $res = B::Deparse::Wrapper::getcode($val);
 150    print $res =~ /use warnings/ ? '' : 'not ', 'ok ', $i++, "\n";
 151 }
 152 my ($q,$p);
 153 my $x=sub { ++$q,++$p };
 154 test($x);
 155 eval <<EOFCODE and test($x);
 156    package bar;
 157    use strict;
 158    use warnings;
 159    use warnings::register;
 160    package main;
 161    1
 162 EOFCODE
 163
 164 __DATA__
 165 # 2
 166 1;
 167 ####
 168 # 3
 169 {
 170     no warnings;
 171     '???';
 172     2;
 173 }
 174 ####
 175 # 4
 176 my $test;
 177 ++$test and $test /= 2;
 178 >>>>
 179 my $test;
 180 $test /= 2 if ++$test;
 181 ####
 182 # 5
 183 -((1, 2) x 2);
 184 ####
 185 # 6
 186 {
 187     my $test = sub : lvalue {
 188         my $x;
 189     }
 190     ;
 191 }
 192 ####
 193 # 7
 194 {
 195     my $test = sub : method {
 196         my $x;
 197     }
 198     ;
 199 }
 200 ####
 201 # 8
 202 {
 203     my $test = sub : locked method {
 204         my $x;
 205     }
 206     ;
 207 }
 208 ####
 209 # 9
 210 {
 211     234;
 212 }
 213 continue {
 214     123;
 215 }
 216 ####
 217 # 10
 218 my $x;
 219 print $main::x;
 220 ####
 221 # 11
 222 my @x;
 223 print $main::x[1];
 224 ####
 225 # 12
 226 my %x;
 227 $x{warn()};
 228 ####
 229 # 13
 230 my $foo;
 231 $_ .= <ARGV> . <$foo>;
 232 ####
 233 # 14
 234 my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 235 ####
 236 # 15
 237 s/x/'y';/e;
 238 ####
 239 # 16 - various lypes of loop
 240 { my $x; }
 241 ####
 242 # 17
 243 while (1) { my $k; }
 244 ####
 245 # 18
 246 my ($x,@a);
 247 $x=1 for @a;
 248 >>>>
 249 my($x, @a);
 250 $x = 1 foreach (@a);
 251 ####
 252 # 19
 253 for (my $i = 0; $i < 2;) {
 254     my $z = 1;
 255 }
 256 ####
 257 # 20
 258 for (my $i = 0; $i < 2; ++$i) {
 259     my $z = 1;
 260 }
 261 ####
 262 # 21
 263 for (my $i = 0; $i < 2; ++$i) {
 264     my $z = 1;
 265 }
 266 ####
 267 # 22
 268 my $i;
 269 while ($i) { my $z = 1; } continue { $i = 99; }
 270 ####
 271 # 23
 272 foreach $i (1, 2) {
 273     my $z = 1;
 274 }
 275 ####
 276 # 24
 277 my $i;
 278 foreach $i (1, 2) {
 279     my $z = 1;
 280 }
 281 ####
 282 # 25
 283 my $i;
 284 foreach my $i (1, 2) {
 285     my $z = 1;
 286 }
 287 ####
 288 # 26
 289 foreach my $i (1, 2) {
 290     my $z = 1;
 291 }
 292 ####
 293 # 27
 294 foreach our $i (1, 2) {
 295     my $z = 1;
 296 }
 297 ####
 298 # 28
 299 my $i;
 300 foreach our $i (1, 2) {
 301     my $z = 1;
 302 }
 303 ####
 304 # 29
 305 my @x;
 306 print reverse sort(@x);
 307 ####
 308 # 30
 309 my @x;
 310 print((sort {$b cmp $a} @x));
 311 ####
 312 # 31
 313 my @x;
 314 print((reverse sort {$b <=> $a} @x));
 315 ####
 316 # 32
 317 our @a;
 318 print $_ foreach (reverse @a);
 319 ####
 320 # 33
 321 our @a;
 322 print $_ foreach (reverse 1, 2..5);