mirror of
https://github.com/Stichting-MINIX-Research-Foundation/pkgsrc-ng.git
synced 2025-09-12 05:52:19 -04:00
113 lines
3.2 KiB
Perl
113 lines
3.2 KiB
Perl
#! @PREFIX@/bin/perl
|
|
#
|
|
# $NetBSD: gpg2dot.pl,v 1.5 2011/01/13 00:40:09 lukem Exp $
|
|
|
|
# ----------------------------------------------------------------------------
|
|
# "THE BEER-WARE LICENSE" (Revision 42):
|
|
# Andrew Brown <atatat@NetBSD.org> and Luke Mewburn <lukem@NetBSD.org>
|
|
# wrote this file. As long as you retain this notice you can do whatever
|
|
# you want with this stuff. If we meet some day, and you think this stuff
|
|
# is worth it, you can buy us a beer in return.
|
|
# ----------------------------------------------------------------------------
|
|
|
|
#
|
|
# gpg2dot [mykey] --
|
|
# generate input for dot(1) from gpg(1) --list-sigs
|
|
# gpg http://www.gnupg.org
|
|
# dot http://www.graphviz.org/
|
|
#
|
|
|
|
$url_statistics='http://webware.lysator.liu.se/jc/wotsap/search/keystatistics?key=%s';
|
|
$url_pathfinder='http://webware.lysator.liu.se/jc/wotsap/search/paths?top=%s&bottom=%s';
|
|
|
|
$now = localtime();
|
|
$mykeyid = uc shift;
|
|
|
|
open(GPG, "gpg --list-sigs --with-colons --no-sig-cache --verbose 2>/dev/null |");
|
|
while (<GPG>) {
|
|
chomp;
|
|
my @fields = split /:/;
|
|
if ($fields[0] eq "pub" || $fields[0] eq "uid") {
|
|
if ($fields[0] eq "pub") {
|
|
($keyid, $date, $kuid) = ($fields[4], $fields[5], $fields[9]);
|
|
}
|
|
else {
|
|
next; # XXX --with-colons doesn't seem to produce uid records with useable values
|
|
($kuid) = ($fields[$9]);
|
|
}
|
|
$kuid =~ s/\"/\\\"/g;
|
|
$kuid =~ s/\\x([0-9a-fA-F]+)/chr(hex($1))/eg;
|
|
$keyid = substr($keyid, -8);
|
|
$kuid{$keyid} = $kuid;
|
|
next if ($label{$keyid} != "");
|
|
$label{$keyid} = "$keyid - $date\\n$kuid";
|
|
}
|
|
elsif ($fields[0] eq "sig") {
|
|
($skeyid, $date, $suid) = ($fields[4], $fields[5], $fields[9]);
|
|
$skeyid = substr($skeyid, -8);
|
|
next if ($suid =~ /id not found/ ||
|
|
$skeyid eq $keyid);
|
|
push(@isigs, "$keyid $skeyid $date $suid");
|
|
$sigmap{"$keyid-$skeyid"} = 1;
|
|
}
|
|
}
|
|
|
|
foreach (@isigs) {
|
|
($keyid, $skeyid, $date, $suid) = split(/ /, $_, 4);
|
|
next if (!$kuid{$keyid} || !$kuid{$skeyid});
|
|
next if ($sigmap{"$skeyid-$keyid"} == -1);
|
|
$color = "black";
|
|
$attrs = "";
|
|
if ($sigmap{"$skeyid-$keyid"}) {
|
|
if ($keyid eq $mykeyid ||
|
|
$skeyid eq $mykeyid) { # two way trust, includes me
|
|
$color = "green";
|
|
} else { # two way trust, me unevolved
|
|
$color = "blue";
|
|
}
|
|
$attrs = ",dir=\"both\"";
|
|
$sigmap{"$keyid-$skeyid"} = -1;
|
|
} elsif ($keyid eq $mykeyid) { # you trust me (one way)
|
|
$color = "orange";
|
|
} elsif ($skeyid eq $mykeyid) { # i trust you (one way)
|
|
$color = "red";
|
|
}
|
|
push(@sigs, sprintf("\"%s\" -> \"%s\"[tailURL=\"%s\",headURL=\"%s\",color=\"%s\"%s];\t// %s -> %s\n",
|
|
$skeyid, $keyid,
|
|
sprintf($url_pathfinder, $keyid, $skeyid),
|
|
sprintf($url_pathfinder, $skeyid, $keyid),
|
|
$color, $attrs,
|
|
$kuid{$skeyid}, $kuid{$keyid}));
|
|
$signer{$skeyid} = "yes";
|
|
$signed{$keyid} = "yes";
|
|
}
|
|
|
|
foreach (keys %label) {
|
|
next if (!$signer{$_} && !$signed{$_});
|
|
push(@keys, sprintf("\"%s\" [URL=\"%s\",label=\"%s\",shape=\"box\"];\n",
|
|
$_, sprintf($url_statistics, $_), $label{$_}));
|
|
}
|
|
|
|
@sigs = uniq(sort(@sigs));
|
|
|
|
$" = "";
|
|
print(<<"EOF")
|
|
digraph "gpg" {
|
|
label = "gpg signature graph, $now";
|
|
|
|
@keys
|
|
@sigs
|
|
}
|
|
EOF
|
|
;
|
|
|
|
sub uniq {
|
|
my (@i) = @_;
|
|
my (@o);
|
|
push(@o, shift(@i));
|
|
foreach (@i) {
|
|
push(@o, $_) if ($o[-1] ne $_);
|
|
}
|
|
@o;
|
|
}
|