summaryrefslogtreecommitdiffstats
path: root/scripts/rc-alert.pl
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 15:53:52 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-07 15:53:52 +0000
commitefe47381c599b07e4c7bbdb2e91e8090a541c887 (patch)
tree05cf57183f5a23394eca11b00f97a74a5dfdf79d /scripts/rc-alert.pl
parentInitial commit. (diff)
downloaddevscripts-efe47381c599b07e4c7bbdb2e91e8090a541c887.tar.xz
devscripts-efe47381c599b07e4c7bbdb2e91e8090a541c887.zip
Adding upstream version 2.23.4+deb12u1.upstream/2.23.4+deb12u1upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'scripts/rc-alert.pl')
-rwxr-xr-xscripts/rc-alert.pl501
1 files changed, 501 insertions, 0 deletions
diff --git a/scripts/rc-alert.pl b/scripts/rc-alert.pl
new file mode 100755
index 0000000..7f3243d
--- /dev/null
+++ b/scripts/rc-alert.pl
@@ -0,0 +1,501 @@
+#!/usr/bin/perl
+
+# rc-alert - find RC bugs for programs on your system
+# Copyright (C) 2003 Anthony DeRobertis
+# Modifications Copyright 2003 Julian Gilbey <jdg@debian.org>
+# Modifications Copyright 2008 Adam D. Barratt <adam@adam-barratt.org.uk>
+# Modifications copyright 2009 by Jan Hauke Rahm <info@jhr-online.de>
+#
+# 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 Devscripts::Packages;
+use File::Basename;
+use File::Copy qw(move);
+use File::HomeDir;
+use File::Path qw(make_path);
+use File::Spec;
+use Getopt::Long qw(:config bundling permute no_getopt_compat);
+
+sub remove_duplicate_values($);
+sub store_if_relevant(%);
+sub human_flags($);
+sub unhtmlsanit($);
+sub dt_parse_request($);
+
+$ENV{HOME} = File::HomeDir->my_home;
+my $cachedir
+ = $ENV{XDG_CACHE_HOME} || File::Spec->catdir($ENV{HOME}, '.cache');
+$cachedir = File::Spec->catdir($cachedir, 'devscripts', 'rc-alert');
+
+my $url = "http://bugs.debian.org/release-critical/other/all.html";
+my $cachefile = File::Spec->catfile($cachedir, basename($url));
+my $forcecache = 0;
+my $usecache = 0;
+
+my @flags = (
+ [qr/P/ => 'pending'],
+ [qr/\+/ => 'patch'],
+ [qr/H/ => 'help [wanted]'],
+ [qr/M/ => 'moreinfo [needed]'],
+ [qr/R/ => 'unreproducible'],
+ [qr/S/ => 'security'],
+ [qr/U/ => 'upstream'],
+);
+# A little hacky but allows us to sort the list by length
+my @dists = (
+ [qr/O/ => 'oldstable'],
+ [qr/S/ => 'stable'],
+ [qr/T/ => 'testing'],
+ [qr/U/ => 'unstable'],
+ [qr/E/ => 'experimental'],
+);
+
+my $includetags = "";
+my $excludetags = "";
+
+my $includedists = "";
+my $excludedists = "";
+
+my $tagincoperation = "or";
+my $tagexcoperation = "or";
+my $distincoperation = "or";
+my $distexcoperation = "or";
+
+my $popcon = 0;
+my $popcon_by_vote = 0;
+my $popcon_local = 0;
+
+my $debtags = '';
+my $debtags_db = '/var/lib/debtags/package-tags';
+
+my $progname = basename($0);
+
+my $usage = <<"EOF";
+Usage: $progname [--help|--version|--cache] [package ...]
+ List all installed packages (or listed packages) with
+ release-critical bugs, as determined from the Debian
+ release-critical bugs list.
+
+ Options:
+ --cache Create ~/.devscripts_cache directory if it does not exist
+
+ Matching options: (see the manpage for further information)
+ --include-tags Set of tags to include
+ --include-tag-op Must all tags match for inclusion?
+ --exclude-tags Set of tags to exclude
+ --exclude-tag-op Must all tags match for exclusion?
+ --include-dists Set of distributions to include
+ --include-dist-op Must all distributions be matched for inclusion?
+ --exclude-dists Set of distributions to exclude
+ --exclude-dist-op Must all distributions be matched for exclusion?
+
+ Debtags options: (only list packages with matching debtags)
+ --debtags Comma separated list of tags
+ (e.g. implemented-in::perl,role::plugin)
+ --debtags-database Database file (default: /var/lib/debtags/package-tags)
+
+ Popcon options:
+ --popcon Sort bugs by package's popcon rank
+ --pc-vote Sort by_vote instead of by_inst
+ (see popularity-contest(8))
+ --pc-local Use local popcon data from last popcon run
+ (/var/log/popularity-contest)
+EOF
+
+my $version = <<"EOF";
+This is $progname, from the Debian devscripts package, version ###VERSION###
+This code is copyright 2003 by Anthony DeRobertis
+Modifications copyright 2003 by Julian Gilbey <jdg\@debian.org>
+Modifications copyright 2008 by Adam D. Barratt <adam\@adam-barratt.org.uk>
+Modifications copyright 2009 by Jan Hauke Rahm <info\@jhr-online.de>
+This program comes with ABSOLUTELY NO WARRANTY.
+You are free to redistribute this code under the terms of the
+GNU General Public License, version 2, or (at your option) any later version.
+EOF
+
+##
+## handle command-line options
+##
+
+my ($opt_help, $opt_version);
+GetOptions(
+ "help|h" => \$opt_help,
+ "version|v" => \$opt_version,
+ "cache" => \$forcecache,
+ "include-tags|f=s" => \$includetags,
+ "exclude-tags=s" => \$excludetags,
+ "include-tag-op|t=s" => \$tagincoperation,
+ "exclude-tag-op=s" => \$tagexcoperation,
+ "include-dists|d=s" => \$includedists,
+ "exclude-dists=s" => \$excludedists,
+ "include-dist-op|o=s" => \$distincoperation,
+ "exclude-dist-op=s" => \$distexcoperation,
+ "debtags=s" => \$debtags,
+ "debtags-database=s" => \$debtags_db,
+ "popcon" => \$popcon,
+ "pc-vote" => \$popcon_by_vote,
+ "pc-local" => \$popcon_local,
+) or do { print $usage; exit 1; };
+
+if ($opt_help) { print $usage; exit 0; }
+if ($opt_version) { print $version; exit 0; }
+
+$tagincoperation =~ /^(or|and)$/ or $tagincoperation = 'or';
+$distincoperation =~ /^(or|and)$/ or $distincoperation = 'or';
+$tagexcoperation =~ /^(or|and)$/ or $tagexcoperation = 'or';
+$distexcoperation =~ /^(or|and)$/ or $distexcoperation = 'or';
+$includetags =~ s/[^P+HMRSUI]//gi;
+$excludetags =~ s/[^P+HMRSUI]//gi;
+$includedists =~ s/[^OSTUE]//gi;
+$excludedists =~ s/[^OSTUE]//gi;
+$includetags = remove_duplicate_values(uc($includetags));
+$excludetags = remove_duplicate_values(uc($excludetags));
+$includedists = remove_duplicate_values(uc($includedists));
+$excludedists = remove_duplicate_values(uc($excludedists));
+
+## First download the RC bugs page
+
+my $curl_or_wget;
+my $getcommand;
+if (system("command -v wget >/dev/null 2>&1") == 0) {
+ $curl_or_wget = "wget";
+ $getcommand = "wget -q -O -";
+} elsif (system("command -v curl >/dev/null 2>&1") == 0) {
+ $curl_or_wget = "curl";
+ $getcommand = "curl -qfsL";
+} else {
+ die
+"$progname: this program requires either the wget or curl package to be installed\n";
+}
+
+if (!-d $cachedir) {
+ if ($forcecache) {
+ make_path($cachedir);
+ }
+}
+
+my $usingcache = 0;
+if (-d $cachedir) {
+ chdir $cachedir or die "$progname: can't cd $cachedir: $!\n";
+
+ if ("$curl_or_wget" eq "wget") {
+ # Either use the cached version because the remote hasn't been
+ # updated (-N) or download a complete new copy (--no-continue)
+ if (system('wget', '-qN', '--no-continue', $url) != 0) {
+ die "$progname: wget failed!\n";
+ }
+ } elsif ("$curl_or_wget" eq "curl") {
+ if (system('curl', '-qfsLR', $url) != 0) {
+ die "$progname: curl failed!\n";
+ }
+ } else {
+ die "$progname: Unknown download program $curl_or_wget!\n";
+ }
+ open BUGS, $cachefile or die "$progname: could not read $cachefile: $!\n";
+ $usingcache = 1;
+} else {
+ open BUGS, "$getcommand $url |"
+ or die "$progname: could not run $curl_or_wget: $!\n";
+}
+
+## Get list of installed packages (not source packages)
+my $package_list;
+if (@ARGV) {
+ my %tmp = map { $_ => 1 } @ARGV;
+ $package_list = \%tmp;
+} else {
+ $package_list = InstalledPackages(1);
+}
+
+## Get popcon information
+my %popcon;
+if ($popcon) {
+ my $pc_by = $popcon_by_vote ? 'vote' : 'inst';
+
+ my $pc_regex;
+ if ($popcon_local) {
+ open POPCON, "/var/log/popularity-contest"
+ or die "$progname: Unable to access popcon data: $!";
+ $pc_regex = '(\d+)\s\d+\s(\S+)';
+ } else {
+ open POPCON,
+ "$getcommand http://popcon.debian.org/by_$pc_by.gz | gunzip -c |"
+ or die "$progname: Not able to receive remote popcon data!";
+ $pc_regex = '(\d+)\s+(\S+)\s+(\d+\s+){5}\(.*\)';
+ }
+
+ while (<POPCON>) {
+ next unless /$pc_regex/;
+ # rank $1 for package $2
+ if ($popcon_local) {
+ # negative for inverse sorting of atimes
+ $popcon{$2} = "-$1";
+ } else {
+ $popcon{$2} = $1;
+ }
+ }
+ close POPCON;
+}
+
+## Get debtags info
+my %dt_pkg;
+my @dt_requests;
+if ($debtags) {
+ ## read debtags database to %dt_pkg
+ open DEBTAGS, $debtags_db
+ or die "$progname: could not read debtags database: $!\n";
+ while (<DEBTAGS>) {
+ next unless /^(.+?)(?::?\s*|:\s+(.+?)\s*)$/;
+ $dt_pkg{$1} = $2;
+ }
+ close DEBTAGS;
+
+ ## and parse the request string
+ @dt_requests = dt_parse_request($debtags);
+}
+
+## Read the list of bugs
+
+my $found_bugs_start;
+my ($current_package, $comment);
+
+my $html;
+{
+ local $/;
+ $html = <BUGS>;
+}
+
+my ($ignore) = $html =~ m%<strong>I</strong>: ([^<]*)%;
+push(@flags, [qr/I/ => $ignore]);
+
+my @stanzas = $html =~ m%<div class="package">(.*?)</div>%gs;
+my %pkg_store;
+foreach my $stanza (@stanzas) {
+ if ($stanza
+ =~ m%<a name="([^\"]+)"><strong>Package:</strong></a> <a href="[^\"]+">%i
+ ) {
+ $current_package = $1;
+ $comment = '';
+ while ($stanza
+ =~ m%<a name="(\d+)"></a>\s*<a href="[^\"]+">\d+</a> (\[[^\]]+\])( \[[^\]]+\])? ([^<]+)%igc
+ ) {
+ my ($num, $tags, $dists, $name) = ($1, $2, $3, $4);
+ chomp $name;
+ store_if_relevant(
+ pkg => $current_package,
+ num => $num,
+ tags => $tags,
+ dists => $dists,
+ name => $name,
+ comment => $comment
+ );
+ }
+ }
+}
+for (sort { $a <=> $b } keys %pkg_store) {
+ print $pkg_store{$_};
+}
+
+if ($usingcache) {
+ close BUGS or die "$progname: could not close $cachefile: $!\n";
+} else {
+ close BUGS
+ or die $!
+ ? "$progname: could not close $curl_or_wget pipe: $!\n"
+ : "$progname: exit status from $curl_or_wget: $?\n";
+}
+
+exit 0;
+
+sub remove_duplicate_values($) {
+ my $in = shift || "";
+
+ $in = join("", sort { $a cmp $b } split //, $in);
+
+ $in =~ s/(.)\1/$1/g while $in =~ /(.)\1/;
+
+ return $in;
+}
+
+sub store_if_relevant(%) {
+ my %args = @_;
+
+ my $pkgname = $args{pkg};
+ $args{pkg} =~ s/^src://;
+
+ if ( exists($package_list->{ $args{pkg} })
+ || exists($package_list->{$pkgname})) {
+ # potentially relevant
+ my ($flags, $flagsapply) = human_flags($args{tags});
+ my $distsapply = 1;
+ my $dists;
+ ($dists, $distsapply) = human_dists($args{dists})
+ if defined $args{dists};
+
+ return unless $flagsapply and $distsapply;
+
+ foreach (@dt_requests) {
+ ## the array should be empty if nothing requested
+ return
+ unless ($dt_pkg{ $args{pkg} }
+ and $dt_pkg{ $args{pkg} } =~ /(\A|,\s*)$_(,|\z)/);
+ }
+
+ # yep, relevant
+ my $bug_string
+ = "Package: $pkgname\n"
+ . $comment
+ . # non-empty comments always contain the trailing \n
+ "Bug: $args{num}\n"
+ . "Bug-URL: https://bugs.debian.org/$args{num}\n"
+ . "Title: "
+ . unhtmlsanit($args{name}) . "\n"
+ . "Flags: "
+ . $flags . "\n"
+ . (defined $args{dists} ? "Dists: " . $dists . "\n" : "")
+ . (
+ defined $dt_pkg{ $args{pkg} }
+ ? "Debtags: " . $dt_pkg{ $args{pkg} } . "\n"
+ : ""
+ );
+
+ unless ($popcon_local) {
+ $bug_string .= (
+ defined $popcon{ $args{pkg} }
+ ? "Popcon rank: " . $popcon{ $args{pkg} } . "\n"
+ : ""
+ );
+ }
+ $bug_string .= "\n";
+
+ if ($popcon) {
+ return unless $bug_string;
+ my $index
+ = $popcon{ $args{pkg} } ? $popcon{ $args{pkg} } : 9999999;
+ $pkg_store{$index} .= $bug_string;
+ } else {
+ $pkg_store{1} .= $bug_string;
+ }
+ }
+}
+
+sub human_flags($) {
+ my $mrf = shift; # machine readable flags, for those of you wondering
+ my @hrf = (); # considering above, should be obvious
+ my $matchedflags = 0;
+ my $matchedexcludes = 0;
+ my $applies = 1;
+
+ foreach my $flagref (@flags) {
+ my ($flag, $desc) = @{$flagref};
+ if ($mrf =~ $flag) {
+ if ($excludetags =~ $flag) {
+ $matchedexcludes++;
+ } elsif ($includetags =~ $flag or !$includetags) {
+ $matchedflags++;
+ }
+ push @hrf, $desc;
+ }
+ }
+ if ( $excludetags
+ and $tagexcoperation eq 'and'
+ and (length $excludetags == $matchedexcludes)) {
+ $applies = 0;
+ } elsif ($matchedexcludes and $tagexcoperation eq 'or') {
+ $applies = 0;
+ } elsif ($includetags and !$matchedflags) {
+ $applies = 0;
+ } elsif ($includetags
+ and $tagincoperation eq 'and'
+ and (length $includetags != $matchedflags)) {
+ $applies = 0;
+ }
+
+ if (@hrf) {
+ return ("$mrf (" . join(", ", @hrf) . ')', $applies);
+ } else {
+ return ("$mrf (none)", $applies);
+ }
+}
+
+sub human_dists($) {
+ my $mrf = shift; # machine readable flags, for those of you wondering
+ my @hrf = (); # considering above, should be obvious
+ my $matcheddists = 0;
+ my $matchedexcludes = 0;
+ my $applies = 1;
+
+ foreach my $distref (@dists) {
+ my ($dist, $desc) = @{$distref};
+ if ($mrf =~ $dist) {
+ if ($excludedists =~ $dist) {
+ $matchedexcludes++;
+ } elsif ($includedists =~ $dist or !$includedists) {
+ $matcheddists++;
+ }
+ push @hrf, $desc;
+ }
+ }
+ if ( $excludedists
+ and $distexcoperation eq 'and'
+ and (length $excludedists == $matchedexcludes)) {
+ $applies = 0;
+ } elsif ($matchedexcludes and $distexcoperation eq 'or') {
+ $applies = 0;
+ } elsif ($includedists and !$matcheddists) {
+ $applies = 0;
+ } elsif ($includedists
+ and $distincoperation eq 'and'
+ and (length $includedists != $matcheddists)) {
+ $applies = 0;
+ }
+
+ if (@hrf) {
+ return ("$mrf (" . join(", ", @hrf) . ')', $applies);
+ } else {
+ return ('', $applies);
+ }
+}
+
+# Reverse of master.debian.org:/srv/bugs.debian.org/cgi-bin/common.pl
+sub unhtmlsanit ($) {
+ my %saniarray = ('lt', '<', 'gt', '>', 'amp', '&', 'quot', '"');
+ my $in = $_[0];
+ $in =~ s/&(lt|gt|amp|quot);/$saniarray{$1}/g;
+ return $in;
+}
+
+sub dt_parse_request($) {
+ my %dt_lookup;
+ foreach (split /,/, $_[0]) {
+ my ($d_key, $d_val) = split '::', $_;
+ die
+"$progname: A debtag must be of the form 'key::value'. See debtags(1) for details!"
+ unless ($d_key and $d_val);
+ if ($dt_lookup{$d_key}) {
+ $dt_lookup{$d_key} = "$dt_lookup{$d_key}|$d_val";
+ } else {
+ $dt_lookup{$d_key} = quotemeta($d_val);
+ }
+ }
+
+ my @out;
+ while (my ($dk, $dv) = each %dt_lookup) {
+ $dv = "($dv)" if ($dv =~ /\|/);
+ push @out, $dk . "::" . $dv;
+ }
+ return @out;
+}