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