ext/B/t/deparse.t

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