This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update B-Debug to CPAN version 1.26
[perl5.git] / cpan / B-Debug / Debug.pm
1 package B::Debug;
2
3 our $VERSION = '1.26';
4 BEGIN { if ($] >= 5.027001) { require deprecate; import deprecate; } }
5
6 use strict;
7 require 5.006;
8 use B qw(peekop walkoptree walkoptree_exec
9          main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
10 use Config;
11 my (@optype, @specialsv_name);
12 require B;
13 if ($] < 5.009) {
14   require B::Asmdata;
15   B::Asmdata->import (qw(@optype @specialsv_name));
16 } else {
17   B->import (qw(@optype @specialsv_name));
18 }
19
20 if ($] < 5.006002) {
21   eval q|sub B::GV::SAFENAME {
22     my $name = (shift())->NAME;
23     # The regex below corresponds to the isCONTROLVAR macro from toke.c
24     $name =~ s/^([\cA-\cZ\c\\c[\c]\c?\c_\c^])/"^".chr(64 ^ ord($1))/e;
25     return $name;
26   }|;
27 }
28
29 my ($have_B_Flags, $have_B_Flags_extra);
30 if (!$ENV{PERL_CORE}){ # avoid CORE test crashes
31   eval { require B::Flags and $have_B_Flags++ };
32   $have_B_Flags_extra++ if $have_B_Flags and $B::Flags::VERSION gt '0.03';
33 }
34 my %done_gv;
35
36 sub _printop {
37   my $op = shift;
38   my $addr = ${$op} ? $op->ppaddr : '';
39   $addr =~ s/^PL_ppaddr// if $addr;
40   if (${$op}) {
41     return sprintf "0x%08x %6s %s", ${$op}, B::class($op), $addr;
42   } else {
43     return sprintf "0x%x %6s %s", ${$op}, '', $addr;
44   }
45 }
46
47 sub B::OP::debug {
48     my ($op) = @_;
49     printf <<'EOT', B::class($op), $$op, _printop($op), _printop($op->next), _printop($op->sibling), $op->targ, $op->type, $op->name;
50 %s (0x%lx)
51         op_ppaddr       %s
52         op_next         %s
53         op_sibling      %s
54         op_targ         %d
55         op_type         %d      %s
56 EOT
57     if ($] > 5.009) {
58         printf <<'EOT', $op->opt;
59         op_opt          %d
60 EOT
61     } else {
62         printf <<'EOT', $op->seq;
63         op_seq          %d
64 EOT
65     }
66     if ($have_B_Flags) {
67         printf <<'EOT', $op->flags, $op->flagspv, $op->private, $op->privatepv;
68         op_flags        %u      %s
69         op_private      %u      %s
70 EOT
71     } else {
72         printf <<'EOT', $op->flags, $op->private;
73         op_flags        %u
74         op_private      %u
75 EOT
76     }
77     if ($op->can('rettype')) {
78         printf <<'EOT', $op->rettype;
79         op_rettype      %u
80 EOT
81     }
82 }
83
84 sub B::UNOP::debug {
85     my ($op) = @_;
86     $op->B::OP::debug();
87     printf "\top_first\t%s\n", _printop($op->first);
88 }
89
90 sub B::BINOP::debug {
91     my ($op) = @_;
92     $op->B::UNOP::debug();
93     printf "\top_last \t%s\n", _printop($op->last);
94 }
95
96 sub B::LOOP::debug {
97     my ($op) = @_;
98     $op->B::BINOP::debug();
99     printf <<'EOT', _printop($op->redoop), _printop($op->nextop), _printop($op->lastop);
100         op_redoop       %s
101         op_nextop       %s
102         op_lastop       %s
103 EOT
104 }
105
106 sub B::LOGOP::debug {
107     my ($op) = @_;
108     $op->B::UNOP::debug();
109     printf "\top_other\t%s\n", _printop($op->other);
110 }
111
112 sub B::LISTOP::debug {
113     my ($op) = @_;
114     $op->B::BINOP::debug();
115     printf "\top_children\t%d\n", $op->children;
116 }
117
118 sub B::PMOP::debug {
119     my ($op) = @_;
120     $op->B::LISTOP::debug();
121     printf "\top_pmreplroot\t0x%x\n", $] < 5.008 ? ${$op->pmreplroot} : $op->pmreplroot;
122     printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};
123     printf "\top_pmnext\t0x%x\n", ${$op->pmnext} if $] < 5.009005;
124     if ($Config{'useithreads'}) {
125       printf "\top_pmstashpv\t%s\n", cstring($op->pmstashpv);
126       printf "\top_pmoffset\t%d\n", $op->pmoffset;
127     } else {
128       printf "\top_pmstash\t%s\n", cstring($op->pmstash);
129     }
130     printf "\top_precomp\t%s\n", cstring($op->precomp);
131     printf "\top_pmflags\t0x%x\n", $op->pmflags;
132     printf "\top_reflags\t0x%x\n", $op->reflags if $] >= 5.009;
133     printf "\top_pmpermflags\t0x%x\n", $op->pmpermflags if $] < 5.009;
134     printf "\top_pmdynflags\t0x%x\n", $op->pmdynflags if $] < 5.009;
135     $op->pmreplroot->debug if $] < 5.008;
136 }
137
138 sub B::COP::debug {
139     my ($op) = @_;
140     $op->B::OP::debug();
141     my $warnings = ref $op->warnings ? ${$op->warnings} : 0;
142     printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, $warnings;
143         cop_label       "%s"
144         cop_stashpv     "%s"
145         cop_file        "%s"
146         cop_seq         %d
147         cop_arybase     %d
148         cop_line        %d
149         cop_warnings    0x%x
150 EOT
151   if ($] > 5.008 and $] < 5.011) {
152     my $cop_io = B::class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;
153     printf("    cop_io          %s\n", cstring($cop_io));
154   }
155 }
156
157 sub B::SVOP::debug {
158     my ($op) = @_;
159     $op->B::OP::debug();
160     printf "\top_sv\t\t0x%x\n", ${$op->sv};
161     $op->sv->debug;
162 }
163
164 sub B::METHOP::debug {
165     my ($op) = @_;
166     $op->B::OP::debug();
167     if (${$op->first})  {
168       printf "\top_first\t0x%x\n", ${$op->first};
169       $op->first->debug;
170     } else {
171       printf "\top_meth_sv\t0x%x\n", ${$op->meth_sv};
172       $op->meth_sv->debug;
173     }
174 }
175
176 sub B::UNOP_AUX::debug {
177     my ($op) = @_;
178     $op->B::OP::debug();
179     # string and perl5 aux_list needs the cv
180     # cperl has aux, Concise,-debug leaves it empty
181     if ($op->can('aux')) {
182         printf "\top_aux\t%s\n", cstring($op->aux);
183     }
184 }
185
186 sub B::PVOP::debug {
187     my ($op) = @_;
188     $op->B::OP::debug();
189     printf "\top_pv\t\t%s\n", cstring($op->pv);
190 }
191
192 sub B::PADOP::debug {
193     my ($op) = @_;
194     $op->B::OP::debug();
195     printf "\top_padix\t%ld\n", $op->padix;
196 }
197
198 sub B::NULL::debug {
199     my ($sv) = @_;
200     if ($$sv == ${sv_undef()}) {
201         print "&sv_undef\n";
202     } else {
203         printf "NULL (0x%x)\n", $$sv;
204     }
205 }
206
207 sub B::SV::debug {
208     my ($sv) = @_;
209     if (!$$sv) {
210         print B::class($sv), " = NULL\n";
211         return;
212     }
213     printf <<'EOT', B::class($sv), $$sv, $sv->REFCNT;
214 %s (0x%x)
215         REFCNT          %d
216 EOT
217     printf "\tFLAGS\t\t0x%x", $sv->FLAGS;
218     if ($have_B_Flags) {
219       printf "\t%s", $have_B_Flags_extra ? $sv->flagspv(0) : $sv->flagspv;
220     }
221     print "\n";
222 }
223
224 sub B::RV::debug {
225     my ($rv) = @_;
226     B::SV::debug($rv);
227     printf <<'EOT', ${$rv->RV};
228         RV              0x%x
229 EOT
230     $rv->RV->debug;
231 }
232
233 sub B::PV::debug {
234     my ($sv) = @_;
235     $sv->B::SV::debug();
236     my $pv = $sv->PV();
237     printf <<'EOT', cstring($pv), $sv->CUR, $sv->LEN;
238         xpv_pv          %s
239         xpv_cur         %d
240         xpv_len         %d
241 EOT
242 }
243
244 sub B::IV::debug {
245     my ($sv) = @_;
246     $sv->B::SV::debug();
247     printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
248 }
249
250 sub B::NV::debug {
251     my ($sv) = @_;
252     $sv->B::IV::debug();
253     printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
254 }
255
256 sub B::PVIV::debug {
257     my ($sv) = @_;
258     $sv->B::PV::debug();
259     printf "\txiv_iv\t\t%d\n", $sv->IV if $sv->FLAGS & SVf_IOK;
260 }
261
262 sub B::PVNV::debug {
263     my ($sv) = @_;
264     $sv->B::PVIV::debug();
265     printf "\txnv_nv\t\t%s\n", $sv->NV if $sv->FLAGS & SVf_NOK;
266 }
267
268 sub B::PVLV::debug {
269     my ($sv) = @_;
270     $sv->B::PVNV::debug();
271     printf "\txlv_targoff\t%d\n", $sv->TARGOFF;
272     printf "\txlv_targlen\t%u\n", $sv->TARGLEN;
273     printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));
274 }
275
276 sub B::BM::debug {
277     my ($sv) = @_;
278     $sv->B::PVNV::debug();
279     printf "\txbm_useful\t%d\n", $sv->USEFUL;
280     printf "\txbm_previous\t%u\n", $sv->PREVIOUS;
281     printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));
282 }
283
284 sub B::CV::debug {
285     my ($cv) = @_;
286     $cv->B::PVNV::debug();
287     my $stash = $cv->STASH;
288     my $start = $cv->START;
289     my $root  = $cv->ROOT;
290     my $padlist = $cv->PADLIST;
291     my $file = $cv->FILE;
292     my $gv;
293     printf <<'EOT', $$stash, $$start, $$root;
294         STASH           0x%x
295         START           0x%x
296         ROOT            0x%x
297 EOT
298     if ($cv->can('NAME_HEK') && $cv->NAME_HEK) {
299         printf("\tNAME\t%%s\n", $cv->NAME_HEK);
300     }
301     elsif ( $]>5.017 && ($cv->FLAGS & 0x40000)) { #lexsub
302         printf("\tNAME\t%%s\n", $cv->NAME_HEK);
303     } else {
304         $gv = $cv->GV;
305         printf("\tGV\t%0x%x\t%s\n", $$gv, $gv->SAFENAME);
306     }
307     printf <<'EOT', $file, $cv->DEPTH, $padlist, ${$cv->OUTSIDE};
308         FILE            %s
309         DEPTH           %d
310         PADLIST         0x%x
311         OUTSIDE         0x%x
312 EOT
313     printf("\tOUTSIDE_SEQ\t%d\n", $cv->OUTSIDE_SEQ) if $] > 5.007;
314     if ($have_B_Flags) {
315         my $SVt_PVCV = $] < 5.010 ? 12 : 13;
316         printf("\tCvFLAGS\t0x%x\t%s\n", $cv->CvFLAGS,
317                $have_B_Flags_extra ? $cv->flagspv($SVt_PVCV) : $cv->flagspv);
318     } else {
319         printf("\tCvFLAGS\t0x%x\n", $cv->CvFLAGS);
320     }
321     printf("\tSIGOP\t0x%x\n", $cv->SIGOP) if $cv->can('SIGOP');
322     $start->debug if $start;
323     $root->debug if $root;
324     $gv->debug if $gv;
325     $padlist->debug if $padlist;
326 }
327
328 sub B::AV::debug {
329     my ($av) = @_;
330     $av->B::SV::debug;
331     _array_debug($av);
332 }
333
334 sub _array_debug {
335     my ($av) = @_;
336     # tied arrays may leave out FETCHSIZE
337     my (@array) = eval { $av->ARRAY; };
338     print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
339     my $fill = eval { scalar(@array) };
340     if ($Config{'useithreads'} && B::class($av) ne 'PADLIST') {
341       printf <<'EOT', $fill, $av->MAX, $av->OFF;
342         FILL            %d
343         MAX             %d
344         OFF             %d
345 EOT
346     } else {
347       printf <<'EOT', $fill, $av->MAX;
348         FILL            %d
349         MAX             %d
350 EOT
351     }
352     if ($] < 5.009) {
353       if ($have_B_Flags) {
354         printf("\tAvFLAGS\t0x%x\t%s\n", $av->AvFLAGS,
355                $have_B_Flags_extra ? $av->flagspv(10) : $av->flagspv);
356       } else {
357         printf("\tAvFLAGS\t0x%x\n", $av->AvFLAGS);
358       }
359     }
360 }
361
362 sub B::GV::debug {
363     my ($gv) = @_;
364     if ($done_gv{$$gv}++) {
365         printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;
366         return;
367     }
368     my $sv = $gv->SV;
369     my $av = $gv->AV;
370     my $cv = $gv->CV;
371     $gv->B::SV::debug;
372     printf <<'EOT', $gv->SAFENAME, $gv->STASH->NAME, $gv->STASH, $$sv, $gv->GvREFCNT, $gv->FORM, $$av, ${$gv->HV}, ${$gv->EGV}, $$cv, $gv->CVGEN, $gv->LINE, $gv->FILE, $gv->GvFLAGS;
373         NAME            %s
374         STASH           %s (0x%x)
375         SV              0x%x
376         GvREFCNT        %d
377         FORM            0x%x
378         AV              0x%x
379         HV              0x%x
380         EGV             0x%x
381         CV              0x%x
382         CVGEN           %d
383         LINE            %d
384         FILE            %s
385 EOT
386     if ($have_B_Flags) {
387       my $SVt_PVGV = $] < 5.010 ? 13 : 9;
388       printf("\tGvFLAGS\t0x%x\t%s\n", $gv->GvFLAGS,
389              $have_B_Flags_extra ? $gv->flagspv($SVt_PVGV) : $gv->flagspv);
390     } else {
391       printf("\tGvFLAGS\t0x%x\n", $gv->GvFLAGS);
392     }
393     $sv->debug if $sv;
394     $av->debug if $av;
395     $cv->debug if $cv;
396 }
397
398 sub B::SPECIAL::debug {
399     my $sv = shift;
400     my $i = ref $sv ? $$sv : 0;
401     print defined $specialsv_name[$i] ? $specialsv_name[$i] : "", "\n";
402 }
403
404 sub B::PADLIST::debug {
405     my ($padlist) = @_;
406     printf <<'EOT', B::class($padlist), $$padlist, $padlist->REFCNT;
407 %s (0x%x)
408         REFCNT          %d
409 EOT
410     _array_debug($padlist);
411 }
412
413 sub compile {
414     my $order = shift;
415     B::clearsym();
416     $DB::single = 1 if defined &DB::DB;
417     if ($order && $order eq "exec") {
418         return sub { walkoptree_exec(main_start, "debug") }
419     } else {
420         return sub { walkoptree(main_root, "debug") }
421     }
422 }
423
424 1;
425
426 __END__
427
428 =head1 NAME
429
430 B::Debug - Walk Perl syntax tree, printing debug info about ops
431
432 =head1 SYNOPSIS
433
434         perl -MO=Debug foo.pl
435         perl -MO=Debug,-exec foo.pl
436
437 =head1 DESCRIPTION
438
439 See F<ext/B/README> and the newer L<B::Concise>.
440
441 =head1 OPTIONS
442
443 With option -exec, walks tree in execute order,
444 otherwise in basic order.
445
446 =head1 AUTHOR
447
448 Malcolm Beattie, C<retired>
449 Reini Urban C<rurban@cpan.org>
450
451 =head1 LICENSE
452
453 Copyright (c) 1996, 1997 Malcolm Beattie
454 Copyright (c) 2008, 2010, 2013, 2014 Reini Urban
455
456         This program is free software; you can redistribute it and/or modify
457         it under the terms of either:
458
459         a) the GNU General Public License as published by the Free
460         Software Foundation; either version 1, or (at your option) any
461         later version, or
462
463         b) the "Artistic License" which comes with this kit.
464
465     This program is distributed in the hope that it will be useful,
466     but WITHOUT ANY WARRANTY; without even the implied warranty of
467     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See either
468     the GNU General Public License or the Artistic License for more details.
469
470     You should have received a copy of the Artistic License with this kit,
471     in the file named "Artistic".  If not, you can get one from the Perl
472     distribution. You should also have received a copy of the GNU General
473     Public License, in the file named "Copying". If not, you can get one
474     from the Perl distribution or else write to the Free Software Foundation,
475     Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
476
477 =cut
478