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