t/lib/b.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..19\n";
  19
  20 my $test = 1;
  21
  22 sub ok { print "ok $test\n"; $test++ }
  23
  24 use B::Deparse;
  25 my $deparse = B::Deparse->new() or print "not ";
  26 ok;
  27
  28 # Tell B::Deparse about our ambient pragmas
  29 { my ($hint_bits, $warning_bits);
  30  BEGIN {($hint_bits, $warning_bits) = ($^H, ${^WARNING_BITS})}
  31  $deparse->ambient_pragmas (
  32      hint_bits    => $hint_bits,
  33      warning_bits => $warning_bits,
  34      '$['         => 0 + $[
  35  );
  36 }
  37
  38 print "not " if "{\n    1;\n}" ne $deparse->coderef2text(sub {1});
  39 ok;
  40
  41 print "not " if "{\n    '???';\n    2;\n}" ne
  42                     $deparse->coderef2text(sub {1;2});
  43 ok;
  44
  45 print "not " if "{\n    \$test /= 2 if ++\$test;\n}" ne
  46                     $deparse->coderef2text(sub {++$test and $test/=2;});
  47 ok;
  48
  49 print "not " if "{\n    -((1, 2) x 2);\n}" ne
  50                     $deparse->coderef2text(sub {-((1,2)x2)});
  51 ok;
  52
  53 {
  54 my $a = <<'EOF';
  55 {
  56     $test = sub : lvalue {
  57         my $x;
  58     }
  59     ;
  60 }
  61 EOF
  62 chomp $a;
  63 print "not " if $deparse->coderef2text(sub{$test = sub : lvalue{my $x}}) ne $a;
  64 ok;
  65
  66 $a =~ s/lvalue/method/;
  67 print "not " if $deparse->coderef2text(sub{$test = sub : method{my $x}}) ne $a;
  68 ok;
  69
  70 $a =~ s/method/locked method/;
  71 print "not " if $deparse->coderef2text(sub{$test = sub : method locked {my $x}})
  72                                      ne $a;
  73 ok;
  74 }
  75
  76 print "not " if (eval "sub ".$deparse->coderef2text(sub () { 42 }))->() != 42;
  77 ok;
  78
  79 use constant 'c', 'stuff';
  80 print "not " if (eval "sub ".$deparse->coderef2text(\&c))->() ne 'stuff';
  81 ok;
  82
  83 $a = 0;
  84 print "not " if "{\n    (-1) ** \$a;\n}"
  85                 ne $deparse->coderef2text(sub{(-1) ** $a });
  86 ok;
  87
  88 # XXX ToDo - constsub that returns a reference
  89 #use constant cr => ['hello'];
  90 #my $string = "sub " . $deparse->coderef2text(\&cr);
  91 #my $val = (eval $string)->();
  92 #print "not " if ref($val) ne 'ARRAY' || $val->[0] ne 'hello';
  93 #ok;
  94
  95 my $a;
  96 my $Is_VMS = $^O eq 'VMS';
  97 my $Is_MacOS = $^O eq 'MacOS';
  98
  99 my $path = join " ", map { qq["-I$_"] } @INC;
 100 my $redir = $Is_MacOS ? "" : "2>&1";
 101
 102 $a = `$^X $path "-MO=Deparse" -anle 1 $redir`;
 103 $a =~ s/-e syntax OK\n//g;
 104 $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037
 105 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc'
 106 $b = <<'EOF';
 107
 108 LINE: while (defined($_ = <ARGV>)) {
 109     chomp $_;
 110     @F = split(/\s+/, $_, 0);
 111     '???';
 112 }
 113
 114 EOF
 115 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
 116 ok;
 117
 118 $a = `$^X $path "-MO=Debug" -e 1 $redir`;
 119 print "not " unless $a =~
 120 /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
 121 ok;
 122
 123 $a = `$^X $path "-MO=Terse" -e 1 $redir`;
 124 print "not " unless $a =~
 125 /\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s;
 126 ok;
 127
 128 $a = `$^X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
 129 $a =~ s/\(0x[^)]+\)//g;
 130 $a =~ s/\[[^\]]+\]//g;
 131 $a =~ s/-e syntax OK//;
 132 $a =~ s/[^a-z ]+//g;
 133 $a =~ s/\s+/ /g;
 134 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
 135 $a =~ s/^\s+//;
 136 $a =~ s/\s+$//;
 137 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
 138 if ($is_thread) {
 139     $b=<<EOF;
 140 leave enter nextstate label leaveloop enterloop null and defined null
 141 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
 142 threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
 143 EOF
 144 } else {
 145     $b=<<EOF;
 146 leave enter nextstate label leaveloop enterloop null and defined null
 147 null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
 148 null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
 149 EOF
 150 }
 151 $b=~s/\n/ /g;$b=~s/\s+/ /g;
 152 $b =~ s/\s+$//;
 153 print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
 154 ok;
 155
 156 chomp($a = `$^X $path "-MB::Stash" "-Mwarnings" -e1`);
 157 $a = join ',', sort split /,/, $a;
 158 $a =~ s/-u(PerlIO|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define';
 159 $a =~ s/-uWin32,// if $^O eq 'MSWin32';
 160 $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
 161 $a =~ s/-uCwd,// if $^O eq 'cygwin';
 162 if ($Config{static_ext} eq ' ') {
 163   $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
 164      . '-umain,-ustrict,-uutf8,-uwarnings';
 165   if (ord('A') == 193) { # EBCDIC sort order is qw(a A) not qw(A a)
 166       $b = join ',', sort split /,/, $b;
 167   }
 168   print "# [$a] vs [$b]\nnot " if $a ne $b;
 169   ok;
 170 } else {
 171   print "ok $test # skipped: one or more static extensions\n"; $test++;
 172 }
 173
 174 if ($is_thread) {
 175     print "# use5005threads: test $test skipped\n";
 176 } else {
 177     $a = `$^X $path "-MO=Showlex" -e "my %one" $redir`;
 178     if (ord('A') != 193) { # ASCIIish
 179         print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
 180     }
 181     else { # EBCDICish C<1: PVNV (0x1a7ede34) "%\226\225\205">
 182         print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%\\[0-9].*sv_undef.*HV/s;
 183     }
 184 }
 185 ok;
 186
 187 # Bug 20001204.07
 188 {
 189 my $foo = $deparse->coderef2text(sub { { 234; }});
 190 # Constants don't get optimised here.
 191 print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
 192 ok;
 193 $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
 194 print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;
 195 ok;
 196 }