view release on metacpan or  search on metacpan

Graph.pm  view on Meta::CPAN

	    } 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)] : ()),