initial commit

3 files changed, 809 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0cadd13
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,16 @@
+1
+1.*
+2
+2.*
+3
+3.*
+a
+b
+c
+d
+e
+foo
+bar
+baz
+*~
+*.bak
diff --git a/README b/README
new file mode 100644
index 0000000..8cc1d0f
--- /dev/null
+++ b/README
@@ -0,0 +1,27 @@
+Greypool - a repology.org maintainer status tool
+
+Greypool uses the repology.org JSON API to check for outdated
+packages in repositories checked by repology.org. It works with any
+repository, though it's mainly been tested with the "slackbuilds"
+(SlackBuilds.org) repo.
+
+It's written in Perl, and designed to use as few external Perl modules
+as possible. Currently it requires:
+
+- Either JSON::PP or (preferred) JSON::XS
+- POSIX
+- Getopt::Long
+
+Also, wget is required.
+
+On first run, you'll be prompted for an email address and a repository.
+This is saved in the config file.
+
+Output is a report either as plain text (with or without ANSI color),
+comma-separated values (CSV), or HTML.
+
+Greypool complies with repology.org's API guidelines. To avoid excessive
+requests, the API responses are cached for 24 hours.
+
+Greypool was written by B. Watson <urchlay@slackware.uk>, and is
+released under the WTFPL.
diff --git a/greypool b/greypool
new file mode 100755
index 0000000..c3b761b
--- /dev/null
+++ b/greypool
@@ -0,0 +1,766 @@
+#!/usr/bin/perl -w
+
+# https://repology.org/api/v1
+
+# TODO:
+# - interactive config (just ask for email and repo).
+# - implement mask
+# - style the HTML somewhat.
+# - log file?
+# - CSV output
+
+# This stuff is so we can run (slowly) on a stock Slackware
+# install. With JSON::PP, it takes 0.9 sec to parse one JSON
+# file from repology that contains 200 of my builds... but I
+# have over 1000 builds. Most of you, it's going to run
+# faster than that with PP.
+BEGIN {
+	($SELF = $0) =~ s,.*/,,;
+	eval { require JSON::XS; JSON::XS->import(); }; # can we go fast?
+	if($@) {
+		warn "$SELF: JSON::XS not available, falling back to JSON::PP (slow!)\n";
+		eval { require JSON::PP; JSON::PP->import(); };
+		if($@) {
+			# should never happen on Slackware:
+			die "$SELF: couldn't load either JSON::XS or JSON::PP\n";
+		}
+	}
+}
+
+use Getopt::Long;
+use POSIX 'strftime';
+use feature 'unicode_strings';
+
+$VERSION = "0.0.0";
+$verbose = $force = $html = 0;
+$stamp = strftime("%Y%m%d", localtime);
+
+# all the parsed data gets shoved in here.
+# keys are visiblename of each project.
+# values are another hash, with keys projname (repology's name for
+# the project), oldver (our outdated version), newver (repology's
+# reported "newest" version(s)).
+%report = ();
+
+# TODO: make this configurable
+$user_agent = 'Mozilla/5.0 (compatible; greypool-repology-bot/1.0; +https://github.com/SlackBuildsOrg/slackbuilds)';
+
+sub warning {
+	warn "$SELF: warning: " . join(" ", @_). "\n";
+}
+
+sub fatal {
+	die "$SELF: fatal: " . join(" ", @_). "\n";
+}
+
+sub info {
+	return unless $verbose;
+	warn "$SELF: " . join(" ", @_). "\n";
+}
+
+sub read_file {
+	undef local $/;
+	local @ARGV = shift;
+	$_ = <>;
+}
+
+sub parse_opts {
+	Getopt::Long::Configure("bundling");
+	GetOptions(
+		"verbose|v" => \$verbose,
+		"force|f" => \$force,
+		"html|h" => \$html,
+		"html-fragment|H" => \$html_frag,
+		"csv|s" => \$csv_output,
+		"version|V" => sub { print "$VERSION\n"; exit 0; },
+		"doc|help" => sub { exec("perldoc $0"); },
+		"man" => sub { exec("pod2man --stderr -s1 -cgreypool -r$VERSION $0"); },
+		"color|colour|c" => \$color_output,
+		"mono|no-color|no-colour|m" => sub { $color_output = 0; },
+		"config-dir|C=s" => \$privdir,
+	) or fatal("error in command line options (try --help).");
+
+	$html = 1 if $html_frag;
+	$html = 0 if $csv_output;
+
+	$email = shift @ARGV;
+	fatal "extra junk on the command line after '$email'" if @ARGV;
+
+	$color_output = -t STDOUT unless defined $color_output;
+	$privdir = $ENV{HOME} . "/.greypool/" unless defined $privdir;
+	$config_file = $privdir . "/config";
+}
+
+# perl replacement for shell's "mkdir -p".
+# no error checking at all, but that's fine, the caller will know it
+# failed when it tries to *use* the directory that didn't get created.
+sub mkdir_p {
+	for(@_) {
+		my $path;
+		for my $d (split /\//) {
+			$path .= "$d/";
+			-d $path || mkdir $path;
+		}
+	}
+}
+
+# the API doesn't seem to have a way to just get a list of repos
+# from repology, so this does traditional HTML scraping. Yuck.
+sub get_repo_list {
+	print "Getting repo list\n";
+	open my $f,
+		"wget -qO- --user-agent '$user_agent' " .
+		'https://repology.org/repositories/statistics' .
+		'|';
+	while(<$f>) {
+		if(m,<a\s*href="/repository/([^"/]+)">([^<]+)</a>,) {
+			$repo_list{$1} = $2;
+		}
+	}
+	close $;
+}
+
+sub show_repo_list {
+	get_repo_list() unless %repo_list;
+	print "$_ ($repo_list{$_})\n" for sort keys %repo_list;
+}
+
+sub prompt {
+	(my $p, $d) = @_;
+	chomp $p;
+	(local $|)++;
+	print $p;
+	print " [$d]" if $d;
+	print "? ";
+	my $resp = <>;
+	chomp $resp;
+	$resp = $d if $resp eq '' && defined $d;
+	return $resp;
+}
+
+sub create_default_config {
+	if(! (-t STDOUT && -t STDIN) ) {
+		fatal "$config_file doesn't exist; run without redirection to create\n";
+	}
+
+	print "$config_file doesn't exist; creating new.\nPress ^C to abort.\n\n";
+
+	my $ok;
+	while(!$ok) {
+		$email = prompt("Your email address", $email);
+		redo if $email =~ /^\s*$/;
+		show_repo_list();
+		$repo = prompt("What repo is this config file for", $repo);
+		redo if $repo =~ /^\s*$/;
+		my $yn = prompt(<<EOF, "Y");
+
+Email address: $email
+Repository:    $repo
+
+Is this correct
+EOF
+		$ok = 1 if ($yn =~ /\s*y/i);
+		print "\n";
+	}
+
+	$pfmt = 'pkgurl https://slackbuilds.org/repository/15.0/$NAME/';
+	if($repo ne 'slackbuilds') {
+		$pfmt = '# ' . $pfmt;
+	}
+
+	mkdir_p($privdir);
+
+	open my $f, ">$config_file" or fatal "$config_file: $!";
+	print $f <<EOF;
+# Config file for greypool.
+
+# See the greypool man page or --help output for more information.
+
+# Comments and whitespace can be used freely here, including on
+# the same line as a setting. Example:
+
+#email me\@myhouse.com # my fake email address.
+
+# Settings
+##########
+
+# Optional but recommended: Your email address (as seen by
+# repology). This can be overridden on the command line, to check
+# someone else's packages. If you don't set this here, you'll have to
+# pass it as an argument to greypool every time you run it.
+email $email
+
+# Required: The repository you want to check (repology's name for it).
+# Only one allowed, and no way to override on the command line. If you
+# need to check multiple repos, use multiple config directories and
+# the -C option.
+repo $repo
+
+# Optional: List any packages you don't want to check for updates here.
+# They can be any mix of one per line, or multiple per line.
+#ignore evince
+#ignore yar calf-ladspa
+
+# Optional: List any bad versions of packages you don't want to update
+# to here. One line per package, multiple versions per line allowed.
+#mask srecord 1.65
+
+# Optional: Format string for package URLs. These are the "local" package
+# names (what your repository calls them, not repology's name).
+# The string \$NAME will be replaced by the package name (globally).
+# If this is not set, the package names won't by clickable links.
+# NOTE: For SlackBuilds.org, the URL *must* end in a trailing slash!
+$pfmt
+EOF
+
+	$yn = prompt("Config file created. Check package status now", "Y");
+	unless($yn =~ /^\s*y/i) {
+		print "\nOK. Run $SELF again when you're ready to check package status.\n";
+		exit 0;
+	}
+}
+
+sub parse_mask {
+	(my $pkg, @versions) = split /\s+/, $_[0];
+	fatal "$config_file:$.: no versions listed for 'mask'" unless @versions;
+	$masked{$pkg} = \@versions if @versions;
+}
+
+sub read_config_file {
+	create_default_config() unless -e $config_file;
+	info "reading config from $config_file";
+
+	open my $f, "<$config_file" or fatal $!;
+
+	while(<$f>) {
+		chomp;
+		s/#.*//;         # remove comments
+		next if /^\s*$/; # skip blanks
+		s/^\s+//;        # trim leading whitespace
+		s/\s+$//;        # trim trailing whitespace
+
+		(my $key, $val) = split /\s+/, $_, 2;
+		fatal "$config_file line $. malformed (no spaces)" unless defined $val;
+
+		for(lc $key) {
+			my $ok;
+			/email/  && do { $ok++; $email = $val unless defined $email; };
+			/repo/   && do { $ok++; $repo  = $val;                       };
+			/pkgurl/ && do { $ok++; $pkgurl  = $val;                     };
+			/ignore/ && do { $ok++; $ignore{$_}++ for split /\s+/, $val; };
+			/mask/   && do { $ok++; parse_mask($val);                    };
+			fatal "$config_file line $. malformed (unknown key '$_')" unless $ok;
+		}
+	}
+	close $f;
+
+	fatal "no email given on the command line or in the config file"
+		unless defined $email;
+
+	fatal "no repo set in the config file" unless defined $repo;
+
+	$cachedir = $privdir . "/cache/$email";
+	$cachestampfile = $cachedir . "/stamp";
+
+	if($verbose) {
+		warn <<EOF;
+config summary:
+cachedir: $cachedir
+   email: $email
+    repo: $repo
+EOF
+		my $i = join(" ", keys %ignore);
+		warn " ignored: $i \n" if $i;
+		for(keys %masked) {
+			warn "  masked $_ versions: " . join(",", @{$masked{$_}}) . "\n";
+		}
+	}
+}
+
+sub decode_file {
+	$_ = shift;
+
+	info("decoding JSON file $_");
+
+	eval {
+		$j = decode_json(read_file($_));
+	};
+
+	fatal "failed to decode JSON: $@" if $@;
+}
+
+sub get_cache_filename {
+	return $cachedir . "/" . $_[0] . ".json";
+}
+
+sub parse_file {
+	my $filenum = shift;
+	my $file = get_cache_filename($filenum);
+	decode_file($file);
+
+	my $lastpkg = "";
+	my $firstpkg;
+
+	my $count = 0;
+	for $proj (keys %{$j}) {
+		$count++;
+		$firstpkg = $proj unless defined $firstpkg;
+		$lastpkg = $proj if $proj gt $lastpkg;
+		my $arr = $$j{$proj};
+		my $newest;
+		for my $hr (@{$arr}) {
+			my($status, $version) = @$hr{qw/status version/};
+
+			# *anyone's* newest version.
+			if($status eq 'newest') {
+				$newest = $version;
+				last;
+			}
+
+			# FIXME: what about the other statuses? repology has:
+			# newest, devel, unique, outdated, legacy, rolling,
+			# noscheme, incorrect, untrusted, ignored.
+		}
+		for my $hr (@{$arr}) {
+			my($status, $r_repo, $name, $version) =
+				@$hr{qw/status repo visiblename version/};
+
+			if($r_repo eq $repo && $status eq 'outdated') {
+				if(!defined($ignore{$proj}) && !defined($ignore{$name})) {
+					my %item = (
+						projname => $proj,
+						oldver   => $version,
+						newver   => $newest);
+					$report{$name} = \%item;
+					last;
+				}
+			}
+		}
+	}
+
+	info "$count entries in file, last package $lastpkg\n";
+	return $lastpkg eq $firstpkg ? undef : $lastpkg;
+}
+
+# do our own URL escaping to avoid depending on an external module.
+# based on: https://en.wikipedia.org/wiki/URL_escaping
+# ...and also the perldoc for URI::Escape
+# neither of these mentions the blindingly obvious fact that the %
+# character itself has to be escaped.
+# % ! # $ & ' ( ) * + , / : ; = ? @ [ ]
+sub url_escape {
+	my $s = shift;
+	$s =~ s{[^-.0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz]}{sprintf("%%%x", ord($&))}ge;
+	return $s;
+}
+
+sub cache_ok {
+	return 0 unless -e $cachestampfile;
+	my $oldstamp = read_file($cachestampfile);
+	chomp($oldstamp);
+	#warn "stamp $stamp, oldstamp $oldstamp";
+	return $stamp eq $oldstamp;
+}
+
+sub stamp_cache {
+	open my $f, ">$cachestampfile" or fatal $!;
+	print $f $stamp;
+	close $f;
+}
+
+sub check_cache {
+	system("mkdir -p $cachedir");
+	return if cache_ok();
+	for(<$cachedir/*>) {
+		unlink $_;
+	}
+}
+
+# wget -O repo3.json --user-agent Ruby 'https://repology.org/api/v1/projects/doomseeker/?maintainer=urchlay%40slackware.uk&status=outdated&repo=slackbuilds'
+sub make_api_url {
+	my $lastpkg = shift;
+	my $url = "https://repology.org/api/v1/projects/";
+	$url .= "$lastpkg/" if defined $lastpkg;
+	$url .= "?maintainer=";
+	$url .= url_escape($email);
+	$url .= "&status=outdated&repo=";
+	$url .= url_escape($repo);
+}
+
+sub download {
+	my $url = make_api_url(shift);
+	my $num = shift;
+
+	my $filename = $cachedir . "/" . $num . ".json";
+	if(!$force && (-e $filename)) {
+		info "$filename found in cache, not downloading";
+		return;
+	}
+
+	my $qopt = $verbose ? "" : "-q";
+
+	my $cmd =
+		"wget " .
+		"$qopt " .
+		"-O $filename " .
+		"--user-agent '$user_agent' " .
+		"'$url'";
+
+	info $cmd;
+	system($cmd);
+}
+
+sub generate_report {
+	my $filecount = 1;
+	my $lastpkg = "NONE"; # don't use undef
+
+	# we can't really download all the json files, then parse them
+	# all after downloading: to know how to get the 2nd one, you have
+   # to parse the first one to get the last (lexicallly greatest)
+   # package name.
+	while(defined $lastpkg) {
+		download($lastpkg, $filecount);
+		$lastpkg = parse_file($filecount++);
+	}
+
+	print_report_header();
+	my $count = 0;
+	if(!keys %report) {
+		print_empty_report();
+	} else {
+		print_table_start();
+		for(sort keys %report) {
+			$count++;
+			print_report_line($_);
+		}
+		print_table_end();
+	}
+	print_report_footer($count);
+}
+
+####### report printing stuff
+
+sub print_report_header {
+	return if $csv_output;
+	return if $html_frag;
+	print "<html><head><title>\n" if $html;
+	print "Repology status report for $email ($repo repository)\n\n";
+	print "</title></head>\n<body>\n" if $html;
+}
+
+sub print_empty_report {
+	return if $csv_output;
+	print "All packages up to date.\n";
+}
+
+sub print_table_start {
+	if($html) {
+		print "Repology status report for $email ($repo repository)<p />\n";
+		print "<table><tr><th>Package</th><th>Version</th><th>Newest Version</th></tr>\n";
+	} elsif($csv_output) {
+		print "Package,RepologyName,Version,Newest\n";
+	} else {
+		printf("%-30s", "Package");
+		printf("%24s", "Version");
+		printf("%24s", "Newest");
+		print "\n" . ("-" x 79) . "\n";;
+	}
+}
+
+sub print_report_line {
+	my $name = shift;
+
+	my $hr = $report{$name};
+	my $projname = $hr->{projname};
+	my $oldver = $hr->{oldver};
+	my $newver = $hr->{newver} || "???";
+
+	if($html) {
+		my $nlink;
+		if($pkgurl) {
+			(my $target = $pkgurl) =~ s,\$NAME,$name,g;
+			$nlink = "<a href=\"$target\">$name</a>";
+		} else {
+			$nlink = $name;
+		}
+		my $pnlink = "<a href=\"https://repology.org/project/$projname/versions\">$projname</a>";
+		print "<tr><td>$nlink => $pnlink</td><td>$oldver</td><td>$newver</td></tr>\n";
+	} elsif($csv_output) {
+		print "$name,$projname,$oldver,$newver\n";
+	} else {
+		my $w2 = 24;
+		if(length($name) > 30) {
+			$w2 = 24 - ((length($name)) - 30);
+		}
+		printf("%-30s", $name);
+		red(sprintf("%${w2}s", $oldver));
+		print " ";
+		green(sprintf("%24s", $newver));
+		print "\n";
+	}
+}
+
+sub print_table_end {
+	print "</table>\n" if $html;
+}
+
+sub print_report_footer {
+	return if $csv_output;
+	my $count = shift;
+	if($count) {
+		print "<br />" if $html;
+		print $count . " package" . ($count == 1 ? "" : "s") . " out of date.\n";
+		print "<p />" if $html;
+	}
+	print "</body></html>" if $html && (!$html_frag);
+}
+
+####### ANSI color stuff
+sub red {
+	colorize(1, @_);
+}
+
+sub green {
+	colorize(2, @_);
+}
+
+sub colorize {
+	my $color = shift;
+	print "\x1b[01;3${color}m" if $color_output;
+	print for @_;
+	print "\x1b[0m" if $color_output;
+}
+
+### main()
+
+parse_opts();
+read_config_file();
+check_cache();
+generate_report();
+stamp_cache();
+
+__END__
+
+=pod
+
+=head1 NAME
+
+greypool - check for outdated packages using repology.org API
+
+=head1 SYNOPSIS
+
+B<greypool> [--help | --man | --version] | [-options] [I<email-address>]
+
+=head1 DESCRIPTION
+
+B<greypool> uses repology.org's JSON API to check for outdated
+distribution packages by a particular maintainer.
+
+To avoid excessive traffic to the repology.org server, the JSON files
+are cached locally, and will only be re-downloaded after 24 hours.
+
+Output is a report, either plain text (possibly with ANSI color) or
+HTML. In either case, the report is printed to standard output.
+
+The report is a table, where each row lists the package name, the
+current version, and the newest version according to repology. If
+the latter is B<???>, that means repology knows the package is outdated,
+but no other distro has packaged the newest version. In the HTML
+report, repology's name for the package is also shown, as a
+clickable link that goes to the "versions" page for the package.
+
+=head1 OPTIONS
+
+Bundling options is supported, e.g. B<-qf> is the same as B<-q -f>.
+
+=over 4
+
+=item B<-c>, B<--color>, B<--colour>
+
+Colorize the output. For HTML output, this is already the default. For
+plain text, the default is to colorize only if standard output is a
+tty device (e.g. not redirected to a file).
+
+=item B<-m>, B<--mono> B<--no-color>, B<--no-colour>
+
+Do no colorize the output, even if stdout is a terminal. This also
+produces monochrome HTML pages, with the B<-h> / B<--html> option.
+
+=item B<-C>, B<--config-dir> I<directory>
+
+Use a directory other than I<~/.greypool/> for the config file, logs,
+and cache. This directory will be created (with a default all-comments
+config file) if it doesn't already exist.
+
+=item B<-f>, B<--force>
+
+Re-download the JSON files, even if we have a cached copy less than
+24 hours old. Use this option with caution: excessive requests to the
+repology.org server may cause the server to block your IP address.
+
+=item B<-h>, B<--html>
+
+Generate report as an HTML page, rather than the default plain text.
+The HTML output is kinda rough-looking, because the B<greypool> author
+is not a web designer and doesn't want to be one.
+
+=item B<-H>, B<--html-fragment>
+
+Like B<--html>, but I<just> the HTML table (no header, body tag, etc).
+Suitable for embedding in another HTML page.
+
+=item B<-C>, B<--csv>
+
+Comma-separated value output. The first line is a "header" with the
+field names; the rest of the output is one line per package. This
+would fail if someone put a comma in a version number... I<*shrug*>
+
+=item B<-v>, B<--verbose>
+
+Print informational messages about what B<greypool> is doing,
+including the B<wget>(1) progress bar during downloads. Messages go
+to standard error outpu.
+
+=item B<-V>, B<--version>
+
+Print B<greypool> version and exit.
+
+=item B<--help>
+
+Display documentation using your pager.
+
+=item B<--man>
+
+Format documentation as a man page (troff), print to standard output.
+
+=back
+
+=head1 CONFIG FILE
+
+The config file is located at B<~/.greypool/config>. If it doesn't
+exist, B<greypool> will create it, with commented-out examples.
+
+The config syntax is simple. Comments and whitespace are allowed in
+the usual way, and each non-comment line consists of a key, followed
+by one or more values. If there are multiple values, separate them
+with spaces.
+
+=head2 Config file keys
+
+=over 4
+
+=item B<repo>
+
+Limit the search to one specific repository. This key is required,
+and there's no command-line option to override it.
+
+This key can only have one value, and can only occur once in the
+config file.
+
+If you maintain packages for more than one distribution, you'll
+have to create separate config directories for each one, and call
+B<greypool> with the B<--config-dir> or B<-C> option.
+
+=item B<email>
+
+The default email address to use, if one isn't provided on the
+command line. This key can only have one value, and can only
+occur once in the config file.
+
+If no email address is set in the config file, you must give an
+address on the command line. If not, B<greypool> will exit with error
+status.
+
+Example:
+
+    email urchlay@slackware.uk
+
+=item B<ignore>
+
+This key can have multiple values, and can occur multiple times. Use
+it to list packages whose status you don't want to check. Examples would
+be projects that have upstream version updates available, but the
+newer versions can't be built on the latest stable release of your OS
+due to outdated libraries.
+
+Examples:
+
+    # evince can't be updated on Slackware 15.0
+    ignore evince
+
+    # gstreamer plugins must match the version of gstreamer
+    # included in Slackware
+    ignore gst-plugins-bad-nonfree
+
+Note that the above could also be written as:
+
+    ignore evince gst-plugins-bad-nonfree
+
+=item B<mask>
+
+This key can occur multiple times, and must have at least two values.
+Use it to pretend a particular version of a project doesn't exist.
+
+Example:
+
+    # version 1.65 of srecord doesn't ship any documentation at all
+    mask srecord 1.65
+
+Multiple versions can be listed on one mask line:
+
+    mask somepackage 1.2 1.3 1.4
+
+=item B<pkgurl>
+
+Optional. When generating HTML output, if this is set, the distro
+package names in the HTML will be clickable links that go to the
+distro's web page for that package... provided you set the value
+correctly! The string B<$NAME> will be replaced with the package
+name. Note that these are "your" names, not repology's.
+
+Example:
+
+    pkgurl https://slackbuilds.org/repository/15.0/$NAME/
+
+=back
+
+=head1 NOTES
+
+=head2 Required Perl Modules
+
+If you get this error message on startup:
+
+    greypool: couldn't load either JSON::XS or JSON::PP
+
+...then you should install your OS's package for the JSON::XS perl module.
+On Slackware, this is B<perl-JSON-XS> from SlackBuilds.org. For other
+distributions, repology.org will tell you:
+
+    https://repology.org/project/perl%3Ajson-xs/versions
+
+You will also need the B<POSIX> perl module, which is usually bundled
+with the main perl package, and the B<Getopt::Long> module which
+is bundled on some distributions. See:
+
+    https://repology.org/projects/?search=perl%3Agetopt-long
+
+=head2 External Binaries
+
+B<greypool> uses B<wget>(1) to talk to the repology.org API. This is a
+deliberate design choice, to avoid the long chain of perl dependencies
+required for libwww-perl.
+
+=head1 AUTHOR
+
+B. Watson <urchlay@slackware.uk>, aka Urchlay on Libera IRC.
+
+=head1 LICENSE
+
+B<greypool> is licensed under the WTFPL. See
+http://www.wtfpl.net/txt/copying/ for details.
+
+=head1 SEE ALSO
+
+The repology.org API documentation: https://repology.org/api/v1
+
+=cut