File Coverage

blib/lib/B/Graph.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

# B/Graph.pm
# Copyright (C) 1997, 1998, 2000 Stephen McCamant. All rights reserved.
# This program is free software; you can redistribute and/or modifiy it
# under the same terms as Perl itself.
package B::Graph;
$VERSION = "0.51";

use 5.004; # Some 5.003_??s might work; most recently tested w/5.005
use B qw(class main_start main_root main_cv sv_undef svref_2object ppname);
use B::Asmdata qw(@specialsv_name);

use strict;

my %nodes; # addr => have we printed it?
my @edges; # [from => to, line, type]
my @todo; # nodes to print
my($addrs, $type, $style, $sv_shape, $dump_svs, $dump_stashes, $filegvs,
   $seqs, $types, $float, $targlinks);
use vars '@padnames'; # should be my(), but I want to use local() on it

sub ad {
    return $ {$_[0]};
}

sub max {
    my($m) = $_[0];
    my $x;
    for $x (@_) {
	$m = $x if $x > $m;
    }
    return $m;
}

sub proclaim_node {
    return unless @_;
    if ($type eq "vcg") {
	my(@lines) = ();
	my($title, $shape, $color);
	for my $l (@_) {
	    my(@l) = @$l;
	    if ($l[0] eq "title") {
		$title = $l[1];
	    } elsif ($l[0] eq "color") {
		$color = ('white', 'lightgrey', 'lightblue', 'lightred',
		   'lightgreen', 'lightyellow', 'orange', 'cyan',
		   'lightmagenta', 'yellow', 'green', 'aquamarine',
		   'khaki')[$l[1]];
	    } elsif ($l[0] eq "shape") {
		$shape = $l[1];
	    } elsif ($l[0] eq "text") {
		push @lines, $l[1];
	    } elsif ($l[0] eq "link") {
		$l[3] = 0 unless defined $l[3];
		if ($l[2]) {
		    unless ($float and $l[3] == 1 || $l[3] == 2) {
			if ($addrs) {
			    push @lines, "$l[1]: " . sprintf("%x", $l[2]);
			} else {
			    push @lines, "$l[1]";
			}
		    }
		    push @edges, [$title, $l[2], scalar(@lines), $l[3]]
			unless @lines > 55;
		}
	    } elsif ($l[0] eq "val") {
		push @lines, "$l[1]: $l[2]" if $l[2];
	    } elsif ($l[0] eq "sval") {
		my($v) = $l[2];
		if (defined $v) {
		    $v =~ s/([\x00-\x1f\"\x80-\xff])/
		            "\\\\x" . sprintf("%x", ord($1))/eg;
		    $v = substr($v,0,10) . "..." . substr($v, -10)
			if length $v > 23;
		    push @lines, qq/$l[1]: '$v'/;
		} else {
		    push @lines, "$l[1]: undef";
		}
	    } else {
		die "unknown node info type: $l[0] (@_)!\n";
	    }
	}

	print "node: { ";
	print qq'title: "$title" ';
	print qq'color: $color ' if $color;
	print qq'shape: $shape ' if $shape;
	print qq'label: "', join("\n", @lines), '"';
	print "}\n\n";
    } elsif ($type eq "dot") {
	my(@lines) = ();
	my($title, $shape, $color);
	for my $l (@_) {
	    my(@l) = @$l;
	    if ($l[0] eq "title") {
		$title = $l[1];
	    } elsif ($l[0] eq "color") {
		$color = ('black', 'gray50', 'navyblue', 'red',
		   'darkgreen', 'brown', 'magenta4',
		   'blue', 'dodgerblue', 'orange', 'darkgreen', 'blue',
		   'khaki4')[$l[1]];
	    } elsif ($l[0] eq "shape") {
	    } elsif ($l[0] eq "text") {
		push @lines, $l[1];
	    } elsif ($l[0] eq "link") {
		$l[3] = 0 unless defined $l[3];
		if ($l[2]) {
		    unless ($float and $l[3] == 1 || $l[3] == 2) {
			if ($addrs) {
			    push @lines, "$l[1]: " . sprintf("%x", $l[2]);
			} else {
			    push @lines, "$l[1]";
			}
		    }
		    push @edges, [$title, $l[2], scalar(@lines), $l[3]];
		}
	    } elsif ($l[0] eq "val") {
		push @lines, "$l[1]: $l[2]" if $l[2];
	    } elsif ($l[0] eq "sval") {
		my($v) = $l[2];
		if (defined $v) {
		    $v =~ s/([\x00-\x1f\"\x80-\xff<>])/
		            "\\\\x" . sprintf("%x", ord($1))/eg;
		    $v = substr($v,0,10) . "..." . substr($v, -10)
			if length $v > 23;
		    push @lines, qq/$l[1]: '$v'/;
		} else {
		    push @lines, "$l[1]: undef";
		}
	    } else {
		die "unknown node info type: $l[0] (@_)!\n";
	    }
	}
	for my $i (1 .. $#lines) {
	    $lines[$i] = "" . $lines[$i];
	}
	print "n$title [";
	print qq'color=$color,' if $color;
	print qq'label="', join("|", @lines), '"';
	print "];\n";
    } elsif ($type eq "text") {
	my(@lines) = ();
#	print "@_\n";
	my($title);
	for my $l (@_) {
	    my(@l) = @$l;
	    if ($l[0] eq "title") {
		$title = $l[1];
	    } elsif ($l[0] eq "text") {
		push @lines, $l[1];
	    } elsif ($l[0] eq "link") {
		if ($l[1] and $l[2] and defined($l[3])) {
		    push @lines, "$l[1] -> $l[2] ($l[3])";
		    push @edges, [$title, $l[2], scalar(@lines), $l[3]];
		}
	    } elsif ($l[0] eq "val") {
		push @lines, "$l[1]: $l[2]" if $l[2];
	    } elsif ($l[0] eq "sval") {
		my($v) = $l[2];
		if (defined $v) {
		    $v =~ s/([\x00-\x1f\"\x80-\xff])/
		            "\\\\x" . sprintf("%x", ord($1))/eg;
		    $v = substr($v,0,10) . "..." . substr($v, -10)
			if length $v > 23;
		    push @lines, qq/$l[1]: '$v'/;
		} else {
		    push @lines, "$l[1]: undef";
		}
	    } elsif ($l[0] eq "color" or $l[0] eq "shape") {
	    } else {
		die "unknown node info type: $l[0] (@_)!\n";
	    }
	}
	my($m) = max(map(length $_, @lines));
	my($l);
	for $l (@lines) {
	    $l = "|" . $l . (" " x ($m - length($l))) . "|";
	}
	unshift @lines, "-" x ($m + 2);
#	substr($lines[0], ($m + 2 - length $title)/2,
#	       length $title) = $title;
	print join("\n", @lines), "\n", "-" x ($m + 2), "\n\n";
    }
}

sub proclaim_edge {
    my $anchor = !($float and $_[3] == 1 || $_[3] == 2);
    if ($type eq "vcg") {
	print 'edge: { sourcename: "', $_[0], '"',
	      ' targetname: "', $_[1], '"',
	      ($anchor ? (' anchor: ', $_[2] || 1) : ()),
	      [[" priority: 5 class: 1",
		" priority: 0 color: cyan class: 2",
		" priority: 0 color: pink class: 3",
		" priority: 5 color: lightgrey class: 4",
	        " priority: 0 color: lightred class: 5"],
	       [" priority: 0 color: lightgrey class: 1",
		" priority: 0 color: cyan class: 2",
		" priority: 10 color: magenta thickness: 8 arrowsize: 20"
		. " class: 3",
		" priority: 0 color: lightgrey class: 4",
	        " priority: 0 color: red thickness: 8 arrowsize: 20"
		. " class: 5"]]->
		    [$style][$_[3] || 0],
	      qq'}\n';
    } elsif ($type eq "dot") {
	print 'n', $_[0], (($anchor && $_[2]) ? ':p' . $_[2] : ""),
	      ' -> n', $_[1], " ",
	      [["[weight=5]",
		"[constraint=false,color=cyan]",
		"[constraint=false,color=pink]",
		"[weight=5,color=lightgrey]",
	        "[constraint=false,color=red]"],
	       ["[color=lightgrey]",
		"[color=cyan]",
		"[weight=10,color=magenta,style=bold]",
		"[color=lightgrey]",
	        "[weight=10,color=red,style=bold]"]
	       ]->[$style][$_[3] || 0], ";\n";
    } elsif ($type eq "text") {
	print "$_[0].$_[2] -> $_[1] ($_[3])\n";
    }

}

sub node {
    push @todo, [@_];
}

sub op_flags {
    my($x) = @_;
    my(@v);
    push @v, "V" if ($x & 3) == 1;
    push @v, "S" if ($x & 3) == 2;
    push @v, "L" if ($x & 3) == 3;
    push @v, "K" if $x & 4;
    push @v, "P" if $x & 8;
    push @v, "R" if $x & 16;
    push @v, "M" if $x & 32;
    push @v, "T" if $x & 64;
    push @v, "*" if $x & 128;
    return join("", @v);
}

sub op_common {
    my($op) = @_;
    if ($style) {
	node($op->next->graph) if ad($op->next);
    } else {
	if ($op->flags & 4 and class($op) ne "OP") { # OPf_KIDS
	    my $kid;
	    for ($kid = $op->first; $$kid; $kid = $kid->sibling) {
		node($kid->graph);
	    }
	}
    }
    my($n) = substr(ppname($op->type), 3);
    my($null) = $n eq "null";
    my(@targ);
    if ($null or !$op->targ) {
	@targ = ();
    } elsif ($op->targ) {
	if ($targlinks and $padnames[$op->targ]) {
	    @targ = ['link', 'targ', $padnames[$op->targ], 3];
	} else {
	    @targ = ['val', 'targ', $op->targ];
	}
    }
    return (
	    ['title' => $$op],
	    ['color' => {'OP' => 0, 'UNOP' => 1, 'BINOP' => 2,
			 'LOGOP' => 3, 'CONDOP' => 4, 'LISTOP' => 5,
			 'PMOP' => 6, 'COP' => 7, 'SVOP' => 8,
			 'PVOP' => 9, 'GVOP' => 10,
			 'LOOP' => 12}->{class($op)} || 0],
	    ['text', join("", $n, " (", class($op), ")")],
	    ($null ? ['text', " was " . substr(ppname($op->targ), 3)] : ()),
	    ($addrs ? ['text', sprintf("%x", $$op)] : ()),
	    ($types ? ['val', "type", $op->type] : ()),
	    ['sval', "flags", op_flags($op->flags)],
	    ['link', "next", ad($op->next), 2 + 3*($n eq "cond_expr")],
	    ['link', "sibling", ad($op->sibling), 1],
	    @targ,
	    ($seqs ? ['val', "seq", $op->seq] : ()),
	    ['val', "private", $op->private],
	    );
}

sub B::OP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    return op_common($op);
}

sub B::UNOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my(@l) = op_common($op);
    push @l, ['link', "first", ad($op->first), 0];
    if (ad($op->first) and ad($op->first->sibling)) {
	my($kid) = $op->first->sibling;
	while ($$kid) {
	    push @l, ['link', "(stepchild)", $$kid, 3];
	    $kid = $kid->sibling;
	}
    }
    return @l;
}

sub B::BINOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    return (op_common($op),
	    ['link', "first", ad($op->first), 0],
	    ['link', "last", ad($op->last), 0],
	    );
}

sub B::LOGOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my(@l) = op_common($op);
    push @l, ['link', "first", ad($op->first), 0];
    if (ad($op->first) and ad($op->first->sibling)) {
	my($kid) = $op->first->sibling;
	while ($$kid) {
	    push @l, ['link', "(child)", $$kid, 3];
	    $kid = $kid->sibling;
	}
    }
    node($op->other->graph) if $style;
    push @l, ['link', "other", ad($op->other), 4];
    return @l;
}

sub B::CONDOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my(@l) = op_common($op);
    if ($style) {
	node($op->true->graph);
	node($op->false->graph);
    }
    push @l, ['link', "first", ad($op->first), 0];
    if (ad($op->first)) {
	my($kid) = $op->first->sibling;
	while (class($kid) ne "NULL") {
	    push @l, ['link', "(child)", $$kid, 3];
	    $kid = $kid->sibling;
	}
    }
    push @l, (['link', "true", ad($op->true), 4],
	      ['link', "false", ad($op->false), 4],
	     );
    return @l;
}

sub B::LISTOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my(@l) = op_common($op);
    push @l, ['link', "first", ad($op->first), 0];
    push @l, ['val', "children", $op->children];
    if (ad($op->first)) {
	my($kid) = $op->first->sibling;
	while (class($kid) ne "NULL" and ad($kid->sibling)) {
	    push @l, ['link', "(child)", $$kid, 3];
	    $kid = $kid->sibling;
	}
    }
    push @l, ['link', "last", ad($op->last), 0];
    return @l;
}

