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