/usr/share/perl5/DEPS/Transform/CompatGroup.pm is in libdeps-perl 0.13-2.
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 | # 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::Transform::CompatGroup;
use warnings;
use strict;
use graphincludes::graph::grouped;
use Carp qw(croak);
sub apply {
my %args = @_;
# sanity checks
if (!defined $args{graphs}
or scalar @{$args{graphs}} != 1) {
use Data::Dumper; print STDERR Dumper(keys %args);
croak "graphincludes::transform::compatgroup applies to a single graph";
}
my $src = $args{graphs}[0]; # the low-level graph
my $lvl = $args{level};
my $prj = $args{labeller};
my @prev = map { $prj->{TRANSGRAPH}->get_node_from_name($_)->{DATA}
or croak "no graph named '$_'" } @{$args{previous}};
my $new = new graphincludes::graph::grouped;
# for each low-level node:
# - record the group, and the correct $lvl-1 group as ingredient
# - record the groups for the llnode dependencies
# - record dependencies between the groups, and the correct edge as ingredient
# - record intra-node dependencies in groups
foreach my $llnode ($src->get_nodes) {
my $groupname = $prj->filelabel($llnode->{LABEL}, $lvl);
next if !defined $groupname;
my ($newnode, $newsubnode) = _register_node ($new, $llnode, $groupname, $lvl, $prj, \@prev);
# find the immediate subedge
foreach my $edge ($src->get_edges_from($llnode->{LABEL})) {
my $newdepname = $prj->filelabel($edge->{DST}{LABEL}, $lvl);
next if !defined $newdepname;
my ($newdep, $newsubdep) = _register_node ($new, $edge->{DST}, $newdepname, $lvl, $prj, \@prev);
# record the dep, as part of node if intra-group, or as edge ingredient
my $subedge = $prev[$#prev]->get_edge($newsubnode->{LABEL}, $newsubdep->{LABEL});
if ($newdep eq $newnode) {
# the subedge is taken from level $lvl-1, and will not be found there if it was
# aleady intra-node at that level, so skip it if we do not find it
$new->register_intragroup_edge($newnode, $subedge)
if defined $subedge;
} else {
$new->record_edge($groupname, $newdepname)->add_ingredients($subedge);
}
}
}
return $new;
}
# Hack to get the dependency graph in corect shape. Not to be
# mis-used: the compatgroup mechanism allows for inconsistencies if
# this fixup is used, when the filelabel function does not define a
# proper group hierarchy.
sub fixup_dep {
my ($graph, $src, $dst, $orig) = @_;
$graph->has_edge($orig, $dst) or croak "no dependency exists from $orig to $dst";
$graph->drop_edge($orig, $dst);
$graph->record_edge($src, $dst);
}
sub _register_node {
my ($new, $node, $groupname, $lvl, $prj, $prev) = @_;
# find the immediate subnode
my ($subnode, $prevlevel);
for ($prevlevel = $lvl - 1;
$prevlevel >= 0 and
!defined ($subnode = $prev->[$prevlevel]->
get_node_from_name($prj->filelabel($node->{LABEL}, $prevlevel)));
--$prevlevel) {
}
# hack necessary because prefixstrip is applied to level 0 - we
# would need another graph between 0 and 1 for this
$subnode = $prev->[$prevlevel]->get_node_from_name($node->{LABEL}) unless defined $subnode;
die "No ingredient node found for $groupname for $node->{LABEL}" unless defined $subnode;
my $newnode = $new->record_node($groupname);
$new->register_group_member($newnode, $subnode);
return ($newnode->add_ingredients($subnode), $subnode);
}
1;
|