sub B::LOOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my(@l) = op_common($op);
    push @l, ['link', "first", ad($op->first), 0];
    push @l, ['val', "children", $op->children];
    if (ad($op->first)) {
	my($kid) = $op->first->sibling;
	while (class($kid) ne "NULL" and ad($kid->sibling)) {
	    push @l, ['link', "(child)", $$kid, 3];
	    $kid = $kid->sibling;
	}
    }
    push @l, (['link', "last", ad($op->last), 0],
	      ['link', "lastop", ad($op->lastop), 4],
	      ['link', "redoop", ad($op->redoop), 4],
	      ['link', "nextop", ad($op->nextop), 4],
	      );
    node($op->redoop->graph);
    node($op->nextop->graph);
    node($op->lastop->graph);
    return @l;
}


sub B::PMOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my(@l) = (op_common($op),
	      ['link', "first", ad($op->first), 0],
	      ['link', "last", ad($op->last), 0],
	      ['val', "children", $op->children],
	      ['link', "pmreplroot", ad($op->pmreplroot), 0],
	      ['link', "pmreplstart", ad($op->pmreplstart), 4],
	      ['link', "pmnext", ad($op->pmnext), 0],
	      ['sval', "precomp", $op->precomp],
	      ['val', "pmflags", $op->pmflags],
	      );
    if ($style) {
	node($op->pmreplstart->graph);
    } else {
	node($op->pmreplroot->graph);
    }
    return @l;
}

