view release on metacpan or  search on metacpan

os2/B/Concise.pm  view on Meta::CPAN

	    $h{targarglife} = $h{targarg} = "$h{targ} $refs";
	}
    } elsif ($h{targ}) {
	my $padname = (($curcv->PADLIST->ARRAY)[0]->ARRAY)[$h{targ}];
	if (defined $padname and class($padname) ne "SPECIAL") {
	    $h{targarg}  = $padname->PVX;
	    if ($padname->FLAGS & SVf_FAKE) {
		$h{targarglife} = "$h{targarg}:FAKE";
	    }
	    else {
		my $intro = $padname->NVX - $cop_seq_base;
		my $finish = int($padname->IVX) - $cop_seq_base;
		$finish = "end" if $finish == 999999999 - $cop_seq_base;
		$h{targarglife} = "$h{targarg}:$intro,$finish";
	    }
	} else {
	    $h{targarglife} = $h{targarg} = "t" . $h{targ};
	}
    }
    $h{arg} = "";
    $h{svclass} = $h{svaddr} = $h{svval} = "";
    if ($h{class} eq "PMOP") {
	my $precomp = $op->precomp;
	if (defined $precomp) {
	    $precomp = cstring($precomp); # Escape literal control sequences
 	    $precomp = "/$precomp/";
	} else {
	    $precomp = "";
	}
	my $pmreplroot = $op->pmreplroot;
	my $pmreplstart;
	if (ref($pmreplroot) eq "B::GV") {
	    # with C<@stash_array = split(/pat/, str);>,
	    #  *stash_array is stored in /pat/'s pmreplroot.
	    $h{arg} = "($precomp => \@" . $pmreplroot->NAME . ")";
	} elsif (!ref($pmreplroot) and $pmreplroot) {
	    # same as the last case, except the value is actually a
	    # pad offset for where the GV is kept (this happens under
	    # ithreads)
	    my $gv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$pmreplroot];
	    $h{arg} = "($precomp => \@" . $gv->NAME . ")";
	} elsif ($ {$op->pmreplstart}) {
	    undef $lastnext;
	    $pmreplstart = "replstart->" . seq($op->pmreplstart);
	    $h{arg} = "(" . join(" ", $precomp, $pmreplstart) . ")";
	} else {
	    $h{arg} = "($precomp)";
	}
    } elsif ($h{class} eq "PVOP" and $h{name} ne "trans") {
	$h{arg} = '("' . $op->pv . '")';
	$h{svval} = '"' . $op->pv . '"';
    } elsif ($h{class} eq "COP") {
	my $label = $op->label;
	$h{coplabel} = $label;
	$label = $label ? "$label: " : "";
	my $loc = $op->file;
	$loc =~ s[.*/][];
	$loc .= ":" . $op->line;
	my($stash, $cseq) = ($op->stash->NAME, $op->cop_seq - $cop_seq_base);
	my $arybase = $op->arybase;
	$arybase = $arybase ? ' $[=' . $arybase : "";
	$h{arg} = "($label$stash $cseq $loc$arybase)";
    } elsif ($h{class} eq "LOOP") {
	$h{arg} = "(next->" . seq($op->nextop) . " last->" . seq($op->lastop)
	  . " redo->" . seq($op->redoop) . ")";
    } elsif ($h{class} eq "LOGOP") {
	undef $lastnext;
	$h{arg} = "(other->" . seq($op->other) . ")";
    } elsif ($h{class} eq "SVOP") {
	if (! ${$op->sv}) {
	    my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->targ];
	    $h{arg} = "[" . concise_sv($sv, \%h) . "]";
	    $h{targarglife} = $h{targarg} = "";
	} else {
	    $h{arg} = "(" . concise_sv($op->sv, \%h) . ")";
	}
    } elsif ($h{class} eq "PADOP") {
	my $sv = (($curcv->PADLIST->ARRAY)[1]->ARRAY)[$op->padix];
	$h{arg} = "[" . concise_sv($sv, \%h) . "]";
    }
    $h{seq} = $h{hyphseq} = seq($op);
    $h{seq} = "" if $h{seq} eq "-";
    $h{seqnum} = $op->seq;
    $h{next} = $op->next;
    $h{next} = (class($h{next}) eq "NULL") ? "(end)" : seq($h{next});
    $h{nextaddr} = sprintf("%#x", $ {$op->next});
    $h{sibaddr} = sprintf("%#x", $ {$op->sibling});
    $h{firstaddr} = sprintf("%#x", $ {$op->first}) if $op->can("first");
    $h{lastaddr} = sprintf("%#x", $ {$op->last}) if $op->can("last");

    $h{classsym} = $opclass{$h{class}};
    $h{flagval} = $op->flags;
    $h{flags} = op_flags($op->flags);
    $h{privval} = $op->private;
    $h{private} = private_flags($h{name}, $op->private);
    $h{addr} = sprintf("%#x", $$op);
    $h{label} = $labels{$op->seq};
    $h{typenum} = $op->type;
    $h{noise} = $linenoise[$op->type];
    $_->(\%h, $op, \$format, \$level) for @callbacks;
    return fmt_line(\%h, $format, $level);
}

sub B::OP::concise {
    my($op, $level) = @_;
    if ($order eq "exec" and $lastnext and $$lastnext != $$op) {
	my $h = {"seq" => seq($lastnext), "class" => class($lastnext),
		 "addr" => sprintf("%#x", $$lastnext)};
	print fmt_line($h, $gotofmt, $level+1);
    }
    $lastnext = $op->next;
    print concise_op($op, $level, $format);
}

# B::OP::terse (see Terse.pm) now just calls this
sub b_terse {
    my($op, $level) = @_;

    # This isn't necessarily right, but there's no easy way to get
    # from an OP to the right CV. This is a limitation of the
    # ->terse() interface style, and there isn't much to do about