path: root/perlupd

#!/usr/bin/perl -w

# Keep this at the top of the file for easy editing.
# Most perl packages, it's obvious how to derive the CPAN module name
# from the Slackware package name. The ones that aren't, list here:
# 'CPAN' => 'SBo',
%overrides = (
	'Graph::Easy' => 'graph-easy',
	'App::Tarotplane' => 'tarotplane',
	'EBook::Ishmael' => 'ishmael',
	'Alien::Build::Plugin::Download::GitLab' => 'Download-GitLab',
	'IO::Stringy' => 'perl-IO-stringy',
	'MIME::Tools' => 'perl-MIME-tools',
	'Perl::Tidy' => 'perl-Perl-Tidy',
	'Socket::GetAddrInfo', 'perl-Socket-GetAddrinfo',
	'Tree::DAG_Node' => 'perl-tree-dagnode',
	'Linux::DesktopFiles' => 'perl-linux-desktop-files',
	'App::sbozyp' => 'sbozyp',
	'App::rename' => 'rename.pl',
	'LWP' => 'libwww-perl',
	'Locale::Messages' => 'perl-libintl',
	'CDDB_get' => 'perl-CDDB-get',
	'Perl::Tidy' => 'perl-Tidy',
	'Number::Bytes::Human' => 'perl-Number-Bites-Human',
);

# these seem to have been removed from CPAN, or anyway they don't
# show up in 02packages.details.txt.gz.
#'perl-Sys-CPU',
#'perl-Time-modules',
#'perl-Cstools',
#'perl-Meta-Requirements-Range',

($SELF = $0) =~ s,.*/,,;

if(@ARGV && $ARGV[0] eq '--help') {
	print <<EOF;
$SELF - Find outdated SBo perl packages for a given maintainer.

Usage: $SELF <maintainer | -a | -o>

Options:
  -a   Show all maintainers.
  -o   Show only orphaned builds.

The maintainer is the MAINTAINER name *or* email address from the
.info files. Note that you don't have to quote the name if it contains
spaces (though you do, if it has other shell metacharacters).

If no maintainer is given, then environment variable SBO_EMAIL is
used. If this isn't set, the program exits with error status.

If the environment variable SBO_GITROOT is set, it's used to find
the .info files. It should be set to the directory that contains the
categories (e.g. academic/ system/ office/). If it's not set, the
current directory is used.

Only packages whose .info files list https://cpan.metacpan.org
downloads are checked. Up-to-date packages are not listed, except for
ones with "weird" version numbers (see below).

Output looks something like this:

\$ $SELF
perl-http-tiny: ver 0.082, avail 0.096  https://cpan.metacpan.org/authors/id/H/HA/HAARG/HTTP-Tiny-0.096.tar.gz
perl-inc-module-install: ver 1.19, avail 1.21  https://cpan.metacpan.org/authors/id/E/ET/ETHER/Module-Install-1.21.tar.gz
perl-Cstools: can't get new version from CPAN info
=== 10 builds: 7 up to date, 2 outdated, 1 unknown.

The "can't get new version" error message above can be caused by
obsolete modules being removed from the CPAN index, or this script's
failure to map CPAN module name to the SBo build name. Sorry about that.

Written by B. Watson <urchlay\@slackware.uk>, licensed under the WTFPL.
EOF
	exit 0;
}

if(@ARGV) {
	$EMAIL = join(" ", @ARGV);
} else {
	$EMAIL = $ENV{SBO_EMAIL};
	if(not defined $EMAIL) {
die <<EOF;
$SELF: you must provide a maintainer name/email either on the command
line or in the variable SBO_EMAIL. Try --help.
EOF
	}
}
$EMAIL = 'NOEMAIL' if $EMAIL eq '-o';
$EMAIL = '' if $EMAIL eq '-a';

$PKGFILE = "02packages.details.txt.gz";
$CACHEDIR = "$ENV{HOME}/.cpan/sources/modules";
$CACHE = "$CACHEDIR/$PKGFILE";
$CACHE_MAX = (12 * 60 * 60); # seconds (aka 1/2 day)

