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