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