This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
0f60b95a5b771ca30a4df15f9b16a026681ca3a9
[perl5.git] / 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 my $path = join " ", map { qq["-I$_"] } (File::Spec->catfile("blib","lib"), @INC);
36 my $redir = $^O =~ /VMS|MSWin32|MacOS/ ? "" : "2>&1";
37
38 $a = `$X $path "-MO=Debug" -e 1 $redir`;
39 like($a, qr/\bLISTOP\b.*\bOP\b.*\bCOP\b.*\bOP\b/s);
40
41
42 $a = `$X $path "-MO=Terse" -e 1 $redir`;
43 like($a, qr/\bLISTOP\b.*leave.*\n    OP\b.*enter.*\n    COP\b.*nextstate.*\n    OP\b.*null/s);
44
45 $a = `$X $path "-MO=Terse" -ane "s/foo/bar/" $redir`;
46 $a =~ s/\(0x[^)]+\)//g;
47 $a =~ s/\[[^\]]+\]//g;
48 $a =~ s/-e syntax OK//;
49 $a =~ s/[^a-z ]+//g;
50 $a =~ s/\s+/ /g;
51 $a =~ s/\b(s|foo|bar|ullsv)\b\s?//g;
52 $a =~ s/^\s+//;
53 $a =~ s/\s+$//;
54 $a =~ s/\s+nextstate$//; # if $] < 5.008001; # 5.8.0 adds it. 5.8.8 not anymore
55 my $is_thread = $Config{use5005threads} && $Config{use5005threads} eq 'define';
56 if ($is_thread) {
57     $b=<<EOF;
58 leave enter nextstate label leaveloop enterloop null and defined null
59 threadsv readline gv lineseq nextstate aassign null pushmark split pushre
60 threadsv const null pushmark rvav gv nextstate subst const unstack
61 EOF
62 } elsif ($] >= 5.021005) {
63   $b=<<EOF;
64 leave enter nextstate label leaveloop enterloop null and defined null null
65 gvsv readline gv lineseq nextstate split pushre null
66 gvsv const nextstate subst const unstack
67 EOF
68 } else {
69   $b=<<EOF;
70 leave enter nextstate label leaveloop enterloop null and defined null null
71 gvsv readline gv lineseq nextstate aassign null pushmark split pushre null
72 gvsv const null pushmark rvav gv nextstate subst const unstack
73 EOF
74 }
75 $b=~s/\n/ /g; $b=~s/\s+/ /g;
76 $b =~ s/\s+$//;
77 $b =~ s/split pushre/split/ if $] >= 5.025006;
78
79 is($a, $b);
80
81 like(B::Debug::_printop(B::main_root),  qr/LISTOP\s+\[OP_LEAVE\]/);
82 like(B::Debug::_printop(B::main_start), qr/OP\s+\[OP_ENTER\]/);
83
84 $a = `$X $path "-MO=Debug" -e "B::main_root->debug" $redir`;
85 like($a, qr/op_next\s+0x0/m);
86 $a = `$X $path "-MO=Debug" -e "B::main_start->debug" $redir`;
87 like($a, qr/\[OP_ENTER\]/m);
88
89 # pass missing FETCHSIZE, fixed with 1.06
90 my $e = q(BEGIN{tie @a, __PACKAGE__;sub TIEARRAY {bless{}} sub FETCH{1}};print $a[1]);
91 $a = `$X $path "-MO=Debug" -e"$e" $redir`;
92 unlike($a, qr/locate object method "FETCHSIZE"/m);
93
94 # NV assertion with CV, fixed with 1.13
95 my $tmp = "tmp.pl";
96 open TMP, ">", $tmp;
97 print TMP 'my $p=1;$g=2;sub p($){my $i=1;$i+1};print p(0)+$g;';
98 close TMP;
99 $a = `$X $path "-MO=Debug" $tmp $redir`;
100 ok(! $?);
101 unlike($a, qr/assertion "SvTYPE(sv) != SVt_PVCV" failed.*function: S_sv_2iuv_common/m);
102 unlike($a, qr/Use of uninitialized value in print/m);
103
104 END { unlink $tmp if $tmp; }