1N/Apackage B::Debug;

1N/A

1N/Aour $VERSION = '1.01';

1N/A

1N/Ause strict;

1N/Ause B qw(peekop class walkoptree walkoptree_exec

1N/A main_start main_root cstring sv_undef);

1N/Ause B::Asmdata qw(@specialsv_name);

1N/A

1N/Amy %done_gv;

1N/A

1N/Asub B::OP::debug {

1N/A my ($op) = @_;

1N/A printf <<'EOT', class($op), $$op, ${$op->next}, ${$op->sibling}, $op->ppaddr, $op->targ, $op->type, $op->seq, $op->flags, $op->private;

1N/A%s (0x%lx)

1N/A op_next 0x%x

1N/A op_sibling 0x%x

1N/A op_ppaddr %s

1N/A op_targ %d

1N/A op_type %d

1N/A op_seq %d

1N/A op_flags %d

1N/A op_private %d

1N/A}

1N/A

1N/Asub B::UNOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::OP::debug();

1N/A printf "\top_first\t0x%x\n", ${$op->first};

1N/A}

1N/A

1N/Asub B::BINOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::UNOP::debug();

1N/A printf "\top_last\t\t0x%x\n", ${$op->last};

1N/A}

1N/A

1N/Asub B::LOOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::BINOP::debug();

1N/A printf <<'EOT', ${$op->redoop}, ${$op->nextop}, ${$op->lastop};

1N/A op_redoop 0x%x

1N/A op_nextop 0x%x

1N/A op_lastop 0x%x

1N/A}

1N/A

1N/Asub B::LOGOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::UNOP::debug();

1N/A printf "\top_other\t0x%x\n", ${$op->other};

1N/A}

1N/A

1N/Asub B::LISTOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::BINOP::debug();

1N/A printf "\top_children\t%d\n", $op->children;

1N/A}

1N/A

1N/Asub B::PMOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::LISTOP::debug();

1N/A printf "\top_pmreplroot\t0x%x\n", ${$op->pmreplroot};

1N/A printf "\top_pmreplstart\t0x%x\n", ${$op->pmreplstart};

1N/A printf "\top_pmnext\t0x%x\n", ${$op->pmnext};

1N/A printf "\top_pmregexp->precomp\t%s\n", cstring($op->precomp);

1N/A printf "\top_pmflags\t0x%x\n", $op->pmflags;

1N/A $op->pmreplroot->debug;

1N/A}

1N/A

1N/Asub B::COP::debug {

1N/A my ($op) = @_;

1N/A $op->B::OP::debug();

1N/A my $cop_io = class($op->io) eq 'SPECIAL' ? '' : $op->io->as_string;

1N/A printf <<'EOT', $op->label, $op->stashpv, $op->file, $op->cop_seq, $op->arybase, $op->line, ${$op->warnings}, cstring($cop_io);

1N/A cop_label %s

1N/A cop_stashpv %s

1N/A cop_file %s

1N/A cop_seq %d

1N/A cop_arybase %d

1N/A cop_line %d

1N/A cop_warnings 0x%x

1N/A cop_io %s

1N/A}

1N/A

1N/Asub B::SVOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::OP::debug();

1N/A printf "\top_sv\t\t0x%x\n", ${$op->sv};

1N/A $op->sv->debug;

1N/A}

1N/A

1N/Asub B::PVOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::OP::debug();

1N/A printf "\top_pv\t\t%s\n", cstring($op->pv);

1N/A}

1N/A

1N/Asub B::PADOP::debug {

1N/A my ($op) = @_;

1N/A $op->B::OP::debug();

1N/A printf "\top_padix\t\t%ld\n", $op->padix;

1N/A}

1N/A

1N/Asub B::NULL::debug {

1N/A my ($sv) = @_;

1N/A if ($$sv == ${sv_undef()}) {

1N/A print "&sv_undef\n";

1N/A } else {

1N/A printf "NULL (0x%x)\n", $$sv;

1N/A }

1N/A}

1N/A

1N/Asub B::SV::debug {

1N/A my ($sv) = @_;

1N/A if (!$$sv) {

1N/A print class($sv), " = NULL\n";

1N/A return;

1N/A }

1N/A printf <<'EOT', class($sv), $$sv, $sv->REFCNT, $sv->FLAGS;

1N/A%s (0x%x)

1N/A REFCNT %d

1N/A FLAGS 0x%x

1N/A}

1N/A

1N/Asub B::RV::debug {

1N/A my ($rv) = @_;

1N/A B::SV::debug($rv);

1N/A printf <<'EOT', ${$rv->RV};

1N/A RV 0x%x

1N/A $rv->RV->debug;

1N/A}

1N/A

1N/Asub B::PV::debug {

1N/A my ($sv) = @_;

1N/A $sv->B::SV::debug();

1N/A my $pv = $sv->PV();

1N/A printf <<'EOT', cstring($pv), length($pv);

1N/A xpv_pv %s

1N/A xpv_cur %d

1N/A}

