1package B::Debug;
2
3our $VERSION = '1.26';
4BEGIN { if ($] >= 5.027001) { require deprecate; import deprecate; } }
5
6use strict;
7require 5.006;
8use B qw(peekop walkoptree walkoptree_exec
9         main_start main_root cstring sv_undef SVf_NOK SVf_IOK);
10use Config;
11my (@optype, @specialsv_name);
12require B;
13if ($] < 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
20if ($] < 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
29my ($have_B_Flags, $have_B_Flags_extra);
30if (!$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}
34my %done_gv;
35
36sub _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
47sub 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
56EOT
57    if ($] > 5.009) {
58	printf <<'EOT', $op->opt;
59	op_opt		%d
60EOT
61    } else {
62	printf <<'EOT', $op->seq;
63	op_seq		%d
64EOT
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
70EOT
71    } else {
72        printf <<'EOT', $op->flags, $op->private;
73	op_flags	%u
74	op_private	%u
75EOT
76    }
77    if ($op->can('rettype')) {
78        printf <<'EOT', $op->rettype;
79	op_rettype	%u
80EOT
81    }
82}
83
84sub B::UNOP::debug {
85    my ($op) = @_;
86    $op->B::OP::debug();
87    printf "\top_first\t%s\n", _printop($op->first);
88}
89
90sub B::BINOP::debug {
91    my ($op) = @_;
92    $op->B::UNOP::debug();
93    printf "\top_last \t%s\n", _printop($op->last);
94}
95
96sub 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
103EOT
104}
105
106sub B::LOGOP::debug {
107    my ($op) = @_;
108    $op->B::UNOP::debug();
109    printf "\top_other\t%s\n", _printop($op->other);
110}
111
112sub B::LISTOP::debug {
113    my ($op) = @_;
114    $op->B::BINOP::debug();
115    printf "\top_children\t%d\n", $op->children;
116}
117
118sub 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
138sub 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
150EOT
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
157sub 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
164sub 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
176sub 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
186sub B::PVOP::debug {
187    my ($op) = @_;
188    $op->B::OP::debug();
189    printf "\top_pv\t\t%s\n", cstring($op->pv);
190}
191
192sub B::PADOP::debug {
193    my ($op) = @_;
194    $op->B::OP::debug();
195    printf "\top_padix\t%ld\n", $op->padix;
196}
197
198sub 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
207sub 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
216EOT
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
224sub B::RV::debug {
225    my ($rv) = @_;
226    B::SV::debug($rv);
227    printf <<'EOT', ${$rv->RV};
228	RV		0x%x
229EOT
230    $rv->RV->debug;
231}
232
233sub 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
241EOT
242}
243
244sub 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
250sub 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
256sub 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
262sub 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
268sub 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
276sub 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
284sub 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
297EOT
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
312EOT
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
328sub B::AV::debug {
329    my ($av) = @_;
330    $av->B::SV::debug;
331    _array_debug($av);
332}
333
334sub _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
345EOT
346    } else {
347      printf <<'EOT', $fill, $av->MAX;
348	FILL		%d
349	MAX		%d
350EOT
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
362sub 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
385EOT
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
398sub 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
404sub B::PADLIST::debug {
405    my ($padlist) = @_;
406    printf <<'EOT', B::class($padlist), $$padlist, $padlist->REFCNT;
407%s (0x%x)
408	REFCNT		%d
409EOT
410    _array_debug($padlist);
411}
412
413sub 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
4241;
425
426__END__
427
428=head1 NAME
429
430B::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
439See F<ext/B/README> and the newer L<B::Concise>.
440
441=head1 OPTIONS
442
443With option -exec, walks tree in execute order,
444otherwise in basic order.
445
446=head1 AUTHOR
447
448Malcolm Beattie, C<retired>
449Reini Urban C<rurban@cpan.org>
450
451=head1 LICENSE
452
453Copyright (c) 1996, 1997 Malcolm Beattie
454Copyright (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
479