738 lines
18 KiB
Perl
Executable File
738 lines
18 KiB
Perl
Executable File
#!@PERL5@
|
|
|
|
# Copyright (c) 2002, 2003, 2004 by Andrew Brown <atatat@netbsd.org>
|
|
# Absolutely no warranty.
|
|
|
|
# $NetBSD: pkgdepgraph.pl,v 1.12 2014/03/03 05:06:43 obache Exp $
|
|
# pkgdepgraph: @DISTVER@
|
|
|
|
use strict;
|
|
# no strict 'refs';
|
|
|
|
use Getopt::Long;
|
|
Getopt::Long::Configure("bundling");
|
|
my(@opts, %opt);
|
|
my($iam, $version, $usecolor, $group, $locations, $order, $versions);
|
|
my($limit, $delete, $rebuild, $force, @outofdate, @update, $clean);
|
|
my($pkg_dbdir, $pkgsrcdir, $packages, $pkgadd, $fetch, $make);
|
|
my($all, $target, $exists, $reverse, $simple, @subgraph, @impact, %impactof);
|
|
|
|
$version = '@DISTVER@';
|
|
($iam = $0) =~ s:.*/::;
|
|
@opts = ('A', 'a+', 'C', 'c', 'D', 'd=s', 'e', 'F', 'f', 'g', 'i=s',
|
|
'K=s', 'L', 'l', 'M=s', 'm=s', 'O=s', 'o', 'P=s', 'R', 'r',
|
|
'S=s', 's', 't=s', 'U=s', 'v');
|
|
|
|
%opt = (
|
|
'A' => \$pkgadd,
|
|
'a' => \$all,
|
|
# 'C' => implies "realclean", handled later
|
|
# 'c' => implies "clean", handled later
|
|
'D' => \$delete,
|
|
'd' => \$pkg_dbdir,
|
|
'e' => \$exists,
|
|
'F' => \$fetch,
|
|
'f' => \$force,
|
|
'g' => \$group,
|
|
'i' => \@impact,
|
|
'K' => \$packages,
|
|
'L' => \$limit,
|
|
'l' => \$locations,
|
|
'M' => \$make,
|
|
'm' => \$target,
|
|
'O' => \@outofdate,
|
|
'o' => \$order,
|
|
'P' => \$pkgsrcdir,
|
|
'R' => \$rebuild,
|
|
'r' => \$reverse,
|
|
'S' => \@subgraph,
|
|
's' => \$simple,
|
|
# 't' => goes to rebuild, handled later
|
|
'U' => \@update,
|
|
'v' => \$versions,
|
|
);
|
|
die("usage: $iam [-AaCcDeFfgLloRrsv] [-d pkg_dbdir] [-i impact]\n",
|
|
" " x (length($iam) + 8),
|
|
"[-K packages] [-M make] [-m target] [-O package]\n",
|
|
" " x (length($iam) + 8),
|
|
"[-P pkgsrcdir] [-S package] [-t target] [-U package]\n",
|
|
" " x (length($iam) + 8),
|
|
"[data ...]\n")
|
|
if (!GetOptions(\%opt, @opts));
|
|
|
|
die("$iam: -D, -F, -m, and -R are mutually exclusive -- please pick one\n")
|
|
if (($delete != 0) +
|
|
($fetch != 0) +
|
|
($target ne "") +
|
|
($rebuild ne "") > 1);
|
|
|
|
$pkg_dbdir ||= $ENV{'PKG_DBDIR'} || "@PKG_DBDIR@";
|
|
$pkgsrcdir ||= $ENV{'PKGSRCDIR'} || "@PKGSRCDIR@";
|
|
$packages = $ENV{'PKG_PATH'} if (!$packages);
|
|
$packages = $ENV{'PACKAGES'} . "/All" if (!$packages && $ENV{'PACKAGES'});
|
|
$packages = $pkgsrcdir . "/packages/All" if (!$packages);
|
|
$rebuild &&= $opt{t} || "install";
|
|
$clean = "clean" if ($opt{c});
|
|
$clean = "CLEANDEPENDS=YES clean" if ($opt{C});
|
|
$make ||= $ENV{'MAKE'} || "make";
|
|
|
|
my(@pkgs, $pkg, $req, %req, %dep, @reqs, @rreqs);
|
|
my(%clusters, $cluster);
|
|
my(%where, $pkgcnt, $num, %num, @num, %ord, $suffix);
|
|
my(%color, $color, %vuln);
|
|
my(%need, %forced, $label);
|
|
my($recolor, @graph);
|
|
my(%vpkgs);
|
|
|
|
# @pkgs - list of all installed pkgs
|
|
# %req - pkg to ref to hash of pkgs that it requires
|
|
# %dep - pkg to ref to hash of pkgs that depend on it
|
|
# %clusters - pkg prefix to number of pkgs that share the prefix
|
|
# %where - pkg to location in source tree
|
|
# %num/@num - pkg to group number/group number array ref
|
|
# %ord - pkg to its height in the tree
|
|
# %color - pkg to pkg color (green, yellow, red, etc)
|
|
# %vuln - pkg to vulnerabilities recorded against it
|
|
# %need - pkg to version required (pkg is out of date)
|
|
# %forced - pkg marked as "forced" to be out of date
|
|
# %vpkgs - pkg is viewable (part of selected subgraph)
|
|
|
|
##
|
|
## load out-of-date or security problem list (if given), or a graph to
|
|
## recolor
|
|
##
|
|
$recolor = 0;
|
|
if (@ARGV || ! -t) {
|
|
$usecolor = 1;
|
|
while (<>) {
|
|
if (/^digraph/) {
|
|
$recolor = 1;
|
|
@graph = ($_);
|
|
}
|
|
elsif ($recolor > 0) {
|
|
push(@graph, $_);
|
|
$recolor++ if (/^subgraph/);
|
|
$recolor-- if (/^\}/);
|
|
$recolor -= ($recolor == 0);
|
|
}
|
|
elsif (m:^([^/\s]+)\t([^/\s]+/[^/\s]+)\t(\d+[^/\s]*)$:) {
|
|
$where{"$1-$3"} = $2;
|
|
}
|
|
elsif (/^Version mismatch: '(\S+)' (\S+) vs (\S+)/) {
|
|
$color{"$1-$2"} = "red";
|
|
$need{"$1-$2"} = "$1-$3";
|
|
}
|
|
elsif (/^Unknown package: '(\S+)' version (\S+)/) {
|
|
$color{"$1-$2"} = "purple";
|
|
}
|
|
elsif (/Package (\S+) has a (\S+) vulnerability/) {
|
|
$vuln{$1} = $2;
|
|
$color{$1} = "red";
|
|
}
|
|
}
|
|
}
|
|
|
|
##
|
|
## load pkg list
|
|
##
|
|
opendir(P, $pkg_dbdir) || die("opendir");
|
|
@pkgs = grep(/-/ && -d "$pkg_dbdir/$_" && -f "$pkg_dbdir/$_/+BUILD_INFO",
|
|
readdir(P));
|
|
closedir(P);
|
|
$pkgcnt = @pkgs;
|
|
|
|
##
|
|
## where are they needed
|
|
##
|
|
foreach $pkg (@pkgs) {
|
|
$where{$pkg} ||= $pkg;
|
|
open(R, "<$pkg_dbdir/$pkg/+BUILD_INFO") ||
|
|
die("$pkg: +BUILD_INFO: $!\n");
|
|
while (<R>) {
|
|
if (/^PKGPATH\s*=\s*(\S+)/) {
|
|
$where{$pkg} = $1 if ($where{$pkg} eq $pkg);
|
|
last;
|
|
}
|
|
}
|
|
close(R);
|
|
next if (!open(R, "<$pkg_dbdir/$pkg/+REQUIRED_BY"));
|
|
while ($req = <R>) {
|
|
chomp($req);
|
|
$req{$req}->{$pkg} = 1;
|
|
$dep{$pkg}->{$req} = 1;
|
|
}
|
|
close(R);
|
|
}
|
|
|
|
##
|
|
## reset %where based on "better" information, if we have it
|
|
##
|
|
foreach $pkg (@pkgs) {
|
|
if ($need{$pkg} && $where{$need{$pkg}}) {
|
|
$where{$pkg} = $where{$need{$pkg}};
|
|
}
|
|
}
|
|
|
|
##
|
|
## if we're recoloring an existing graph, recolor it now and finish
|
|
##
|
|
if ($recolor) {
|
|
my(%over, %nver, @label, $ocolor);
|
|
map({ /(.*)-(.*)/ && ($nver{$1} = $2) } @pkgs);
|
|
|
|
foreach (@graph) {
|
|
# we don't recolor edges
|
|
($pkg) = (/\"([^\"]+)\"/);
|
|
$pkg =~ s/(.*)-(.*)/$1/;
|
|
$over{$pkg} = $2;
|
|
|
|
if (/, EDGE$/) {
|
|
if (defined($nver{$pkg})) {
|
|
s/color=\"[^\"]+\"/color=\"green\"/;
|
|
}
|
|
else {
|
|
s/color=\"[^\"]+\"/color=\"black\"/;
|
|
}
|
|
}
|
|
|
|
elsif (/label=/) {
|
|
s/color=\"([^\"]+)\"/color="NEWCOLOR"/;
|
|
$ocolor = $1;
|
|
s/label=\"([^\"]+)\"/label="NEWLABEL"/;
|
|
$label = $1;
|
|
if ($nver{$pkg}) {
|
|
if ($nver{$pkg} ne $over{$pkg} || $ocolor ne "red") {
|
|
s/NEWCOLOR/green/;
|
|
}
|
|
else {
|
|
s/NEWCOLOR/$ocolor/;
|
|
}
|
|
|
|
@label = split(/\\n/, $label);
|
|
$label = "";
|
|
|
|
# "where" tag
|
|
if ($label[0] =~ m:/:) {
|
|
$label .= "\\n" . shift(@label);
|
|
}
|
|
|
|
# installed pkg
|
|
$label[0] =~ s/(.*$pkg)-\S*$/$1-$nver{$pkg}/ if ($nver{$pkg});
|
|
$label .= "\\n" . shift(@label);
|
|
|
|
# "needed" pkg
|
|
if ($label[0] =~ /^$pkg-(.*)/) {
|
|
$label .= "\\n$label[0]" if ($1 ne $nver{$pkg});
|
|
shift(@label);
|
|
}
|
|
|
|
# there shouldn't be anything left, but...
|
|
$label .= "\\n" . join("\\n", @label);
|
|
|
|
$label =~ s/\\n//;
|
|
}
|
|
else {
|
|
s/NEWCOLOR/black/;
|
|
}
|
|
s/NEWLABEL/$label/;
|
|
}
|
|
print;
|
|
}
|
|
exit(0);
|
|
}
|
|
|
|
##
|
|
## eliminate redundancies by deleting edges that are redundant
|
|
##
|
|
foreach $pkg (@pkgs) {
|
|
@reqs = sort(keys %{$req{$pkg}});
|
|
@rreqs = recurse(\%req, @reqs);
|
|
map(delete($req{$pkg}->{$_}), @rreqs);
|
|
|
|
@reqs = sort(keys %{$dep{$pkg}});
|
|
@rreqs = recurse(\%dep, @reqs);
|
|
map(delete($dep{$pkg}->{$_}), @rreqs);
|
|
}
|
|
|
|
##
|
|
## create a hash of clusters of package prefixes, with counts. later,
|
|
## clusters that have more than one member can be marked as subgraphs.
|
|
##
|
|
## the outer map() iterates over each pkg name after all instances of
|
|
## _ in the pkg name have been changed to - (for the purposes of
|
|
## accurate clustering). the inner map() breaks each pkg name up into
|
|
## tokens that end in - and loops over the resulting list, appending
|
|
## each one to $a. for example:
|
|
##
|
|
## pkg: one_two-three-4.56
|
|
## tokens: one- two- three-
|
|
## $a: one- one-two- one-two-three-
|
|
##
|
|
map({ $a = "";
|
|
($b = $_) =~ s/_/-/g;
|
|
map({ $a .= $_; $clusters{$a}++; }
|
|
$b =~ /([^-]*-)/g); }
|
|
@pkgs);
|
|
|
|
##
|
|
## impose some sort of order on the pkgs by assigning them numbers
|
|
## that indicate their height in the graph. leaf pkgs will always
|
|
## have an order of 1, and each pkg above will be numbered at least 2
|
|
## (possibly higher, if there exists another longer path to another
|
|
## leaf).
|
|
##
|
|
map(order(1, $_), @pkgs);
|
|
|
|
##
|
|
## assign each pkg a group number, and count the number of pkgs in
|
|
## that group. the group numbers are arbitrary, and serve only to
|
|
## identify pkgs that belong to the same group.
|
|
##
|
|
$num = 1;
|
|
foreach $pkg (@pkgs) {
|
|
my($pkgnum);
|
|
# my direct requirements
|
|
@reqs = sort(keys %{$req{$pkg}});
|
|
# all the requirements of my requirements
|
|
@rreqs = recurse(\%req, @reqs);
|
|
# the lowest group number from all of those
|
|
$pkgnum = number($pkg, @reqs, @rreqs) || $num;
|
|
# stuff all those into the list for that group
|
|
push(@{$num[$pkgnum]}, $pkg, @reqs, @rreqs);
|
|
# now check for packages coming from other groups
|
|
foreach $req ($pkg, @reqs, @rreqs) {
|
|
# no group yet, skip on
|
|
next if (!$num{$req});
|
|
# was $req in a different group
|
|
if ($num{$req} != $pkgnum) {
|
|
# yes, pull that group into the current group
|
|
push(@{$num[$pkgnum]}, @{$num[$num{$req}]});
|
|
# empty out the old group
|
|
@{$num[$num{$req}]} = ();
|
|
}
|
|
}
|
|
# reduce the group list
|
|
@{$num[$pkgnum]} = uniq(sort(@{$num[$pkgnum]}));
|
|
# make sure all packages in this group know
|
|
map($num{$_} = $pkgnum, @{$num[$pkgnum]});
|
|
# skip to next available group number
|
|
$num += ($num == $pkgnum);
|
|
}
|
|
|
|
##
|
|
## if we want to check a specific pkg for rebuild impact, mark it as
|
|
## "forced" to be out of date, unless it already *is* out of date.
|
|
##
|
|
if (@outofdate) {
|
|
$usecolor = 1;
|
|
canonicalize(@outofdate);
|
|
|
|
foreach (@outofdate) {
|
|
if ($color{$_} ne "red") {
|
|
$color{$_} = "red";
|
|
$need{$_} = $_;
|
|
$forced{$_} = " (forced)";
|
|
}
|
|
}
|
|
}
|
|
|
|
##
|
|
## if we want to update a specific package, mark all non-related
|
|
## packages as "green". this avoids rebuilding unnecessary pkgs that
|
|
## don't depend on any of the same dependencies as the given pkg. if
|
|
## $force is set, mark *all* dependencies of the given pkg as out of
|
|
## date.
|
|
##
|
|
if (@update) {
|
|
my(@leftover);
|
|
|
|
canonicalize(@update);
|
|
@update = uniq(sort(@update, recurse(\%req, @update)));
|
|
|
|
if ($force) {
|
|
foreach (@update) {
|
|
if ($color{$_} ne "red") {
|
|
$color{$_} = "red";
|
|
$need{$_} = $_;
|
|
$forced{$_} = " (forced)";
|
|
}
|
|
}
|
|
}
|
|
|
|
foreach (sort(@pkgs)) {
|
|
if ($_ eq $update[0]) {
|
|
shift(@update);
|
|
}
|
|
else {
|
|
push(@leftover, $_);
|
|
}
|
|
}
|
|
|
|
delete(@color{@leftover});
|
|
delete(@need{@leftover});
|
|
}
|
|
|
|
##
|
|
## pick packages for a subgraph
|
|
##
|
|
## + means up from given package, - means down, ++ means all the way
|
|
## up, -- means all the way down, = means all "connected" packages, etc.
|
|
##
|
|
if (@subgraph) {
|
|
my ($sub, $up, $down, $eq);
|
|
foreach (@subgraph) {
|
|
($sub) = (/^([-+=]+)/);
|
|
s/^[-+=]+//;
|
|
$sub = "+-" if ($sub eq "");
|
|
canonicalize($_);
|
|
$up = join("", ($sub =~ /(\+)/g));
|
|
$down = join("", ($sub =~ /(-)/g));
|
|
$eq = join("", ($sub =~ /(=)/g));
|
|
if ($eq) {
|
|
map($vpkgs{$_} = 1, @{$num[$num{$_}]});
|
|
}
|
|
else {
|
|
if ($up) {
|
|
@reqs = sort(keys %{$req{$_}});
|
|
@rreqs = (length($up) > 1) ? recurse(\%req, @reqs) : ();
|
|
map($vpkgs{$_} = 1, ($_, @reqs, @rreqs));
|
|
}
|
|
if ($down) {
|
|
@reqs = sort(keys %{$dep{$_}});
|
|
@rreqs = (length($down) > 1) ? recurse(\%dep, @reqs) : ();
|
|
map($vpkgs{$_} = 1, ($_, @reqs, @rreqs));
|
|
}
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
@vpkgs{@pkgs} = (1) x @pkgs;
|
|
}
|
|
|
|
##
|
|
## if checking for rebuild impact, also mark packages that are too
|
|
## deeply involved as "green" so that they're not candidates for
|
|
## destruction
|
|
##
|
|
if (@impact) {
|
|
my ($impact);
|
|
|
|
# step 1: canonicalize anything that's not a number (ie, is the
|
|
# name of a pkg) and eliminate duplicates (we just don't need 'em)
|
|
foreach (@impact) {
|
|
next if (/^\d+$/);
|
|
canonicalize($_);
|
|
}
|
|
@impact = uniq(sort(@impact));
|
|
|
|
# step 2: the "default" impact allows for anything to be rebuilt,
|
|
# but numeric values in @impact are also allowed, so pick the
|
|
# lowest one (specifying both 1 and 2 really means just 1)
|
|
$impact = $ord{(sort(byord @pkgs))[0]};
|
|
while ($impact[0] =~ /^\d+$/) {
|
|
$_ = shift(@impact);
|
|
$impact = $_ if ($_ < $impact);
|
|
}
|
|
|
|
# step 3: anything that would have too great an impact on the tree
|
|
# gets marked (the impactof() function will check the @impact
|
|
# array to avoid specific pkgs being rebuild)
|
|
foreach $pkg (keys %vpkgs) {
|
|
next if (impactof($impact, $pkg) <= $impact);
|
|
$vpkgs{$pkg} = 2;
|
|
}
|
|
|
|
# step 4: anything so marked gets tagged as green. this tagging
|
|
# is a separate step so that we can properly judge impact over the
|
|
# entire tree (marking too early could prematurely split chunks
|
|
# that need to be rebuilt)
|
|
foreach $pkg (keys %vpkgs) {
|
|
$color{$pkg} = "green" if ($vpkgs{$pkg} == 2);
|
|
}
|
|
}
|
|
|
|
##
|
|
## translate "older" alternate output modes to the new generic version
|
|
##
|
|
if ($fetch) {
|
|
$target = "fetch";
|
|
}
|
|
elsif ($rebuild) {
|
|
$exists = 1;
|
|
$limit = 1;
|
|
$target = $rebuild;
|
|
}
|
|
elsif ($delete) {
|
|
$all++;
|
|
$simple = 1;
|
|
}
|
|
|
|
##
|
|
## "target" output mode, ordered by ascendency
|
|
##
|
|
if ($target || $simple) {
|
|
my(@targets);
|
|
printf("PKG_PATH=\"$packages\"\nexport PKG_PATH\n")
|
|
if ($pkgadd && $rebuild);
|
|
@targets = grep((color($_) eq "red" && !$limit) ||
|
|
(color($_) ne "green" &&
|
|
($all || ($ord{$_} == 1 && $limit))) ||
|
|
($all > 1), keys %vpkgs);
|
|
@targets = sort(byord @targets);
|
|
@targets = reverse(@targets) if (!$reverse);
|
|
print_package(@targets);
|
|
print("true\n") if (!$simple);
|
|
exit(0);
|
|
}
|
|
|
|
##
|
|
## show left overs as a graph
|
|
##
|
|
printf("digraph \"%s packages\" {\n",
|
|
$limit ? "out of date" : "installed");
|
|
printf("label = \"%s packages %s, generated by %s v%s, on %s\";\n",
|
|
$limit ? "out of date" : "installed",
|
|
@subgraph ? "subgraph (@subgraph)" : "graph",
|
|
$iam, $version, scalar(localtime));
|
|
foreach $pkg (sort(bynum keys %vpkgs)) {
|
|
$color = color($pkg);
|
|
next if ($limit && $color eq "green");
|
|
$label = $pkg;
|
|
$label =~ s/(.*)-.*/$1/ if (!$versions);
|
|
$label = "($ord{$pkg}) $label" if ($order);
|
|
$label = "$where{$pkg}\\n$label" if ($locations);
|
|
$label .= "\\n$need{$pkg}$forced{$pkg}" if ($need{$pkg});
|
|
if ($vuln{$pkg}) {
|
|
$label .= "\\n(no update available)" if (!$need{$pkg});
|
|
$label .= "\\n[$vuln{$pkg}]";
|
|
}
|
|
$suffix = "\t// \#$ord{$pkg}, group $num{$pkg}, " .
|
|
(exists($impactof{$pkg}) ? "impact $impactof{$pkg}, " : "") .
|
|
scalar(@{$num[$num{$pkg}]}) . " members, $pkgcnt pkgs";
|
|
$suffix .= ", LEAF" if ($ord{$pkg} == 1);
|
|
|
|
##
|
|
## scan the cluster list, but in the opposite order so in the case
|
|
## of pkgs with a common "multi-token" prefix, we only emit the
|
|
## one with the longest name. we have to prepend the names to a
|
|
## buffer so that they end up being printed in the reverse of
|
|
## discovery order, so that we end up with the "least-specific"
|
|
## subgroup announced first.
|
|
##
|
|
($a = $pkg) =~ s/_/-/g;
|
|
$b = 1;
|
|
$cluster = "";
|
|
while ($group && $a =~ s/-[^-]+-?$/-/) {
|
|
next if ($clusters{$a} == $b);
|
|
$b = $clusters{$a};
|
|
$cluster = sprintf("subgraph \"cluster_%s\" {\n", substr($a, 0, -1)) .
|
|
sprintf("label = \"%s (%d)\";\n", substr($a, 0, -1), $b) .
|
|
$cluster;
|
|
}
|
|
print($cluster);
|
|
printf("\"%s\" [color=\"%s\",label=\"%s\"];$suffix\n", $pkg,
|
|
$usecolor ? $color : "black", $label);
|
|
$cluster =~ s/label = .*\n//g;
|
|
$cluster =~ s/.+\{/\}/g;
|
|
print($cluster);
|
|
@reqs = sort(keys %{$req{$pkg}});
|
|
$suffix =~ s/, LEAF$//;
|
|
$suffix .= ", EDGE";
|
|
foreach $req (@reqs) {
|
|
$color = color($req);
|
|
next if ($limit && $color eq "green");
|
|
printf("\"%s\" -> \"%s\" [color=\"%s\"];$suffix\n", $req, $pkg,
|
|
$usecolor ? $color : "black");
|
|
}
|
|
}
|
|
print("}\n");
|
|
|
|
##
|
|
## print sh(1) style commands to handle work on a given package, or
|
|
## just the package name if $simple is set
|
|
##
|
|
sub print_package {
|
|
foreach (@_) {
|
|
printf("( pkg_info -qe %s || ", /(.*)-.*/) if ($exists && !$simple);
|
|
if ($simple) {
|
|
print($_);
|
|
}
|
|
elsif ($pkgadd) {
|
|
printf("( pkg_add %s.tgz", ($need{$_} || $_));
|
|
}
|
|
else {
|
|
print("( cd $pkgsrcdir/$where{$_} && $make $target");
|
|
print(" && $make $clean") if ($clean);
|
|
}
|
|
if (!$simple) {
|
|
print(" )") if ($exists);
|
|
print(" ) &&");
|
|
}
|
|
print("\n");
|
|
}
|
|
}
|
|
|
|
##
|
|
## find all dependencies above or below a given node
|
|
##
|
|
sub recurse {
|
|
my(@list, @new, $map);
|
|
@list = ();
|
|
$map = shift;
|
|
foreach (@_) {
|
|
@new = keys %{$map->{$_}};
|
|
push(@list, @new, recurse($map, @new));
|
|
}
|
|
uniq(sort(@list));
|
|
}
|
|
|
|
##
|
|
## canonicalize a pkg name based on what we have installed
|
|
##
|
|
sub canonicalize {
|
|
my($canon, $pkg);
|
|
|
|
foreach $pkg (@_) {
|
|
# attempt to find actual pkg, first by argument given...
|
|
($canon) = grep($pkg eq $_, @pkgs);
|
|
|
|
# ...then by comparing against the internal list sans version numbers
|
|
($canon) = grep(($a = $_) =~ s/(.*)-.*/$1/ && $pkg eq $a, @pkgs)
|
|
if (!defined($canon));
|
|
|
|
die("package '$pkg' not found\n")
|
|
if (!defined($canon));
|
|
|
|
$pkg = $canon;
|
|
}
|
|
|
|
@_;
|
|
}
|
|
|
|
##
|
|
## lowest group number of a set of packages
|
|
##
|
|
sub number {
|
|
my($n, $pkg);
|
|
$n = 0;
|
|
foreach $pkg (@_) {
|
|
$n = $num{$pkg} if ($n == 0 || $num{$pkg} < $n);
|
|
}
|
|
$n + 0;
|
|
}
|
|
|
|
##
|
|
## pick a color based on the color of the dependencies
|
|
##
|
|
sub color {
|
|
my($pkg) = @_;
|
|
if ($color{$pkg}) {
|
|
$color{$pkg};
|
|
}
|
|
else {
|
|
my($req, @reqs, $color);
|
|
@reqs = sort(keys %{$req{$pkg}});
|
|
@reqs = (@reqs, recurse(\%req, @reqs));
|
|
$color = "green";
|
|
foreach $req (@reqs) {
|
|
if ($color{$req} eq "red") {
|
|
return "orange";
|
|
}
|
|
elsif ($color{$req} eq "purple") {
|
|
$color = "blue";
|
|
}
|
|
}
|
|
$color;
|
|
}
|
|
}
|
|
|
|
##
|
|
## bynum - higher numbers come last
|
|
##
|
|
sub bynum {
|
|
return $num{$a} <=> $num{$b} ||
|
|
$a cmp $b;
|
|
}
|
|
|
|
##
|
|
## byord - higher orders come first
|
|
##
|
|
sub byord {
|
|
return $ord{$b} <=> $ord{$a} ||
|
|
$b cmp $a;
|
|
}
|
|
|
|
##
|
|
## order - the order of a pkg is one higher than anything below it
|
|
##
|
|
sub order {
|
|
my($n, @pkgs) = @_;
|
|
my($pkg);
|
|
foreach $pkg (@pkgs) {
|
|
$ord{$pkg} = $n if ($ord{$pkg} <= $n);
|
|
order($n + 1, sort(keys %{$req{$pkg}}));
|
|
}
|
|
}
|
|
|
|
##
|
|
## uniq - eliminate adjacent duplicate entries in an array
|
|
##
|
|
sub uniq {
|
|
my($i);
|
|
for ($i = 0; $i < $#_; ) {
|
|
if ($_[$i] eq $_[$i + 1]) {
|
|
splice(@_, $i, 1);
|
|
}
|
|
else {
|
|
$i++;
|
|
}
|
|
}
|
|
@_;
|
|
}
|
|
|
|
##
|
|
## impactof - impact of pkg delete/rebuild is the longest path (either
|
|
## up or down the tree) that encompasses all things that need
|
|
## rebuilding
|
|
##
|
|
sub impactof {
|
|
my ($impact, $pkg) = @_;
|
|
my (@in, @out);
|
|
|
|
# if we already know or it's dead-simple, get out early
|
|
return $impactof{$pkg} if (exists($impactof{$pkg}));
|
|
return $impactof{$pkg} = 0 if (color($pkg) eq "green");
|
|
|
|
# starting with the given pkg, repeatedly look up and down the
|
|
# tree for connected pkgs that also require a rebuild
|
|
@out = ($pkg);
|
|
do {
|
|
@in = @out;
|
|
@out = ($pkg);
|
|
push(@out, grep(color($_) ne "green", recurse(\%dep, @in)));
|
|
push(@out, grep(color($_) ne "green", recurse(\%req, @out)));
|
|
@out = uniq(sort(byord @out));
|
|
} while (@in != @out);
|
|
|
|
# check to see if the set of related pkgs intersects with the set
|
|
# we want to avoid and if so, mark this set as "too expensive"
|
|
$a = "";
|
|
if (@impact) {
|
|
foreach $b (@impact) {
|
|
if (grep($_ eq $b, @out)) {
|
|
$a = $b;
|
|
$impact++;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
# if we didn't hit anything, the impact is the one less than the
|
|
# highest ordered remotely connected pkg we found (the longest
|
|
# path from the top to the bottom of the set to be rebuilt)
|
|
$impact = $ord{$out[0]} - 1 if ($a eq "");
|
|
@impactof{@in} = ($impact) x @in;
|
|
|
|
$impactof{$pkg};
|
|
}
|