/usr/share/perl5/graphincludes/renderer/dot.pm is in libdeps-renderer-dot-perl 0.13-1.1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | # This file is part of the DEPS/graph-includes package
#
# (c) 2005,2006 Yann Dirson <ydirson@altern.org>
# Distributed under version 2 of the GNU GPL.
package graphincludes::renderer::dot;
use warnings;
use strict;
use base qw(graphincludes::renderer);
use Hash::Util qw(lock_keys);
use graphincludes::params;
sub new {
my $class = shift;
my $self = {
DOTFLAGS => [],
OUTFORMAT => undef,
};
bless ($self, $class);
lock_keys (%$self);
return $self;
}
my %paper = (
a4 => '11.6,8.2',
a3 => '16.5,11.6',
letter => '11,8.5',
);
#FIXME: also set arrow head
my @paperparams = ('-Gnodesep=0.1', '-Granksep=0.1', '-Nfontsize=5', '-Efontsize=5');
sub set_multipage {
my $self = shift;
my ($papersize) = @_;
die "Unkown paper size \`$papersize'" unless defined $paper{$papersize};
# paper output format is postscript on stdout unless otherwise specified
$self->set_outputformat ('ps');
push @{$self->{DOTFLAGS}}, @paperparams, '-Gpage=' . $paper{$papersize};
}
sub set_outputformat {
my $self = shift;
$self->{OUTFORMAT} = shift;
}
sub set_outputfile {
my $self = shift;
my ($outfile) = @_;
push @{$self->{DOTFLAGS}}, '-o', $outfile;
$outfile =~ m/.*\.([^.]+)$/ or die "cannot guess output format";
$self->set_outputformat ($1);
}
sub _node_stylestring {
my ($node, $style) = @_;
my @attrs;
my $label = ($style->{label} or $node->{LABEL});
foreach my $key (keys %$style) {
if ($key eq 'label') {
next; # already handled
} elsif ($key eq 'extralabel') {
$label .= "\\n$style->{$key}";
} elsif ($key eq 'bgcolor') {
# FIXME: should validate color (use Graphics::ColorNames)
push @attrs, 'style=filled', 'fillcolor='.$style->{$key};
} elsif ($key eq 'bordercolor') {
push @attrs, 'color='.$style->{$key};
} else {
print STDERR "Warning: graphincludes::renderer::dot does not support attribute '$key' for nodes\n";
}
}
unshift @attrs, "label=\"$label\"";
join ',', @attrs;
}
sub _edge_stylestring {
my ($node, $style) = @_;
my @attrs;
foreach my $key (keys %$style) {
if ($key eq 'label') {
push @attrs, "label=\".$style->{$key}\"";
} else {
print STDERR "Warning: graphincludes::renderer::dot does not support style attribute '$key' for edges\n";
}
}
join ',', @attrs;
}
# apply sequence of stylers on an object
# FIXME: move to where ?
sub style {
my ($object, $graphnode, $stylers) = @_;
my $style = {};
foreach my $styler (@$stylers) {
$styler->apply($object, $graphnode, $style);
}
return $style;
}
sub printgraph {
my $self = shift;
my ($graphnode, $nodestylers, $edgestylers) = @_;
# $graphnode can be a node in the transform graph, or maybe a simple graph,
# allowing to graph the transform graph itself
my $graph = eval { defined $graphnode->{DATA} } ? $graphnode->{DATA} : $graphnode;
push @{$self->{DOTFLAGS}}, "-T$self->{OUTFORMAT}" if defined $self->{OUTFORMAT};
if (scalar(@{$self->{DOTFLAGS}}) > 0) {
my $flags = join ' ', @{$self->{DOTFLAGS}};
print STDERR "Running through \`dot $flags'\n" if $graphincludes::params::verbose;
open STDOUT, "| dot $flags";
}
print "strict digraph dependencies {\nrankdir=LR;\n";
foreach my $node ($graph->get_nodes) {
print "\"$node->{LABEL}\" [", _node_stylestring($node, style($node, $graphnode, $nodestylers)), "]\n";
}
foreach my $file ($graph->get_edge_origins) {
foreach my $edge ($graph->get_edges_from($file)) {
print "\"$file\" -> \"$edge->{DST}{LABEL}\" [", _edge_stylestring($edge, style($edge, $graphnode, $edgestylers)), "]\n";
}
}
print "}\n";
}
sub wait {
my $self = shift;
if (scalar(@{$self->{DOTFLAGS}}) > 0) {
close STDOUT;
wait;
}
}
1;
|