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