$URL =  "https://www.cpan.org/modules/$PKGFILE";
$BASE = "https://cpan.metacpan.org/authors/id/";

if(defined ($SBO_GITROOT = $ENV{SBO_GITROOT})) {
	chdir($SBO_GITROOT) || die "can't cd to $SBO_GITROOT: $!\n";
} elsif(! (-d "academic/" && -d "system/" && -d "desktop/") ) {
	die "SBO_GITROOT not set, and current dir doesn't look like the SBo repo!\n";
}

# Download the $CACHE file if it doesn't exist, or if it's more than
# CACHE_MAX secondsold. Notice, it's stored in the same place cpan
# stores it, so it might already be up to date from using cpan.
# As of October 2026, this is a 2.5MB download.
if(! -e $CACHE || (file_age($CACHE) > $CACHE_MAX)) {
	system("mkdir -p $CACHEDIR");
	system("wget -O$CACHE $URL");
	die "$CACHE didn't download\n" unless -e $CACHE;
}

open $pipe, "gzip -d < $CACHE |" || die "can't read $CACHE: $!\n";

while(<$pipe>) {
	chomp;
	last if /^$/;
}
while(<$pipe>) {
	chomp;
	my($mod, $ver, $path) = split /\s+/;
	next if $ver eq 'undef';

	$ver =~ s,^v(\d),$1,; # v1.2.3 => 1.2.3
	my $pkg = $overrides{$mod};

	$mod =~ s,::,-,g;
	if(not defined $pkg) {
		$pkg = "perl-$mod";
	}

	# $mod is e.g. Foo-Bar
	$versions{$mod} = $ver;
	$paths{$mod} = $path;
	$versions{$mod} = $ver;
	$paths{$mod} = $path;
	# $pkg is now e.g. perl-Foo-Bar
	$versions{$pkg} = $ver;
	$paths{$pkg} = $path;
	$pkg = lc $pkg;
	# $pkg is now e.g. perl-foo-bar
	$versions{$pkg} = $ver;
	$paths{$pkg} = $path;
}
close $pipe;

open $pipe, "git grep -Fl '$EMAIL' '*/*/*.info' |" || die "can't get .info files: $!";

$count = $unknown = $outdated = $uptodate = 0;
while(<$pipe>) {
	chomp;
	my(undef, $pkg, undef) = split /\//;
	my ($ver, $dl) = get_info_ver($_);

	next unless defined $ver;
	$count++;
	my $newver = $versions{$pkg};

	if(not defined $newver) {
		if(not defined($newver = $versions{'App-'. $pkg})) {
			print "$pkg: can't get new version from CPAN info\n";
			$unknown++;
			next;
		}
	}

	if($ver ne $newver) {
		if(same_version($ver, $newver)) {
			print "$pkg: up to date, versions '$ver' and '$newver' considered equal\n";
		} else {
			print "$pkg: outdated $ver, avail $newver  $BASE$paths{$pkg}\n";
			$outdated++;
			next;
		}
	}

	$uptodate++;
}

close $pipe;

print <<EOF;
=== $count builds: $uptodate up to date, $outdated outdated, $unknown unknown
EOF

exit($outdated != 0);

# return undef for a non-metacpan source
sub get_info_ver {
	my $info = shift;
	my ($ver, $dl);

	open my $fh, "<", $info or die "can't open $info: $!\n";
	my $cpan = 0;
	while(<$fh>) {
		if(/^VERSION="([^"]+)"/) {
			$ver = $1;
		} elsif(/^DOWNLOAD="([^"\s]+)/) {
			$dl = $1;
		}
		$cpan++ if /cpan\.metacpan\.org/;
	}
	close $fh;
	return $cpan ? ($ver, $dl) : (undef, undef);
}

sub file_age {
	my @s = stat($_[0]);
	return time - $s[9]; # mtime; perldoc -f stat
}

sub same_version {
	my ($old, $new) = @_;
	my ($maybe, @a) = split /\./, $old;
	$maybe .= ".";
	for(@a) {
		$maybe .= sprintf("%03d", $_);
	}
	return $new eq $maybe;
}