sub B::COP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my $filegv;
    $filegv = $op->filegv if $filegvs;
    my(@l) = (op_common($op),
	      ['val', "label", $op->label],
	      ($dump_stashes ? ['link', "stash", ad($op->stash), 0] : ()),
	      ($filegvs ? ['link', "filegv", $$filegv, 0] : ()),
	      ['val', "cop_seq", $op->cop_seq],
	      ['val', "arybase", $op->arybase],
	      ['val', "line", $op->line],
	      );
    node($filegv->graph) if $filegvs;
    return @l;
}

sub B::SVOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my(@l) = (op_common($op),
	      ['link', "sv", ad($op->sv), 0],
	      );
    node($op->sv->graph);
    return @l;
}

sub B::PVOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    return (op_common($op),
	    ['sval', 'pv', $op->pv],
	    );
}

sub B::GVOP::graph {
    my ($op) = @_;
    return if $nodes{$$op}++;
    my(@l) = (op_common($op),
	      ['link', "gv", ad($op->gv), 0],
	      );
    node($op->gv->graph);
    return @l;
}

sub sv_flags {
    my($x) = @_;
    my(@v);
    push @v, "Pb" if $x & 0x100;
    push @v, "Pt" if $x & 0x200;
    push @v, "Pm" if $x & 0x400;
    push @v, "T" if $x & 0x800;
    push @v, "O" if $x & 0x1000;
    push @v, "Mg" if $x & 0x2000;
    push @v, "Ms" if $x & 0x4000;
    push @v, "Mr" if $x & 0x8000;
    push @v, "I" if $x & 0x10000;
    push @v, "N" if $x & 0x20000;
    push @v, "P" if $x & 0x40000;
    push @v, "R" if $x & 0x80000;
    push @v, "F" if $x & 0x100000;
    push @v, "L" if $x & 0x200000;
    push @v, "B" if $x & 0x400000;
    push @v, "Ro" if $x & 0x800000;
    push @v, "i" if $x & 0x1000000;
    push @v, "n" if $x & 0x2000000;
    push @v, "p" if $x & 0x4000000;
    push @v, "S" if $x & 0x8000000;
    push @v, "V" if $x & 0x10000000;
    return join("", @v);
}

