up patchlevel to 75 (Beta, Issue 1), add podpatch

[perl5.git] / ext / B / B / Terse.pm

package B::Terse;
use strict;
use B qw(peekop class walkoptree_slow walkoptree_exec
	 main_start main_root cstring svref_2object);
use B::Asmdata qw(@specialsv_name);

sub terse {
    my ($order, $cvref) = @_;
    my $cv = svref_2object($cvref);
    if ($order eq "exec") {
	walkoptree_exec($cv->START, "terse");
    } else {
	walkoptree_slow($cv->ROOT, "terse");
    }
}

sub compile {
    my $order = shift;
    my @options = @_;
    if (@options) {
	return sub {
	    my $objname;
	    foreach $objname (@options) {
		$objname = "main::$objname" unless $objname =~ /::/;
		eval "terse(\$order, \\&$objname)";
		die "terse($order, \\&$objname) failed: $@" if $@;
	    }
	}
    } else {
	if ($order eq "exec") {
	    return sub { walkoptree_exec(main_start, "terse") }
	} else {
	    return sub { walkoptree_slow(main_root, "terse") }
	}
    }
}

sub indent {
    my $level = shift;
    return "    " x $level;
}

sub B::OP::terse {
    my ($op, $level) = @_;
    my $targ = $op->targ;
    $targ = ($targ > 0) ? " [$targ]" : "";
    print indent($level), peekop($op), $targ, "\n";
}

sub B::SVOP::terse {
    my ($op, $level) = @_;
    print indent($level), peekop($op), "  ";
    $op->sv->terse(0);
}

sub B::GVOP::terse {
    my ($op, $level) = @_;
    print indent($level), peekop($op), "  ";
    $op->gv->terse(0);
}

sub B::PMOP::terse {
    my ($op, $level) = @_;
    my $precomp = $op->precomp;
    print indent($level), peekop($op),
	defined($precomp) ? " /$precomp/\n" : " (regexp not compiled)\n";

}

sub B::PVOP::terse {
    my ($op, $level) = @_;
    print indent($level), peekop($op), " ", cstring($op->pv), "\n";
}

sub B::COP::terse {
    my ($op, $level) = @_;
    my $label = $op->label;
    if ($label) {
	$label = " label ".cstring($label);
    }
    print indent($level), peekop($op), $label, "\n";
}

sub B::PV::terse {
    my ($sv, $level) = @_;
    print indent($level);
    printf "%s (0x%lx) %s\n", class($sv), $$sv, cstring($sv->PV);
}

sub B::AV::terse {
    my ($sv, $level) = @_;
    print indent($level);
    printf "%s (0x%lx) FILL %d\n", class($sv), $$sv, $sv->FILL;
}

sub B::GV::terse {
    my ($gv, $level) = @_;
    my $stash = $gv->STASH->NAME;
    if ($stash eq "main") {
	$stash = "";
    } else {
	$stash = $stash . "::";
    }
    print indent($level);
    printf "%s (0x%lx) *%s%s\n", class($gv), $$gv, $stash, $gv->NAME;
}

sub B::IV::terse {
    my ($sv, $level) = @_;
    print indent($level);
    printf "%s (0x%lx) %d\n", class($sv), $$sv, $sv->IV;
}

sub B::NV::terse {
    my ($sv, $level) = @_;
    print indent($level);
    printf "%s (0x%lx) %s\n", class($sv), $$sv, $sv->NV;
}

sub B::NULL::terse {
    my ($sv, $level) = @_;
    print indent($level);
    printf "%s (0x%lx)\n", class($sv), $$sv;
}
    
sub B::SPECIAL::terse {
    my ($sv, $level) = @_;
    print indent($level);
    printf "%s #%d %s\n", class($sv), $$sv, $specialsv_name[$$sv];
}

1;