summaryrefslogtreecommitdiffstats
path: root/scripts/deb-why-removed.pl
diff options
context:
space:
mode:
Diffstat (limited to 'scripts/deb-why-removed.pl')
-rwxr-xr-xscripts/deb-why-removed.pl251
1 files changed, 251 insertions, 0 deletions
diff --git a/scripts/deb-why-removed.pl b/scripts/deb-why-removed.pl
new file mode 100755
index 0000000..ba6635f
--- /dev/null
+++ b/scripts/deb-why-removed.pl
@@ -0,0 +1,251 @@
+#!/usr/bin/perl
+#
+# Copyright © 2017-2019 Guillem Jover <guillem@debian.org>
+#
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+use strict;
+use warnings;
+
+use File::Basename;
+use File::Path qw(make_path);
+use File::Copy qw(cp);
+use File::Spec;
+use Getopt::Long qw(:config posix_default no_ignorecase);
+use HTTP::Tiny;
+use Dpkg::Index;
+use Devscripts::Output;
+
+my $VERSION = '0.0';
+my ($PROGNAME) = $0 =~ m{(?:.*/)?([^/]*)};
+
+my %url_map = ('debian' => 'https://ftp-master.debian.org/removals-full.822');
+my $default_url_origin = 'debian';
+
+#
+# Functions
+#
+
+sub version {
+ print "$PROGNAME $VERSION (devscripts ###VERSION###)\n";
+}
+
+sub usage {
+ print <<HELP;
+Usage: $PROGNAME [<option>...] <package>...
+
+Options:
+ -u, --url URL URL to the removals deb822 file list (defaults to
+ <$url_map{$default_url_origin}>).
+ --no-refresh Do not refresh the cached removals file even if old.
+ -h, -?, --help Print this help text.
+ --version Print the version.
+HELP
+}
+
+# XXX: DAK produces broken output, fix it up here before we process it.
+#
+# The two current bogus instances are, at least two fused paragraphs, and
+# bogus "sh: 0: getcwd() failed: No such file or directory" command output
+# interpersed within the file.
+sub fixup_broken_metadata {
+ my $cachefile = shift;
+ my $para_sep = 1;
+
+ open my $fh_old, '<', $cachefile
+ or ds_error("cannot open cache file $cachefile for fixup");
+ open my $fh_new, '>', "$cachefile.new"
+ or ds_error("cannot open cache file $cachefile.new for fixup");
+ while (my $line = <$fh_old>) {
+ if ($line =~ m/^\s*$/) {
+ $para_sep = 1;
+ } elsif (not $para_sep and $line =~ m/^Date:/) {
+ # XXX: We assume each paragraph starts with a Date: field, and
+ # inject the missing newline.
+ print {$fh_new} "\n";
+ } else {
+ $para_sep = 0;
+ }
+
+ # XXX: Fixup shell output detritus.
+ if ($line =~ s/sh: 0: getcwd\(\) failed: No such file or directory//) {
+ # Remove the trailing line so that the next line gets folded back
+ # into this one.
+ chomp $line;
+ }
+
+ print {$fh_new} $line;
+ }
+ close $fh_new or ds_error("cannot write cache file $cachefile.new");
+ close $fh_old;
+
+ # Preserve the original mtime so that mirroring works.
+ my ($atime, $mtime) = (stat $cachefile)[8, 9];
+ utime $atime, $mtime, "$cachefile.new";
+
+ rename "$cachefile.new", $cachefile
+ or ds_error("cannot replace cache file with fixup version");
+}
+
+sub cache_file {
+ my ($url, $cachefile) = @_;
+
+ cp($url, $cachefile) or ds_error("cannot copy removal metadata: $!");
+ fixup_broken_metadata($cachefile);
+}
+
+sub cache_http {
+ my ($url, $cachefile) = @_;
+
+ my $http = HTTP::Tiny->new(verify_SSL => 1);
+ my $resp = $http->mirror($url, $cachefile);
+
+ unless ($resp->{success}) {
+ ds_error(
+ "cannot fetch removal metadata: $resp->{status} $resp->{reason}");
+ }
+
+ if ($resp->{status} != 304) {
+ fixup_broken_metadata($cachefile);
+ }
+}
+
+#
+# Main program
+#
+
+my $opts;
+
+GetOptions(
+ 'url|u=s' => \$opts->{'url'},
+ 'no-refresh' => \$opts->{'no-refresh'},
+ 'help|h|?' => sub { usage(); exit 0 },
+ 'version' => sub { version(); exit 0 },
+ )
+ or die "\nUsage: $PROGNAME [<option>...] <package>...\n"
+ . "Run $PROGNAME --help for more details.\n";
+
+unless (@ARGV) {
+ ds_error('need at least one package name as an argument');
+}
+
+my $url = $opts->{url} // $default_url_origin;
+$url = $url_map{$url} if $url_map{$url};
+
+my $cachehome = $ENV{XDG_CACHE_HOME};
+$cachehome ||= File::Spec->catdir($ENV{HOME}, '.cache') if length $ENV{HOME};
+if (length $cachehome == 0) {
+ ds_error("unknown user home, cannot download removal metadata");
+}
+my $cachedir = File::Spec->catdir($cachehome, 'devscripts', 'deb-why-removed');
+my $cachefile = File::Spec->catfile($cachedir, basename($url));
+
+if (not -d $cachedir) {
+ make_path($cachedir);
+}
+
+if (not -e $cachefile or (-e _ and not $opts->{'no-refresh'})) {
+ # Normalize the URL.
+ $url =~ s{^file://}{};
+
+ # Cache the file locally.
+ if (-e $url) {
+ cache_file($url, $cachefile);
+ } else {
+ cache_http($url, $cachefile);
+ }
+}
+
+my $meta
+ = Dpkg::Index->new(
+ get_key_func => sub { return $_[0]->{Sources} // $_[0]->{Binaries} // '' },
+ );
+
+$meta->load($cachefile, compression => 0);
+
+STANZA: foreach my $entry ($meta->get) {
+ foreach my $pkg (@ARGV) {
+ # XXX: Skip bogus entries with no indexable fields.
+ next
+ if not defined $entry->{Sources}
+ and not defined $entry->{Binaries};
+
+ next
+ if ($entry->{Sources} // '') !~ m/\Q$pkg\E_/
+ && ($entry->{Binaries} // '') !~ m/\Q$pkg\E_/;
+
+ print $entry->output();
+ print "\n";
+ next STANZA;
+ }
+}
+
+=encoding utf8
+
+=head1 NAME
+
+deb-why-removed - shows the reason a package was removed from the archive
+
+=head1 SYNOPSIS
+
+B<deb-why-removed> [I<option>...] I<package>...
+
+=head1 DESCRIPTION
+
+This program will download the removals metadata from the archive, search
+and print the entries within for a source or binary package name match.
+
+=head1 OPTIONS
+
+=over 4
+
+=item B<-u>, B<--url> I<URL>
+
+URL to the archive removals deb822-formatted file list.
+This can be either an actual URL (https://, http://, file://), an pathname
+or an origin name.
+Currently the only origin name known is B<debian>.
+
+=item B<--no-refresh>
+
+Do not refresh the cached removals file even if there is a newer version
+in the archive.
+
+=item B<-h>, B<-?>, B<--help>
+
+Show a help message and exit.
+
+=item B<--version>
+
+Show the program version.
+
+=back
+
+=head1 FILES
+
+=over 4
+
+=item I<cachedir>B</devscripts/deb-why-removed/>
+
+This directory contains the cached removal files downloaded from the archive.
+I<cachedir> will be either B<$XDG_CACHE_HOME> or if that is not defined
+B<$HOME/.cache/>.
+
+=back
+
+=head1 SEE ALSO
+
+L<https://ftp-master.debian.org/#removed>
+
+=cut