<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package B::Debug;
use strict;
use B qw(peekop class walkoptree walkoptree_exec
         main_start main_root cstring sv_undef);
use B::Asmdata qw(@specialsv_name);

my %done_gv;

sub B::OP::debug {
    my ($op) = @_;
    printf &lt;&lt;'EOT', class($op), $$op, ${$op-&gt;next}, ${$op-&gt;sibling}, $op-&gt;ppaddr, $op-&gt;targ, $op-&gt;type, $op-&gt;seq, $op-&gt;flags, $op-&gt;private;
%s (0x%lx)
	op_next		0x%x
	op_sibling	0x%x
	op_ppaddr	%s
	op_targ		%d
	op_type		%d
	op_seq		%d
	op_flags	%d
	op_private	%d
EOT
}

sub B::UNOP::debug {
    my ($op) = @_;
    $op-&gt;B::OP::debug();
    printf "\top_first\t0x%x\n", ${$op-&gt;first};
}

sub B::BINOP::debug {
    my ($op) = @_;
    $op-&gt;B::UNOP::debug();
    printf "\top_last\t\t0x%x\n", ${$op-&gt;last};
}

sub B::LOOP::debug {
    my ($op) = @_;
    $op-&gt;B::BINOP::debug();
    printf &lt;&lt;'EOT', ${$op-&gt;redoop}, ${$op-&gt;nextop}, ${$op-&gt;lastop};
       op_redoop       0x%x
       op_nextop       0x%x
       op_lastop       0x%x
EOT
}

sub B::LOGOP::debug {
    my ($op) = @_;
    $op-&gt;B::UNOP::debug();
    printf "\top_other\t0x%x\n", ${$op-&gt;other};
}

sub B::LISTOP::debug {
    my ($op) = @_;
    $op-&gt;B::BINOP::debug();
    printf "\top_children\t%d\n", $op-&gt;children;
}

sub B::PMOP::debug {
    my ($op) = @_;
    $op-&gt;B::LISTOP::debug();
    printf "\top_pmreplroot\t0x%x\n", ${$op-&gt;pmreplroot};
    printf "\top_pmreplstart\t0x%x\n", ${$op-&gt;pmreplstart};
    printf "\top_pmnext\t0x%x\n", ${$op-&gt;pmnext};
    printf "\top_pmregexp-&gt;precomp\t%s\n", cstring($op-&gt;precomp);
    printf "\top_pmflags\t0x%x\n", $op-&gt;pmflags;
    $op-&gt;pmreplroot-&gt;debug;
}

sub B::COP::debug {
    my ($op) = @_;
    $op-&gt;B::OP::debug();
    printf &lt;&lt;'EOT', $op-&gt;label, $op-&gt;stashpv, $op-&gt;file, $op-&gt;seq, $op-&gt;arybase, $op-&gt;line, ${$op-&gt;warnings};
	cop_label	%s
	cop_stashpv	%s
	cop_file	%s
	cop_seq		%d
	cop_arybase	%d
	cop_line	%d
	cop_warnings	0x%x
EOT
}

sub B::SVOP::debug {
    my ($op) = @_;
    $op-&gt;B::OP::debug();
    printf "\top_sv\t\t0x%x\n", ${$op-&gt;sv};
    $op-&gt;sv-&gt;debug;
}

sub B::PVOP::debug {
    my ($op) = @_;
    $op-&gt;B::OP::debug();
    printf "\top_pv\t\t0x%x\n", $op-&gt;pv;
}

sub B::PADOP::debug {
    my ($op) = @_;
    $op-&gt;B::OP::debug();
    printf "\top_padix\t\t%ld\n", $op-&gt;padix;
}

sub B::CVOP::debug {
    my ($op) = @_;
    $op-&gt;B::OP::debug();
    printf "\top_cv\t\t0x%x\n", ${$op-&gt;cv};
}

sub B::NULL::debug {
    my ($sv) = @_;
    if ($$sv == ${sv_undef()}) {
	print "&amp;sv_undef\n";
    } else {
	printf "NULL (0x%x)\n", $$sv;
    }
}

sub B::SV::debug {
    my ($sv) = @_;
    if (!$$sv) {
	print class($sv), " = NULL\n";
	return;
    }
    printf &lt;&lt;'EOT', class($sv), $$sv, $sv-&gt;REFCNT, $sv-&gt;FLAGS;
%s (0x%x)
	REFCNT		%d
	FLAGS		0x%x
EOT
}

sub B::PV::debug {
    my ($sv) = @_;
    $sv-&gt;B::SV::debug();
    my $pv = $sv-&gt;PV();
    printf &lt;&lt;'EOT', cstring($pv), length($pv);
	xpv_pv		%s
	xpv_cur		%d
EOT
}

sub B::IV::debug {
    my ($sv) = @_;
    $sv-&gt;B::SV::debug();
    printf "\txiv_iv\t\t%d\n", $sv-&gt;IV;
}