sub sv_magic {
    my($sv) = @_;
    my(@l) = ();
    foreach my $mg ($sv->MAGIC) {
	push @l, (['text', 'MAGIC'],
		  ['sval', ' TYPE', $mg->TYPE],
		  ['val', ' PRIVATE', $mg->PRIVATE],
		  ['val', ' FLAGS', $mg->FLAGS],
		  ['link', ' OBJ', ad($mg->OBJ)],
		  );
	push @l, ['sval', ' PTR', $mg->PTR] unless $mg->TYPE eq "s";
	node($mg->OBJ->graph);
    }
    return @l;
}

sub sv_common {
    my($sv) = @_;
    my(@l);
    @l = (['shape', $sv_shape],
	  ['title', $$sv],
	  ['color', {'SV' => 0, 'PV' => 1, 'IV' => 2, 'NV' => 3,
		     'RV' => 4, 'PVIV' => 5, 'PVNV' => 6, 'AV' => 7,
		     'HV' => 8, 'GV' => 9, 'CV' => 10, 'BM' => 11,
		     'PVLV' => 12, 'PVMG' => 6, 'IO' => 5}
	   ->{class($sv)} || 0],
	  ['text', class($sv) . ($addrs ? " " . sprintf("%x",$$sv) : "")],
	  ['val', 'REFCNT', $sv->REFCNT],
	  ['sval', 'FLAGS', sv_flags($sv->FLAGS)],
	  );
    push @l, sv_magic($sv) if ($sv->FLAGS & 0xff) >= 7;
    return @l;
}

