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