| 1 | package B::Debug; |
| 2 | |
| 3 | our $VERSION = '1.00'; |
| 4 | |
| 5 | use strict; |
| 6 | use B qw(peekop class walkoptree walkoptree_exec |
| 7 | main_start main_root cstring sv_undef); |
| 8 | use B::Asmdata qw(@specialsv_name); |
| 9 | |
| 10 | my %done_gv; |
| 11 | |
| 12 | sub B::OP::debug { |
| 13 | my ($op) = @_; |
| 14 | printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private; |
| 15 | %s (0x%lx) |
| 16 | op_next 0x%x |
| 17 | op_sibling 0x%x |
| 18 | op_ppaddr %s |
| 19 | op_targ %d |
| 20 | op_type %d |
| 21 | op_seq %d |
| 22 | op_flags %d |
| 23 | op_private %d |
| 24 | EOT |
| 25 | } |
| 26 | |
| 27 | sub B::UNOP::debug { |
| 28 | my ($op) = @_; |
| 29 | $op->B::OP::debug(); |
| 30 | printf "\top_first\t0x%x\n", ${$op->first}; |
| 31 | } |
| 32 | |
| 33 | sub B::BINOP::debug { |
| 34 | my ($op) = @_; |
| 35 | $op->B::UNOP::debug(); |
| 36 | printf "\top_last\t\t0x%x\n", ${$op->last}; |
| 37 | } |
| 38 | |
| 39 | sub B::LOOP::debug { |
| 40 | my ($op) = @_; |
| 41 | $op->B::BINOP::debug(); |
| 42 | printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop}; |
| 43 | op_redoop 0x%x |
| 44 | op_nextop 0x%x |
| 45 | op_lastop 0x%x |
| 46 | EOT |
| 47 | } |
| 48 | |
| 49 | sub B::LOGOP::debug { |
| 50 | my ($op) = @_; |
| 51 | $op->B::UNOP::debug(); |
| 52 | printf "\top_other\t0x%x\n", ${$op->other}; |
| 53 | } |
| 54 | |
| 55 | sub B::LISTOP::debug { |
| 56 | my ($op) = @_; |
| 57 | $op->B::BINOP::debug(); |
| 58 | printf "\top_children\t%d\n", $op->children; |
| 59 | } |
| 60 | |
| 61 | sub B::PMOP::debug { |
| 62 | my ($op) = @_; |
| 63 | $op->B::LISTOP::debug(); |
| 64 | printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot}; |
| 65 | printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart}; |
| 66 | printf "\top_pmnext\t0x%x\n", ${$op->pmnext}; |
| 67 | printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp); |
| 68 | printf "\top_pmflags\t0x%x\n", $op->pmflags; |
| 69 | $op->pmreplroot->debug; |
| 70 | } |
| 71 | |
| 72 | sub B::COP::debug { |
| 73 | my ($op) = @_; |
| 74 | $op->B::OP::debug(); |
| 75 | my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string; |
| 76 | printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io); |
| 77 | cop_label %s |
| 78 | cop_stashpv %s |
| 79 | cop_file %s |
| 80 | cop_seq %d |
| 81 | cop_arybase %d |
| 82 | cop_line %d |
| 83 | cop_warnings 0x%x |
| 84 | cop_io %s |
| 85 | EOT |
| 86 | } |
| 87 | |
| 88 | sub B::SVOP::debug { |
| 89 | my ($op) = @_; |
| 90 | $op->B::OP::debug(); |
| 91 | printf "\top_sv\t\t0x%x\n", ${$op->sv}; |
| 92 | $op->sv->debug; |
| 93 | } |
| 94 | |
| 95 | sub B::PVOP::debug { |
| 96 | my ($op) = @_; |
| 97 | $op->B::OP::debug(); |
| 98 | printf "\top_pv\t\t%s\n", cstring($op->pv); |
| 99 | } |
| 100 | |
| 101 | sub B::PADOP::debug { |
| 102 | my ($op) = @_; |
| 103 | $op->B::OP::debug(); |
| 104 | printf "\top_padix\t\t%ld\n", $op->padix; |
| 105 | } |
| 106 | |
| 107 | sub B::NULL::debug { |
| 108 | my ($sv) = @_; |
| 109 | if ($$sv == ${sv_undef()}) { |
| 110 | print "&sv_undef\n"; |
| 111 | } else { |
| 112 | printf "NULL (0x%x)\n", $$sv; |
| 113 | } |
| 114 | } |
| 115 | |
| 116 | sub B::SV::debug { |
| 117 | my ($sv) = @_; |
| 118 | if (!$$sv) { |
| 119 | print class($sv), " = NULL\n"; |
| 120 | return; |
| 121 | } |
| 122 | printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS; |
| 123 | %s (0x%x) |
| 124 | REFCNT %d |
| 125 | FLAGS 0x%x |
| 126 | EOT |
| 127 | } |
| 128 | |
| 129 | sub B::RV::debug { |
| 130 | my ($rv) = @_; |
| 131 | B::SV::debug($rv); |
| 132 | printf <<'EOT', ${$rv->RV}; |
| 133 | RV 0x%x |
| 134 | EOT |
| 135 | $rv->RV->debug; |
| 136 | } |
| 137 | |
| 138 | sub B::PV::debug { |
| 139 | my ($sv) = @_; |
| 140 | $sv->B::SV::debug(); |
| 141 | my $pv = $sv->PV(); |
| 142 | printf <<'EOT', cstring($pv), length($pv); |
| 143 | xpv_pv %s |
| 144 | xpv_cur %d |
| 145 | EOT |
| 146 | } |
| 147 | |
| 148 | sub B::IV::debug { |
| 149 | my ($sv) = @_; |
| 150 | $sv->B::SV::debug(); |
| 151 | printf "\txiv_iv\t\t%d\n", $sv->IV; |
| 152 | } |
| 153 | |
| 154 | sub B::NV::debug { |
| 155 | my ($sv) = @_; |
| 156 | $sv->B::IV::debug(); |
| 157 | printf "\txnv_nv\t\t%s\n", $sv->NV; |
| 158 | } |
| 159 | |
| 160 | sub B::PVIV::debug { |
| 161 | my ($sv) = @_; |
| 162 | $sv->B::PV::debug(); |
| 163 | printf "\txiv_iv\t\t%d\n", $sv->IV; |
| 164 | } |
| 165 | |
| 166 | sub B::PVNV::debug { |
| 167 | my ($sv) = @_; |
| 168 | $sv->B::PVIV::debug(); |
| 169 | printf "\txnv_nv\t\t%s\n", $sv->NV; |
| 170 | } |
| 171 | |
| 172 | sub B::PVLV::debug { |
| 173 | my ($sv) = @_; |
| 174 | $sv->B::PVNV::debug(); |
| 175 | printf "\txlv_targoff\t%d\n", $sv->TARGOFF; |
| 176 | printf "\txlv_targlen\t%u\n", $sv->TARGLEN; |
| 177 | printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE)); |
| 178 | } |
| 179 | |
| 180 | sub B::BM::debug { |
| 181 | my ($sv) = @_; |
| 182 | $sv->B::PVNV::debug(); |
| 183 | printf "\txbm_useful\t%d\n", $sv->USEFUL; |
| 184 | printf "\txbm_previous\t%u\n", $sv->PREVIOUS; |
| 185 | printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE)); |
| 186 | } |
| 187 | |
| 188 | sub B::CV::debug { |
| 189 | my ($sv) = @_; |
| 190 | $sv->B::PVNV::debug(); |
| 191 | my ($stash) = $sv->STASH; |
| 192 | my ($start) = $sv->START; |
| 193 | my ($root) = $sv->ROOT; |
| 194 | my ($padlist) = $sv->PADLIST; |
| 195 | my ($file) = $sv->FILE; |
| 196 | my ($gv) = $sv->GV; |
| 197 | printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ; |
| 198 | STASH 0x%x |
| 199 | START 0x%x |
| 200 | ROOT 0x%x |
| 201 | GV 0x%x |
| 202 | FILE %s |
| 203 | DEPTH %d |
| 204 | PADLIST 0x%x |
| 205 | OUTSIDE 0x%x |
| 206 | OUTSIDE_SEQ %d |
| 207 | EOT |
| 208 | $start->debug if $start; |
| 209 | $root->debug if $root; |
| 210 | $gv->debug if $gv; |
| 211 | $padlist->debug if $padlist; |
| 212 | } |
| 213 | |
| 214 | sub B::AV::debug { |
| 215 | my ($av) = @_; |
| 216 | $av->B::SV::debug; |
| 217 | my(@array) = $av->ARRAY; |
| 218 | print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n"; |
| 219 | printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS; |
| 220 | FILL %d |
| 221 | MAX %d |
| 222 | OFF %d |
| 223 | AvFLAGS %d |
| 224 | EOT |
| 225 | } |
| 226 | |
| 227 | sub B::GV::debug { |
| 228 | my ($gv) = @_; |
| 229 | if ($done_gv{$$gv}++) { |
| 230 | printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME; |
| 231 | return; |
| 232 | } |
| 233 | my ($sv) = $gv->SV; |
| 234 | my ($av) = $gv->AV; |
| 235 | my ($cv) = $gv->CV; |
| 236 | $gv->B::SV::debug; |
| 237 | 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; |
| 238 | NAME %s |
| 239 | STASH %s (0x%x) |
| 240 | SV 0x%x |
| 241 | GvREFCNT %d |
| 242 | FORM 0x%x |
| 243 | AV 0x%x |
| 244 | HV 0x%x |
| 245 | EGV 0x%x |
| 246 | CV 0x%x |
| 247 | CVGEN %d |
| 248 | LINE %d |
| 249 | FILE %s |
| 250 | GvFLAGS 0x%x |
| 251 | EOT |
| 252 | $sv->debug if $sv; |
| 253 | $av->debug if $av; |
| 254 | $cv->debug if $cv; |
| 255 | } |
| 256 | |
| 257 | sub B::SPECIAL::debug { |
| 258 | my $sv = shift; |
| 259 | print $specialsv_name[$$sv], "\n"; |
| 260 | } |
| 261 | |
| 262 | sub compile { |
| 263 | my $order = shift; |
| 264 | B::clearsym(); |
| 265 | if ($order && $order eq "exec") { |
| 266 | return sub { walkoptree_exec(main_start, "debug") } |
| 267 | } else { |
| 268 | return sub { walkoptree(main_root, "debug") } |
| 269 | } |
| 270 | } |
| 271 | |
| 272 | 1; |
| 273 | |
| 274 | __END__ |
| 275 | |
| 276 | =head1 NAME |
| 277 | |
| 278 | B::Debug - Walk Perl syntax tree, printing debug info about ops |
| 279 | |
| 280 | =head1 SYNOPSIS |
| 281 | |
| 282 | perl -MO=Debug[,OPTIONS] foo.pl |
| 283 | |
| 284 | =head1 DESCRIPTION |
| 285 | |
| 286 | See F<ext/B/README>. |
| 287 | |
| 288 | =head1 AUTHOR |
| 289 | |
| 290 | Malcolm Beattie, C<mbeattie@sable.ox.ac.uk> |
| 291 | |
| 292 | =cut |