sub B::SV::graph {
    my ($sv) = @_;
    return unless $$sv;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return sv_common($sv);
}

sub B::RV::graph {
    my($sv) = @_;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    node($sv->RV->graph);
    return (sv_common($sv),
	    ['link', 'RV', ad($sv->RV), 0],
	    );
}

sub pv_common {
    my($sv) = @_;
    my(@l) = sv_common($sv);
    my($pv) = $sv->PV;
    if (defined $pv) {
	push @l, ['sval', 'PVX', $pv];
	push @l, ['val', 'CUR', length($pv)];
    }
    return @l;
}

sub B::PV::graph {
    my ($sv) = @_;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return pv_common($sv);
}

sub B::IV::graph {
    my ($sv) = @_;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return (sv_common($sv), ['val', 'IVX', $sv->IVX]);
}

sub B::NV::graph {
    my ($sv) = @_;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return (sv_common($sv),
	    ['val', 'IVX', $sv->IVX],
	    ['val', 'NVX', $sv->NVX],
	    );
}

sub B::PVIV::graph {
    my ($sv) = @_;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return (pv_common($sv), ['val', 'IVX', $sv->IVX]);
}

sub pvnv_common
{
    my($sv) = @_;
    return (pv_common($sv),
	    ['val', 'IVX', $sv->IVX],
	    ['val', 'NVX', $sv->NVX],
	    );
}

sub B::PVNV::graph {
    my ($sv) = @_;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return pvnv_common($sv);
}

