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 $b = <<'EOF';
  75
  76 LINE: while (defined($_ = <ARGV>)) {
  77     chomp $_;
  78     @F = split(/\s+/, $_, 0);
  79     '???';
  80 }
  81
  82 EOF
  83 print "# [$a]\n\# vs\n# [$b]\nnot " if $a ne $b;
  84 ok;
  85
  86 $a = `$^X "-I../lib" "-MO=Debug" -e 1 2>&1`;
  87 print "not " unless $a =~
  88 /\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s;
  89 ok;
  90
  91 $a = `$^X "-I../lib" "-MO=Terse" -e 1 2>&1`;
  92 print "not " unless $a =~
  93 /\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s;
  94 ok;
  95
  96 $a = `$^X "-I../lib" "-MO=Terse" -ane "s/foo/bar/" 2>&1`;
  97 $a =~ s/\(0x[^)]+\)//g;
  98 $a =~ s/\[[^\]]+\]//g;
  99 $a =~ s/-e syntax OK//;
 100 $a =~ s/[^a-z ]+//g;
 101 $a =~ s/\s+/ /g;
 102 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
 103 $a =~ s/^\s+//;
 104 $a =~ s/\s+$//;
 105 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
 106 if ($is_thread) {
 107     $b=<<EOF;
 108 leave enter nextstate label leaveloop enterloop null and defined null
 109 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
 110 threadsv const null pushmark rvav gv nextstate subst const unstack nextstate
 111 EOF
 112 } else {
 113     $b=<<EOF;
 114 leave enter nextstate label leaveloop enterloop null and defined null
 115 null gvsv readline gv lineseq nextstate aassign null pushmark split pushre
 116 null gvsv const null pushmark rvav gv nextstate subst const unstack nextstate
 117 EOF
 118 }
 119 $b=~s/\n/ /g;$b=~s/\s+/ /g;
 120 $b =~ s/\s+$//;
 121 print "# [$a]\n# vs\n# [$b]\nnot " if $a ne $b;
 122 ok;
 123
 124 chomp($a = `$^X "-I../lib" "-MB::Stash" "-Mwarnings" -e1`);
 125 $a = join ',', sort split /,/, $a;
 126 $a =~ s/-u(perlio|open)(?:::\w+)?,//g if defined $Config{'useperlio'} and $Config{'useperlio'} eq 'define';
 127 $a =~ s/-uWin32,// if $^O eq 'MSWin32';
 128 $a =~ s/-u(Cwd|File|File::Copy|OS2),//g if $^O eq 'os2';
 129 $a =~ s/-uCwd,// if $^O eq 'cygwin';
 130 if ($Config{static_ext} eq ' ') {
 131   $b = '-uCarp,-uCarp::Heavy,-uDB,-uExporter,-uExporter::Heavy,-uattributes,'
 132      . '-umain,-ustrict,-uwarnings';
 133   print "# [$a] vs [$b]\nnot " if $a ne $b;
 134   ok;
 135 } else {
 136   print "ok $test # skipped: one or more static extensions\n"; $test++;
 137 }
 138
 139 if ($is_thread) {
 140     print "# use5005threads: test $test skipped\n";
 141 } else {
 142     $a = `$^X "-I../lib" "-MO=Showlex" -e "my %one" 2>&1`;
 143     print "# [$a]\nnot " unless $a =~ /sv_undef.*PVNV.*%one.*sv_undef.*HV/s;
 144 }
 145 ok;
 146
 147 # Bug 20001204.07
 148 {
 149 my $foo = $deparse->coderef2text(sub { { 234; }});
 150 # Constants don't get optimised here.
 151 print "not " unless $foo =~ /{.*{.*234;.*}.*}/sm;
 152 ok;
 153 $foo = $deparse->coderef2text(sub { { 234; } continue { 123; } });
 154 print "not " unless $foo =~ /{.*{.*234;.*}.*continue.*{.*123.*}/sm;
 155 ok;
 156 }