/usr/share/perl5/DEPS/Transform/TransitiveReduction.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 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 | # 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::TransitiveReduction;
use warnings;
use strict;
use graphincludes::graph;
use Carp qw(croak);
sub apply {
my %args = @_;
# sanity checks
if (!defined $args{graphs}
or scalar @{$args{graphs}} != 1) {
croak "graphincludes::transform::transitivereduction applies to a single graph";
}
my $src = $args{graphs}[0];
my $reduced = $src->copy(deep_copy_edges => 1);
print STDERR "Doing transitive reduction " if $graphincludes::params::verbose;
foreach my $node ($reduced->get_edge_origins) {
print STDERR '.' if $graphincludes::params::verbose;
print STDERR "node $node\n" if $graphincludes::params::debug;
if ($reduced->has_children($node)) {
my %droppedchildren; # hash (indexed list) of children to drop
# first, get the list of children to be dropped
my @considered = ($node);
foreach my $child ($reduced->get_dep_names_from($node)) {
# do not explore children already removed, or some circles cause lost edges
next if defined $droppedchildren{$child};
print STDERR " child $child\n" if $graphincludes::params::debug;
if ($reduced->has_children($child)) {
foreach my $gchild ($reduced->get_dep_names_from($child)) {
if ($gchild ne $node and $gchild ne $child) { # XXX
print STDERR " gchild $gchild\n" if $graphincludes::params::debug;
$reduced->_suppress (\%droppedchildren, $gchild, \@considered,
($node, $child, $gchild));
}
}
}
}
# then drop those children we just marked
foreach my $child (keys %droppedchildren) {
$reduced->drop_edge ($node, $child);
}
}
}
print STDERR " $reduced->{_DROPCOUNT} cleared.\n" if $graphincludes::params::verbose;
$reduced->is_reduction_of ($src)
or die "internal error in transitive reduction (please use --debug)";
return $reduced;
}
package graphincludes::graph; # FIXME !
sub _suppress {
my $self = shift;
my ($dropped, # hash (indexed list) of children to drop
$suspect, # node to consider this time
$considered, # graph nodes already seen, not to reconsider
@context) # current path
= @_;
# Do not consider $suspect twice, prevent looping on circular deps.
# We must take care of the special case of the child that led us to
# the current node, or we would have to do special things to $gchild
return if $suspect eq $context[1] or grep { $suspect eq $_ } (@$considered);
push @$considered, $suspect;
# mark $suspect for removal
if ($self->has_edge($context[0],$suspect) and !defined $dropped->{$suspect}) {
if ($graphincludes::params::showdropped) {
$self->{SPECIALEDGES}{$context[0]}{$suspect} = {color => "#FFCCCC",
constraint => 'false'};
} elsif (grep { $_ eq $context[0] } @graphincludes::params::focus) {
$self->{SPECIALEDGES}{$context[0]}{$suspect} = {color => "#FFCCCC"};
} else {
$self->{_DROPCOUNT}++;
# increment "use count" on each step of the alternate path in @context
my $dropped_edge = $self->get_edge($context[0],$suspect);
my $weight = $dropped_edge->weight;
for (my $i = 0; $i < $#context; $i++) {
$self->{_EDGES}{$context[$i]}{$context[$i+1]}->add_ingredients($dropped_edge);
}
# remove it
$dropped->{$suspect} = 1;
}
print STDERR " --$suspect (", join (',', @context), ")\n" if $graphincludes::params::debug;
}
# look at $suspect's children
if ($self->has_children($suspect)) {
foreach my $child ($self->get_dep_names_from($suspect)) {
if ($graphincludes::params::debug) {
foreach (@context) {
print STDERR " ";
}
print STDERR "$child\n";
}
$self->_suppress ($dropped, $child, $considered, (@context, $child));
}
}
}
1;
|