sub B::NV::debug {
    my ($sv) = @_;
    $sv-&gt;B::IV::debug();
    printf "\txnv_nv\t\t%s\n", $sv-&gt;NV;
}

sub B::PVIV::debug {
    my ($sv) = @_;
    $sv-&gt;B::PV::debug();
    printf "\txiv_iv\t\t%d\n", $sv-&gt;IV;
}

sub B::PVNV::debug {
    my ($sv) = @_;
    $sv-&gt;B::PVIV::debug();
    printf "\txnv_nv\t\t%s\n", $sv-&gt;NV;
}

sub B::PVLV::debug {
    my ($sv) = @_;
    $sv-&gt;B::PVNV::debug();
    printf "\txlv_targoff\t%d\n", $sv-&gt;TARGOFF;
    printf "\txlv_targlen\t%u\n", $sv-&gt;TARGLEN;
    printf "\txlv_type\t%s\n", cstring(chr($sv-&gt;TYPE));
}

sub B::BM::debug {
    my ($sv) = @_;
    $sv-&gt;B::PVNV::debug();
    printf "\txbm_useful\t%d\n", $sv-&gt;USEFUL;
    printf "\txbm_previous\t%u\n", $sv-&gt;PREVIOUS;
    printf "\txbm_rare\t%s\n", cstring(chr($sv-&gt;RARE));
}

sub B::CV::debug {
    my ($sv) = @_;
    $sv-&gt;B::PVNV::debug();
    my ($stash) = $sv-&gt;STASH;
    my ($start) = $sv-&gt;START;
    my ($root) = $sv-&gt;ROOT;
    my ($padlist) = $sv-&gt;PADLIST;
    my ($file) = $sv-&gt;FILE;
    my ($gv) = $sv-&gt;GV;
    printf &lt;&lt;'EOT', $$stash, $$start, $$root, $$gv, $file, $sv-&gt;DEPTH, $padlist, ${$sv-&gt;OUTSIDE};
	STASH		0x%x
	START		0x%x
	ROOT		0x%x
	GV		0x%x
	FILE		%s
	DEPTH		%d
	PADLIST		0x%x			       
	OUTSIDE		0x%x
EOT
    $start-&gt;debug if $start;
    $root-&gt;debug if $root;
    $gv-&gt;debug if $gv;
    $padlist-&gt;debug if $padlist;
}

sub B::AV::debug {
    my ($av) = @_;
    $av-&gt;B::SV::debug;
    my(@array) = $av-&gt;ARRAY;
    print "\tARRAY\t\t(", join(", ", map("0x" . $$_, @array)), ")\n";
    printf &lt;&lt;'EOT', scalar(@array), $av-&gt;MAX, $av-&gt;OFF, $av-&gt;AvFLAGS;
	FILL		%d    
	MAX		%d
	OFF		%d
	AvFLAGS		%d
EOT
}
    
sub B::GV::debug {
    my ($gv) = @_;
    if ($done_gv{$$gv}++) {
	printf "GV %s::%s\n", $gv-&gt;STASH-&gt;NAME, $gv-&gt;SAFENAME;
	return;
    }
    my ($sv) = $gv-&gt;SV;
    my ($av) = $gv-&gt;AV;
    my ($cv) = $gv-&gt;CV;
    $gv-&gt;B::SV::debug;
    printf &lt;&lt;'EOT', $gv-&gt;SAFENAME, $gv-&gt;STASH-&gt;NAME, $gv-&gt;STASH, $$sv, $gv-&gt;GvREFCNT, $gv-&gt;FORM, $$av, ${$gv-&gt;HV}, ${$gv-&gt;EGV}, $$cv, $gv-&gt;CVGEN, $gv-&gt;LINE, $gv-&gt;FILE, $gv-&gt;GvFLAGS;
	NAME		%s
	STASH		%s (0x%x)
	SV		0x%x
	GvREFCNT	%d
	FORM		0x%x
	AV		0x%x
	HV		0x%x
	EGV		0x%x
	CV		0x%x
	CVGEN		%d
	LINE		%d
	FILE		%s
	GvFLAGS		0x%x
EOT
    $sv-&gt;debug if $sv;
    $av-&gt;debug if $av;
    $cv-&gt;debug if $cv;
}

sub B::SPECIAL::debug {
    my $sv = shift;
    print $specialsv_name[$$sv], "\n";
}

sub compile {
    my $order = shift;
    B::clearsym();
    if ($order &amp;&amp; $order eq "exec") {
        return sub { walkoptree_exec(main_start, "debug") }
    } else {
        return sub { walkoptree(main_root, "debug") }
    }
}

1;

__END__

=head1 NAME

B::Debug - Walk Perl syntax tree, printing debug info about ops

=head1 SYNOPSIS

	perl -MO=Debug[,OPTIONS] foo.pl

=head1 DESCRIPTION

See F&lt;ext/B/README&gt;.

=head1 AUTHOR

Malcolm Beattie, C&lt;mbeattie@sable.ox.ac.uk&gt;

=cut
</pre></body></html>