1N/A

1N/Asub B::IV::debug {

1N/A my ($sv) = @_;

1N/A $sv->B::SV::debug();

1N/A printf "\txiv_iv\t\t%d\n", $sv->IV;

1N/A}

1N/A

1N/Asub B::NV::debug {

1N/A my ($sv) = @_;

1N/A $sv->B::IV::debug();

1N/A printf "\txnv_nv\t\t%s\n", $sv->NV;

1N/A}

1N/A

1N/Asub B::PVIV::debug {

1N/A my ($sv) = @_;

1N/A $sv->B::PV::debug();

1N/A printf "\txiv_iv\t\t%d\n", $sv->IV;

1N/A}

1N/A

1N/Asub B::PVNV::debug {

1N/A my ($sv) = @_;

1N/A $sv->B::PVIV::debug();

1N/A printf "\txnv_nv\t\t%s\n", $sv->NV;

1N/A}

1N/A

1N/Asub B::PVLV::debug {

1N/A my ($sv) = @_;

1N/A $sv->B::PVNV::debug();

1N/A printf "\txlv_targoff\t%d\n", $sv->TARGOFF;

1N/A printf "\txlv_targlen\t%u\n", $sv->TARGLEN;

1N/A printf "\txlv_type\t%s\n", cstring(chr($sv->TYPE));

1N/A}

1N/A

1N/Asub B::BM::debug {

1N/A my ($sv) = @_;

1N/A $sv->B::PVNV::debug();

1N/A printf "\txbm_useful\t%d\n", $sv->USEFUL;

1N/A printf "\txbm_previous\t%u\n", $sv->PREVIOUS;

1N/A printf "\txbm_rare\t%s\n", cstring(chr($sv->RARE));

1N/A}

1N/A

1N/Asub B::CV::debug {

1N/A my ($sv) = @_;

1N/A $sv->B::PVNV::debug();

1N/A my ($stash) = $sv->STASH;

1N/A my ($start) = $sv->START;

1N/A my ($root) = $sv->ROOT;

1N/A my ($padlist) = $sv->PADLIST;

1N/A my ($file) = $sv->FILE;

1N/A my ($gv) = $sv->GV;

1N/A printf <<'EOT', $$stash, $$start, $$root, $$gv, $file, $sv->DEPTH, $padlist, ${$sv->OUTSIDE}, $sv->OUTSIDE_SEQ;

1N/A STASH 0x%x

1N/A START 0x%x

1N/A ROOT 0x%x

1N/A GV 0x%x

1N/A FILE %s

1N/A DEPTH %d

1N/A PADLIST 0x%x

1N/A OUTSIDE 0x%x

1N/A OUTSIDE_SEQ %d

1N/A $start->debug if $start;

1N/A $root->debug if $root;

1N/A $gv->debug if $gv;

1N/A $padlist->debug if $padlist;

1N/A}

1N/A

1N/Asub B::AV::debug {

1N/A my ($av) = @_;

1N/A $av->B::SV::debug;

1N/A my(@array) = $av->ARRAY;

1N/A print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";

1N/A printf <<'EOT', scalar(@array), $av->MAX, $av->OFF, $av->AvFLAGS;

1N/A FILL %d

1N/A MAX %d

1N/A OFF %d

1N/A AvFLAGS %d

1N/A}

1N/A

1N/Asub B::GV::debug {

1N/A my ($gv) = @_;

1N/A if ($done_gv{$$gv}++) {

1N/A printf "GV %s::%s\n", $gv->STASH->NAME, $gv->SAFENAME;

1N/A return;

1N/A }

1N/A my ($sv) = $gv->SV;

1N/A my ($av) = $gv->AV;

1N/A my ($cv) = $gv->CV;

1N/A $gv->B::SV::debug;

1N/A 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;

1N/A NAME %s

1N/A STASH %s (0x%x)

1N/A SV 0x%x

1N/A GvREFCNT %d

1N/A FORM 0x%x

1N/A AV 0x%x

1N/A HV 0x%x

1N/A EGV 0x%x

1N/A CV 0x%x

1N/A CVGEN %d

1N/A LINE %d

1N/A FILE %s

1N/A GvFLAGS 0x%x

1N/A $sv->debug if $sv;

1N/A $av->debug if $av;

1N/A $cv->debug if $cv;

1N/A}

1N/A

1N/Asub B::SPECIAL::debug {

1N/A my $sv = shift;

1N/A print $specialsv_name[$$sv], "\n";

1N/A}

1N/A

1N/Asub compile {

1N/A my $order = shift;

1N/A B::clearsym();

1N/A if ($order && $order eq "exec") {

1N/A return sub { walkoptree_exec(main_start, "debug") }

1N/A } else {

1N/A return sub { walkoptree(main_root, "debug") }

1N/A }

1N/A}

1N/A

1N/A1;

1N/A

1N/A