t/lib/b.t

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