cpan/B-Debug/t/debug.t

   1 #!./perl
   2
   3 BEGIN {
   4     delete $ENV{PERL_DL_NONLAZY} if $] < 5.005_58; #Perl_byterun problem
   5     if ($ENV{PERL_CORE}){
   6         chdir('t') if -d 't';
   7         if ($^O eq 'MacOS') {
   8             @INC = qw(: ::lib ::macos:lib);
   9         } else {
  10             @INC = '.';
  11             push @INC, '../lib';
  12         }
  13     } else {
  14         unshift @INC, 't';
  15     }
  16     require Config;
  17     if (($Config::Config{'extensions'} !~ /\bB\b/) ){
  18         print "1..0 # Skip -- Perl configured without B module\n";
  19         exit 0;
  20     }
  21 }
  22
  23 $|  = 1;
  24 use warnings;
  25 use strict;
  26 use Config;
  27 use Test::More tests => 11;
  28 use B;
  29 use B::Debug;
  30 use File::Spec;
  31
  32 my $a;
  33 my $X = $^X =~ m/\s/ ? qq{"$^X"} : $^X;
  34
  35 local $ENV{PERL5LIB} =
  36   join $Config{path_sep}, File::Spec->catfile("blib","lib"), @INC;
  37 my $redir = $^O =~ /VMS|MSWin32|MacOS/ ? "" : "2>&1";
  38
  39 $a = `$X "-MO=Debug" -e 1 $redir`;
  40 like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s);
  41
  42
  43 $a = `$X "-MO=Terse" -e 1 $redir`;
  44 like($a, qr/\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s);
  45
  46 $a = `$X "-MO=Terse" -ane "s/foo/bar/" $redir`;
  47 $a =~ s/\(0x[^)]+\)//g;
  48 $a =~ s/\[[^\]]+\]//g;
  49 $a =~ s/-e syntax OK//;
  50 $a =~ s/[^a-z ]+//g;
  51 $a =~ s/\s+/ /g;
  52 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
  53 $a =~ s/^\s+//;
  54 $a =~ s/\s+$//;
  55 $a =~ s/\s+nextstate$//; # if $] < 5.008001; # 5.8.0 adds it. 5.8.8 not anymore
  56 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
  57 if ($is_thread) {
  58     $b=<<EOF;
  59 leave enter nextstate label leaveloop enterloop null and defined null
  60 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
  61 threadsv const null pushmark rvav gv nextstate subst const unstack
  62 EOF
  63 } elsif ($] >= 5.021005) {
  64   $b=<<EOF;
  65 leave enter nextstate label leaveloop enterloop null and defined null null
  66 gvsv readline gv lineseq nextstate split pushre null
  67 gvsv const nextstate subst const unstack
  68 EOF
  69 } else {
  70   $b=<<EOF;
  71 leave enter nextstate label leaveloop enterloop null and defined null null
  72 gvsv readline gv lineseq nextstate aassign null pushmark split pushre null
  73 gvsv const null pushmark rvav gv nextstate subst const unstack
  74 EOF
  75 }
  76 $b=~s/\n/ /g; $b=~s/\s+/ /g;
  77 $b =~ s/\s+$//;
  78 $b =~ s/split pushre/split/ if $] >= 5.025006;
  79
  80 is($a, $b);
  81
  82 like(B::Debug::_printop(B::main_root),  qr/LISTOP\s+\[OP_LEAVE\]/);
  83 like(B::Debug::_printop(B::main_start), qr/OP\s+\[OP_ENTER\]/);
  84
  85 $a = `$X "-MO=Debug" -e "B::main_root->debug" $redir`;
  86 like($a, qr/op_next\s+0x0/m);
  87 $a = `$X "-MO=Debug" -e "B::main_start->debug" $redir`;
  88 like($a, qr/\[OP_ENTER\]/m);
  89
  90 # pass missing FETCHSIZE, fixed with 1.06
  91 my $e = q(BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};print $a[1]);
  92 $a = `$X "-MO=Debug" -e"$e" $redir`;
  93 unlike($a, qr/locate object method "FETCHSIZE"/m);
  94
  95 # NV assertion with CV, fixed with 1.13
  96 my $tmp = "tmp.pl";
  97 open TMP, ">", $tmp;
  98 print TMP 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;';
  99 close TMP;
 100 $a = `$X "-MO=Debug" $tmp $redir`;
 101 ok(! $?);
 102 unlike($a, qr/assertion "SvTYPE(sv) != SVt_PVCV" failed.*function: S_sv_2iuv_common/m);
 103 unlike($a, qr/Use of uninitialized value in print/m);
 104
 105 END { unlink $tmp if $tmp; }