sub B::PVLV::graph {
    my ($sv) = @_;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return (pvnv_common($sv),
	    ['val', 'LvTARGOFF', $sv->TARGOFF],
	    ['val', 'LvTARGLEN', $sv->TARGLEN],
	    ['sval', 'LvTYPE', chr($sv->TYPE)],
	    );
}

sub B::BM::graph {
    my ($sv) = @_;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return (pvnv_common($sv),
	    ['val', 'BmUSEFUL', $sv->USEFUL],
	    ['val', 'BmPREVIOUS', $sv->PREVIOUS],
	    ['sval', 'BmRARE', chr($sv->RARE)],
	    );
}

sub fill_pad {
    my($cv) = @_;
    return map(ad($_), ($cv->PADLIST->ARRAY)[0]->ARRAY);
}

sub B::CV::graph {
    my ($sv) = @_;
    return unless $dump_svs;
    my($stash) = $sv->STASH;
    my($start) = $sv->START;
    my($root) = $sv->ROOT;
    my($padlist) = $sv->PADLIST;
    my($gv) = $sv->GV;
    my $filegv = "";
    $filegv = $sv->FILEGV if $filegvs;
    return if $nodes{$$sv}++;
    local(@padnames) = fill_pad($sv) if $targlinks;
    node($start->graph) if $start;
    node($root->graph) if $root;
    node($gv->graph) if $gv;
    node($filegv->graph) if $filegv;
    node($padlist->graph) if $padlist;
    node($stash->graph) if $stash and $dump_stashes;
    node($sv->OUTSIDE->graph) if $sv->OUTSIDE;
    return (pvnv_common($sv),
	    ($dump_stashes ? ['link', 'STASH', $$stash, 0] : ()),
	    ['link', 'START', $$start, 2],
	    ['link', 'ROOT', $$root, 0],
	    ['link', 'GV', $$gv, 0],
	    ($filegvs ? ['link', 'FILEGV', $$filegv, 0] : ()),
	    ['val', 'DEPTH',$sv->DEPTH, 0],
	    ['link', 'PADLIST', $$padlist, 0],
	    ['link', 'OUTSIDE', ad($sv->OUTSIDE), 0],
	    );
}

sub B::AV::graph {
    my ($av) = @_;
    return unless $dump_svs;
    my(@array) = $av->ARRAY;
    return if $nodes{$$av}++;
    my($n) = 0;
    my(@l) = sv_common($av);
    push @l, ['text', 'ARRAY:'];
    foreach (@array) {
	push @l, ['link', $n++, $$_, 0];
    }
    push @l, (['val', 'FILL', scalar(@array)],
	      ['val', 'MAX', $av->MAX],
	      ['val', 'OFF', $av->OFF],
	      ['val', 'AvFLAGS', $av->AvFLAGS]
	      );
    map(node($_->graph), @array);
    return @l;
}

sub B::HV::graph {
    my ($hv) = @_;
    return unless $dump_svs;
    my(@array) = $hv->ARRAY;
    my($k, $v, @values);
    return if $nodes{$$hv}++;
    my(@l) = sv_common($hv);
    push @l, ['text', "ARRAY:"];
    while (@array) {
	($k, $v) = (shift(@array), shift(@array));
	$k = "''" if $k eq '"';
	next if $k =~ /_
	if ($v) {
	    push @l, ['link', "$k => ", $$v, 0];
	} else {
	    push @l, ['text', "$k => $$v"];
	}
	push @values, $v;
    }
    push @l, (['val', 'FILL', $hv->FILL],
	      ['val', 'MAX', $hv->MAX],
	      ['val', 'KEYS', $hv->KEYS],
	      ['val', 'RITER', $hv->RITER],
	      ['val', 'NAME', $hv->NAME],
	      ['link', 'PMROOT', ad($hv->PMROOT), 0]
	      );
    node($hv->PMROOT->graph) if $hv->PMROOT;
    map(node($_->graph), @values);
    return @l;
}


