/usr/share/perl5/DEPS/Style/Node/PerGroup.pm is in libdeps-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 | # This file is part of the DEPS/graph-includes package
#
# (c) 2006 Yann Dirson <ydirson@altern.org>
# Distributed under version 2 of the GNU GPL.
package DEPS::Style::Node::PerGroup;
use warnings;
use strict;
use base qw(DEPS::Style);
use Hash::Util qw(lock_keys unlock_keys);
use Carp qw(croak);
# Arguments:
# attribute (eg. 'bgcolor', 'bordercolor')
# valuemap (hash of name => color)
# refgraph (reference graph in which to look for names)
# FIXME: optionally forbid overriding ?
sub new {
my $class = shift;
my $self = $class->SUPER::new([qw(attribute valuemap transgraph graph refgraph)],
[],
@_);
unlock_keys (%$self);
$self->{PATHS} = undef; # cache - double-hash of path-arrays
# to the graphs used as base for coloring
bless ($self, $class);
lock_keys (%$self);
return $self;
}
sub _get_path {
my $self = shift;
my ($src, $dst) = @_;
# look in cache first
my $path = $self->{PATHS}{$src}{$dst};
if (!defined $path) {
my @path = $self->{transgraph}->has_path($src, $dst);
if (@path) {
# we have nothing to look in the 1st node in the graph
shift @path;
# get an graphs from nodes in the transform graph
@path = map { $self->{transgraph}->get_node_from_name($_)->{DATA} } @path;
# fill the cache and keep path
$path = $self->{PATHS}{$src}{$dst} = \@path;
} else {
croak "no path found from $src to $dst";
}
}
return $path;
}
# FIXME: would be more clean and straightforward to apply on a
# formalized "group hierarchy"
sub apply {
my $self = shift;
my ($node, $graphnode, $style) = @_;
my $path = $self->_get_path($self->{graph}, $self->{refgraph});
# iterate on path to find the node in $refgraph
foreach my $graph (@$path) {
$node = ($graph->who_contains($node) or $node);
}
my $checknode;
unless (defined ($checknode = $self->{transgraph}->get_node_from_name($self->{refgraph})
->{DATA}->get_node_from_name($node->{LABEL}))
and $checknode eq $node) {
return $style;
}
my $color = $self->{valuemap}{$node->{LABEL}};
if (defined $color) {
$style->{$self->{attribute}} = $color;
}
return $style;
}
1;
|