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