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