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..18\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  # Note: there used to be ${^WARNING_BITS} here, instead of
  29  # warnings::bits('all'), but this doesn't work, as ${^WARNING_BITS} is
  30  # supposed to be the set of warnings this code has been compiled with, and
  31  # later in this test we include modules that themselves use warnings::register
  32  # (thus modyfing the warnings mask).
  33  BEGIN { ($hint_bits, $warning_bits) = ($^H, warnings::bits('all')); }
  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 # XXX ToDo - constsub that returns a reference
  92 #use constant cr => ['hello'];
  93 #my $string = "sub " . $deparse->coderef2text(\&cr);
  94 #my $val = (eval $string)->();
  95 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
  96 #print "ok " . $i++ . "\n";
  97
  98 my $a;
  99 my $Is_VMS = $^O eq 'VMS';
 100 my $Is_MacOS = $^O eq 'MacOS';
 101
 102 my $path = join " ", map { qq["-I$_"] } @INC;
 103 $path .= " -MMac::err=unix" if $Is_MacOS;
 104 my $redir = $Is_MacOS ? "" : "2>&1";
 105
 106 $a = `$^X $path "-MO=Deparse" -anlwi.bak -e 1 $redir`;
 107 $a =~ s/-e syntax OK\n//g;
 108 $a =~ s/.*possible typo.*\n//;     # Remove warning line
 109 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
 110 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
 111 $b = <<'EOF';
 112 BEGIN { $^I = ".bak"; }
 113 BEGIN { $^W = 1; }
 114 BEGIN { $/ = "\n"; $\ = "\n"; }
 115 LINE: while (defined($_ = <ARGV>)) {
 116     chomp $_;
 117     our(@F) = split(" ", $_, 0);
 118     '???';
 119 }
 120 EOF
 121 $b =~ s/(LINE:)/sub BEGIN {
 122     'MacPerl'->bootstrap;
 123     'OSA'->bootstrap;
 124     'XL'->bootstrap;
 125 }
 126 $1/ if $Is_MacOS;
 127 print "# [$a]\n\# vs expected\n# [$b]\nnot " if $a ne $b;
 128 print "ok " . $i++ . "\n";
 129
 130 __DATA__
 131 # 2
 132 1;
 133 ####
 134 # 3
 135 {
 136     no warnings;
 137     '???';
 138     2;
 139 }
 140 ####
 141 # 4
 142 my $test;
 143 ++$test and $test /= 2;
 144 >>>>
 145 my $test;
 146 $test /= 2 if ++$test;
 147 ####
 148 # 5
 149 -((1, 2) x 2);
 150 ####
 151 # 6
 152 {
 153     my $test = sub : lvalue {
 154         my $x;
 155     }
 156     ;
 157 }
 158 ####
 159 # 7
 160 {
 161     my $test = sub : method {
 162         my $x;
 163     }
 164     ;
 165 }
 166 ####
 167 # 8
 168 {
 169     my $test = sub : locked method {
 170         my $x;
 171     }
 172     ;
 173 }
 174 ####
 175 # 9
 176 {
 177     234;
 178 }
 179 continue {
 180     123;
 181 }
 182 ####
 183 # 10
 184 my $x;
 185 print $main::x;
 186 ####
 187 # 11
 188 my @x;
 189 print $main::x[1];
 190 ####
 191 # 12
 192 my %x;
 193 $x{warn()};
 194 ####
 195 # 13
 196 my $foo;
 197 $_ .= <ARGV> . <$foo>;
 198 ####
 199 # 14
 200 my $foo = "Ab\x{100}\200\x{200}\377Cd\000Ef\x{1000}\cA\x{2000}\cZ";
 201 ####
 202 # 15
 203 s/x/'y';/e;