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