sub B::GV::graph {
    my ($gv) = @_;
    return unless $dump_svs;
    my ($sv) = $gv->SV;
    my ($av) = $gv->AV;
    my ($cv) = $gv->CV;
    return if $nodes{$$gv}++;
    my(@l) = sv_common($gv);
    my($name) = $gv->NAME;
    $name = "''" if $name eq '"';
    push @l, (['sval', 'NAME', $name],
	      ($dump_stashes ? ['link', 'STASH', ad($gv->STASH), 0] : ()),
	      ['link', 'SV', $$sv, 0],
	      ['val', 'GvREFCNT', $gv->GvREFCNT],
	      ['link', 'FORM', ad($gv->FORM)],
	      ['link', 'AV', $$av, 0],
	      ['link', 'HV', ad($gv->HV), 0],
	      ['link', 'EGV', ad($gv->EGV), 0],
	      ['link', 'CV', $$cv, 0],
	      ['link', 'IO', ad($gv->IO), 0],
	      ['val', 'CVGEN', $gv->CVGEN],
	      ['val', 'LINE', $gv->LINE],
	      ($filegvs ? ['link', 'FILEGV', ad($gv->FILEGV), 0] : ()),
	      ['val', 'GvFLAGS', $gv->GvFLAGS],
	      );
    node($sv->graph) if $sv;
    node($av->graph) if $av;
    node($cv->graph) if $cv;
    node($gv->HV->graph) if $gv->HV;
    node($gv->IO->graph) if $gv->IO;
    node($gv->STASH->graph) if $gv->STASH and $dump_stashes;
    node($gv->EGV->graph) if $gv->EGV;
    return @l;
}

sub B::IO::graph {
    my $sv = shift;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    my(@l) = sv_common($sv);
    push @l, (['val', 'LINES', $sv->LINES],
	      ['val', 'PAGE', $sv->PAGE],
	      ['val', 'PAGE_LEN', $sv->PAGE_LEN],
	      ['val', 'LINES_LEFT', $sv->LINES_LEFT],
	      ['sval', 'TOP_NAME', $sv->TOP_NAME],
	      ['link', 'TOP_GV', ad($sv->TOP_GV)],
	      ['sval', 'FMT_NAME', $sv->FMT_NAME],
	      ['link', 'FMT_GV', ad($sv->FMT_GV)],
	      ['sval', 'BOTTOM_NAME', $sv->BOTTOM_NAME],
	      ['link', 'BOTTOM_GV', ad($sv->BOTTOM_GV)],
	      ['val', 'SUBPROCESS', $sv->SUBPROCESS],
	      );
    node($sv->TOP_GV->graph) if $sv->TOP_GV;
    node($sv->FMT_GV->graph) if $sv->FMT_GV;
    node($sv->BOTTOM_GV->graph) if $sv->BOTTOM_GV;
    return @l;
}

sub B::SPECIAL::graph {
    my $sv = shift;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return (['shape', $sv_shape],
	    ['title', $$sv],
	    ['text', $specialsv_name[$$sv]],
	    );
}

sub B::NULL::graph {
    my($sv) = shift;
    return unless $dump_svs;
    return if $nodes{$$sv}++;
    return (['shape', $sv_shape],
	    ['title', $$sv],
	    ['text', ($type eq "text" ? "   NULL   " : "NULL")],
	    );
}

