scripts/rc-alert.pl

   1 #!/usr/bin/perl
   2
   3 # rc-alert - find RC bugs for programs on your system
   4 # Copyright (C) 2003 Anthony DeRobertis
   5 # Modifications Copyright 2003 Julian Gilbey <jdg@debian.org>
   6 # Modifications Copyright 2008 Adam D. Barratt <adam@adam-barratt.org.uk>
   7 # Modifications copyright 2009 by Jan Hauke Rahm <info@jhr-online.de>
   8 #
   9 # This program is free software; you can redistribute it and/or modify
  10 # it under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 2 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # This program is distributed in the hope that it will be useful,
  15 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with this program. If not, see <http://www.gnu.org/licenses/>.
  21
  22 use strict;
  23 use warnings;
  24 use lib '/usr/share/devscripts';
  25 use Devscripts::Packages;
  26 use File::Basename;
  27 use Getopt::Long;
  28
  29 sub remove_duplicate_values($);
  30 sub store_if_relevant(%);
  31 sub human_flags($);
  32 sub unhtmlsanit($);
  33 sub dt_parse_request($);
  34
  35 my $cachedir = $ENV{'HOME'}."/.devscripts_cache/";
  36 my $url = "http://bugs.debian.org/release-critical/other/all.html";
  37 my $cachefile = $cachedir . basename($url);
  38 my $forcecache = 0;
  39 my $usecache = 0;
  40
  41 my %flagmap = ( '(P)' => "pending",
  42                 '.(\+)' => "patch",
  43                 '..(H)' => "help [wanted]",
  44                 '...(M)' => "moreinfo [needed]",
  45                 '....(R)' => "unreproducible",
  46                 '.....(S)' => "security",
  47                 '......(U)' => "upstream",
  48                 '.......(I)' => "lenny-ignore or squeeze-ignore",
  49               );
  50 # A little hacky but allows us to sort the list by length
  51 my %distmap = ( '(O)' => "oldstable",
  52                 '.?(S)' => "stable",
  53                 '.?.?(T)' => "testing",
  54                 '.?.?.?(U)' => "unstable",
  55                 '.?.?.?.?(E)' => "experimental");
  56
  57 my $includetags = "";
  58 my $excludetags = "";
  59
  60 my $includedists = "";
  61 my $excludedists = "";
  62
  63 my $tagincoperation = "or";
  64 my $tagexcoperation = "or";
  65 my $distincoperation = "or";
  66 my $distexcoperation = "or";
  67
  68 my $popcon = 0;
  69 my $popcon_by_vote = 0;
  70 my $popcon_local = 0;
  71
  72 my $debtags = '';
  73 my $debtags_db = '/var/lib/debtags/package-tags';
  74
  75 my $progname = basename($0);
  76
  77 my $usage = <<"EOF";
  78 Usage: $progname [--help|--version|--cache] [package ...]
  79   List all installed packages (or listed packages) with
  80   release-critical bugs, as determined from the Debian
  81   release-critical bugs list.
  82
  83   Options:
  84   --cache           Create ~/.devscripts_cache directory if it does not exist
  85
  86   Matching options: (see the manpage for further information)
  87   --include-tags     Set of tags to include
  88   --include-tag-op   Must all tags match for inclusion?
  89   --exclude-tags     Set of tags to exclude
  90   --exclude-tag-op   Must all tags match for exclusion?
  91   --include-dists    Set of distributions to include
  92   --include-dist-op  Must all distributions be matched for inclusion?
  93   --exclude-dists    Set of distributions to exclude
  94   --exclude-dist-op  Must all distributions be matched for exclusion?
  95
  96   Debtags options: (only list packages with matching debtags)
  97   --debtags          Comma separated list of tags
  98                        (e.g. implemented-in::perl,role::plugin)
  99   --debtags-database Database file (default: /var/lib/debtags/package-tags)
 100
 101   Popcon options:
 102   --popcon           Sort bugs by package's popcon rank
 103   --pc-vote          Sort by_vote instead of by_inst
 104                        (see popularity-contest(8))
 105   --pc-local         Use local popcon data from last popcon run
 106                        (/var/log/popularity-contest)
 107 EOF
 108
 109 my $version = <<"EOF";
 110 This is $progname, from the Debian devscripts package, version ###VERSION###
 111 This code is copyright 2003 by Anthony DeRobertis
 112 Modifications copyright 2003 by Julian Gilbey <jdg\@debian.org>
 113 Modifications copyright 2008 by Adam D. Barratt <adam\@adam-barratt.org.uk>
 114 Modifications copyright 2009 by Jan Hauke Rahm <info\@jhr-online.de>
 115 This program comes with ABSOLUTELY NO WARRANTY.
 116 You are free to redistribute this code under the terms of the
 117 GNU General Public License, version 2, or (at your option) any later version.
 118 EOF
 119
 120 ##
 121 ## handle command-line options
 122 ##
 123
 124 my ($opt_help, $opt_version);
 125 GetOptions("help|h" => \$opt_help,
 126            "version|v" => \$opt_version,
 127            "cache" => \$forcecache,
 128            "include-tags|f=s" => \$includetags,
 129            "exclude-tags=s" => \$excludetags,
 130            "include-tag-op|t=s" => \$tagincoperation,
 131            "exclude-tag-op=s" => \$tagexcoperation,
 132            "include-dists|d=s" => \$includedists,
 133            "exclude-dists=s" => \$excludedists,
 134            "include-dist-op|o=s" => \$distincoperation,
 135            "exclude-dist-op=s" => \$distexcoperation,
 136            "debtags=s" => \$debtags,
 137            "debtags-database=s" => \$debtags_db,
 138            "popcon" => \$popcon,
 139            "pc-vote" => \$popcon_by_vote,
 140            "pc-local" => \$popcon_local,
 141            );
 142
 143 if ($opt_help) { print $usage; exit 0; }
 144 if ($opt_version) { print $version; exit 0; }
 145
 146 $tagincoperation =~ /^(or|and)$/ or $tagincoperation = 'or';
 147 $distincoperation =~ /^(or|and)$/ or $distincoperation = 'or';
 148 $tagexcoperation =~ /^(or|and)$/ or $tagexcoperation = 'or';
 149 $distexcoperation =~ /^(or|and)$/ or $distexcoperation = 'or';
 150 $includetags =~ s/[^P+HMRSUI]//gi;
 151 $excludetags =~ s/[^P+HMRSUI]//gi;
 152 $includedists =~ s/[^OSTUE]//gi;
 153 $excludedists =~ s/[^OSTUE]//gi;
 154 $includetags = remove_duplicate_values(uc($includetags));
 155 $excludetags = remove_duplicate_values(uc($excludetags));
 156 $includedists = remove_duplicate_values(uc($includedists));
 157 $excludedists = remove_duplicate_values(uc($excludedists));
 158
 159 ## First download the RC bugs page
 160
 161 unless (system("command -v wget >/dev/null 2>&1") == 0) {
 162     die "$progname: this program requires the wget package to be installed\n";
 163 }
 164
 165
 166 if (! -d $cachedir and $forcecache) {
 167     mkdir $cachedir
 168         or die "$progname: can't make cache directory $cachedir: $!\n";
 169 }
 170
 171 if (-d $cachedir) {
 172     chdir $cachedir or die "$progname: can't cd $cachedir: $!\n";
 173
 174     if (system("wget -qN $url") != 0) {
 175         die "$progname: wget failed!\n";
 176     }
 177     open BUGS, $cachefile or die "$progname: could not read $cachefile: $!\n";
 178 }
 179 else {
 180     open BUGS, "wget -q -O - $url |" or
 181         die "$progname: could not run wget: $!\n";
 182 }
 183
 184 ## Get list of installed packages (not source packages)
 185 my $package_list;
 186 if (@ARGV) {
 187     my %tmp = map { $_ => 1 } @ARGV;
 188     $package_list = \%tmp;
 189 }
 190 else {
 191     $package_list = InstalledPackages(0);
 192 }
 193
 194 ## Get popcon information
 195 my %popcon;
 196 if ($popcon) {
 197     my $pc_by = $popcon_by_vote ? 'vote' : 'inst';
 198
 199     my $pc_regex;
 200     if ($popcon_local) {
 201         open POPCON, "/var/log/popularity-contest"
 202             or die "$progname: Unable to access popcon data: $!";
 203         $pc_regex = '(\d+)\s\d+\s(\S+)';
 204     } else {
 205         open POPCON, "wget -q -O - http://popcon.debian.org/by_$pc_by.gz | gunzip -c |"
 206             or die "$progname: Not able to receive remote popcon data!";
 207         $pc_regex = '(\d+)\s+(\S+)\s+(\d+\s+){5}\(.*\)';
 208     }
 209
 210     while (<POPCON>) {
 211         next unless /$pc_regex/;
 212         # rank $1 for package $2
 213         if ($popcon_local) {
 214             # negative for inverse sorting of atimes
 215             $popcon{$2} = "-$1";
 216         } else {
 217             $popcon{$2} = $1;
 218         }
 219     }
 220     close POPCON;
 221 }
 222
 223 ## Get debtags info
 224 my %dt_pkg;
 225 my @dt_requests;
 226 if ($debtags) {
 227     ## read debtags database to %dt_pkg
 228     open DEBTAGS, $debtags_db or die "$progname: could not read debtags database: $!\n";
 229     while (<DEBTAGS>) {
 230         next unless /^(.+?)(?::?\s*|:\s+(.+?)\s*)$/;
 231         $dt_pkg{$1} = $2;
 232     }
 233     close DEBTAGS;
 234
 235     ## and parse the request string
 236     @dt_requests = dt_parse_request($debtags);
 237 }
 238
 239 ## Read the list of bugs
 240
 241 my $found_bugs_start;
 242 my ($current_package, $comment);
 243
 244 my %pkg_store;
 245 while (defined(my $line = <BUGS>)) {
 246     if( $line =~ /^<div class="package">/) {
 247         $found_bugs_start = 1;
 248     }
 249     if( ! defined($found_bugs_start)) {
 250         next;
 251     } elsif ($line =~ m%<a name="([^\"]+)"><strong>Package:</strong></a> <a href="[^\"]+">%i) {
 252         $current_package = $1;
 253         $comment = '';
 254     } elsif ($line =~ m%<a name="(\d+)"></a>\s*<a href="[^\"]+">\d+</a> (\[[^\]]+\])( \[[^\]]+\])? ([^<]+)%i) {
 255         my ($num, $tags, $dists, $name) = ($1, $2, $3, $4);
 256         chomp $name;
 257         store_if_relevant(pkg => $current_package, num => $num, tags => $tags, dists => $dists, name => $name, comment => $comment);
 258     }
 259 }
 260 for (sort {$a <=> $b } keys %pkg_store) { print $pkg_store{$_}; }
 261
 262 close BUGS or die "$progname: could not close $cachefile: $!\n";
 263
 264 exit 0;
 265
 266 sub remove_duplicate_values($) {
 267     my $in = shift || "";
 268
 269     $in = join( "", sort { $a cmp $b } split //, $in );
 270
 271     $in =~ s/(.)\1/$1/g while $in =~ /(.)\1/;
 272
 273     return $in;
 274 }
 275
 276 sub store_if_relevant(%) {
 277     my %args = @_;
 278
 279     if (exists($$package_list{$args{pkg}})) {
 280         # potentially relevant
 281         my ($flags, $flagsapply) = human_flags($args{tags});
 282         my $distsapply = 1;
 283         my $dists;
 284         ($dists, $distsapply) = human_dists($args{dists}) if defined $args{dists};
 285
 286         return unless $flagsapply and $distsapply;
 287
 288         foreach (@dt_requests) {
 289             ## the array should be empty if nothing requested
 290             return unless ($dt_pkg{$args{pkg}} and
 291                 $dt_pkg{$args{pkg}} =~ /(\A|,\s*)$_(,|\z)/);
 292         }
 293
 294         # yep, relevant
 295         my $bug_string = "Package: $args{pkg}\n" .
 296             $comment .  # non-empty comments always contain the trailing \n
 297             "Bug:     $args{num}\n" .
 298             "Title:   " . unhtmlsanit($args{name}) . "\n" .
 299             "Flags:   " . $flags . "\n" .
 300             (defined $args{dists} ? "Dists:  " . $dists . "\n" : "") .
 301             (defined $dt_pkg{$args{pkg}} ?
 302                 "Debtags: " . $dt_pkg{$args{pkg}} . "\n" : "");
 303
 304         unless ($popcon_local) {
 305             $bug_string .= (defined $popcon{$args{pkg}} ?
 306                 "Popcon rank: " . $popcon{$args{pkg}} . "\n" : "");
 307         }
 308         $bug_string .= "\n";
 309
 310         if ($popcon) {
 311             return unless $bug_string;
 312             my $index = $popcon{$args{pkg}} ? $popcon{$args{pkg}} : 9999999;
 313             $pkg_store{$index} .= $bug_string;
 314         } else {
 315             $pkg_store{1} .= $bug_string;
 316         }
 317     }
 318 }
 319
 320 sub human_flags($) {
 321     my $mrf = shift;    # machine readable flags, for those of you wondering
 322     my @hrf = ();       # considering above, should be obvious
 323     my $matchedflags = 0;
 324     my $matchedexcludes = 0;
 325     my $applies = 1;
 326
 327     foreach my $flag ( sort { length $a <=> length $b } keys %flagmap ) {
 328         if ($mrf =~ /^\[(?:$flag)/) {
 329             if ($excludetags =~ /\Q$1\E/) {
 330                 $matchedexcludes++;
 331             } elsif ($includetags =~ /\Q$1\E/ or ! $includetags) {
 332                 $matchedflags++;
 333             }
 334             push @hrf, $flagmap{$flag};
 335         }
 336     }
 337     if ($excludetags and $tagexcoperation eq 'and' and
 338         (length $excludetags == $matchedexcludes)) {
 339         $applies = 0;
 340     }
 341     elsif ($matchedexcludes and $tagexcoperation eq 'or') {
 342         $applies = 0;
 343     }
 344     elsif ($includetags and ! $matchedflags) {
 345         $applies = 0;
 346     } elsif ($includetags and $tagincoperation eq 'and' and
 347         (length $includetags != $matchedflags)) {
 348         $applies = 0;
 349     }
 350
 351     if (@hrf) {
 352         return ("$mrf (" . join(", ", @hrf) . ')', $applies);
 353     } else {
 354         return ("$mrf (none)", $applies);
 355     }
 356 }
 357
 358 sub human_dists($) {
 359     my $mrf = shift;     # machine readable flags, for those of you wondering
 360     my @hrf = ();        # considering above, should be obvious
 361     my $matcheddists = 0;
 362     my $matchedexcludes = 0;
 363     my $applies = 1;
 364
 365     foreach my $dist ( sort { length $a <=> length $b } keys %distmap ) {
 366         if ($mrf =~ /(?:$dist)/) {
 367             if ($excludedists =~ /$dist/) {
 368                 $matchedexcludes++;
 369             } elsif ($includedists =~ /$dist/ or ! $includedists) {
 370                 $matcheddists++;
 371             }
 372             push @hrf, $distmap{$dist};
 373         }
 374     }
 375     if ($excludedists and $distexcoperation eq 'and' and
 376         (length $excludedists == $matchedexcludes)) {
 377         $applies = 0;
 378     } elsif ($matchedexcludes and $distexcoperation eq 'or') {
 379         $applies = 0;
 380     } elsif ($includedists and ! $matcheddists) {
 381         $applies = 0;
 382     } elsif ($includedists and $distincoperation eq 'and' and
 383         (length $includedists != $matcheddists)) {
 384         $applies = 0;
 385     }
 386
 387     if (@hrf) {
 388         return ("$mrf (" . join(", ", @hrf) . ')', $applies);
 389     } else {
 390         return ('', $applies);
 391     }
 392 }
 393
 394 # Reverse of master.debian.org:/org/bugs.debian.org/cgi-bin/common.pl
 395 sub unhtmlsanit ($) {
 396     my %saniarray = ('lt','<', 'gt','>', 'amp','&', 'quot', '"');
 397     my $in = $_[0];
 398     $in =~ s/&(lt|gt|amp|quot);/$saniarray{$1}/g;
 399     return $in;
 400 }
 401
 402 sub dt_parse_request($) {
 403     my %dt_lookup;
 404     foreach (split /,/, $_[0]) {
 405         my ($d_key, $d_val) = split '::', $_;
 406         die "$progname: A debtag must be of the form 'key::value'. See debtags(1) for details!"
 407             unless ($d_key and $d_val);
 408         if ($dt_lookup{$d_key}) {
 409             $dt_lookup{$d_key} = "$dt_lookup{$d_key}|$d_val";
 410         } else {
 411             $dt_lookup{$d_key} = quotemeta($d_val);
 412         }
 413     }
 414
 415     my @out;
 416     while (my ($dk, $dv) = each %dt_lookup) {
 417         $dv = "($dv)" if ($dv =~ /\|/);
 418         push @out, $dk . "::" . $dv;
 419     }
 420     return @out;
 421 }