sub compile {
    my($arg, $opt);
    my(@objs);
    $style = 0;
    $dump_stashes = 0;
    $dump_svs = 1;
    $filegvs = 0;
    $sv_shape = 'ellipse';
    $addrs = 0;
    $type = 'text';
    $seqs = 0;
    $types = 0;
    $float = 0;
    $targlinks = 0;
    for $arg (@_) {
	if (substr($arg, 0, 1) eq "-") {
	    $opt = lc $arg;
	    $opt =~ tr/_-//d;
	    if ($opt eq "stashes") {
		$dump_stashes = 1;
	    } elsif ($opt eq "nostashes") {
		$dump_stashes = 0;
	    } elsif ($opt eq "compileorder") {
		$style = 0;
	    } elsif ($opt eq "runorder") {
		$style = 1;
	    } elsif ($opt eq "svs") {
		$dump_svs = 1;
	    } elsif ($opt eq "nosvs") {
		$dump_svs = 0;
	    } elsif ($opt eq "ellipses") {
		$sv_shape = 'ellipse';
	    } elsif ($opt eq "rhombs") {
		$sv_shape = 'rhomb';
	    } elsif ($opt eq "text") {
		$type = 'text';
	    } elsif ($opt eq "vcg") {
		$type = 'vcg';
	    } elsif ($opt eq "dot") {
		$type = 'dot';
	    } elsif ($opt eq "addrs") {
		$addrs = 1;
	    } elsif ($opt eq "noaddrs") {
		$addrs = 0;
	    } elsif ($opt eq "filegvs") {
		if ($] >= 5.005_63) {
		    warn "fileGVs aren't available in this version of Perl\n";
		} else {
		    $filegvs = 1;
		}
	    } elsif ($opt eq "nofilegvs") {
		$filegvs = 0;
	    } elsif ($opt eq "seqs") {
		$seqs = 1;
	    } elsif ($opt eq "noseqs") {
		$seqs = 0;
	    } elsif ($opt eq "types") {
		$types = 1;
	    } elsif ($opt eq "notypes") {
		$types = 0;
	    } elsif ($opt eq "float") {
		$float = 1;
	    } elsif ($opt eq "nofloat") {
		$float = 0;
	    } elsif ($opt eq "targlinks") {
		$targlinks = 1;
	    } elsif ($opt eq "notarglinks") {
		$targlinks = 0;
	    }
	} else {
	    no strict 'refs';
	    push @objs, \*{"main::$arg"};
	}
    }

    if ($type eq "vcg") {
	print "graph: {\n";
	print "layout_downfactor: 10\n";
	print "layout_upfactor:   1\n";
	print "layout_nearfactor: 5\n";
	print "layoutalgorithm: dfs\n";
	print qq'classname 1: "regular"\n';
	print qq'classname 2: "sibling"\n';
	print qq'classname 3: "next"\n';
	print qq'classname 4: "fake"\n';
	print qq'classname 5: "nextish"\n\n';
    } elsif ($type eq "dot") {
	my($pname) = $0;
	$pname = "(cmdline)" if $pname eq "-e";
	print "digraph \"$pname\" {\n";
	print "rankdir=LR;\nnode [shape=record];\nedge [color=black];\n";
    }
    return sub {
	if (@objs) {
	    if ($dump_svs) {
		map(unshift(@todo, [svref_2object($_)->graph]), @objs);
	    } else {
		foreach my $obj (@objs) {
		    my $cv;
		    { no strict 'refs';
		      $cv = svref_2object(*{*$obj}{CODE}); }
		    if ($style == 0) {
			node($cv->ROOT->graph);
			unshift @todo, [$cv->START->graph];
		    } else {
			node($cv->START->graph);
			unshift @todo, [$cv->ROOT->graph];
		    }
		}
	    }
	} else {
	    @padnames = fill_pad(main_cv) if $targlinks;
	    if ($style) {
		node((main_root)->graph);
		unshift @todo, [(main_start)->graph];
	    } else {
		node((main_start)->graph);
		unshift @todo, [(main_root)->graph];
	    }
	    node((main_cv)->graph);
	}
	my($n);
	proclaim_node(@$n) while $n = shift @todo;
	my($e);
	for $e (@edges) {
	    if (exists $nodes{$e->[0]} and exists $nodes{$e->[1]}) {
		proclaim_edge(@$e);
	    }
	    else {
		# print STDERR "$e->[0] =/=> $e->[1]\n";
	    }
	}
	print "}\n" if $type eq "vcg" or $type eq "dot";
	%nodes = @edges = @todo = ();
    }

}

1;
__END__