src/Modules/DebianExtra.pl

   1 #
   2 #  DebianExtra.pl: Extra stuff for debian
   3 #          Author: dms
   4 #         Version: v0.1 (20000520)
   5 #         Created: 20000520
   6 #
   7
   8 use strict;
   9
  10 package DebianExtra;
  11
  12 sub Parse {
  13     my($args) = @_;
  14     my($msg) = '';
  15
  16     #&::DEBUG("DebianExtra: $args\n");
  17     if (!defined $args or $args =~ /^$/) {
  18         $msg = &debianBugs();
  19     } elsif ($args =~ /^(\d+)$/) {
  20         # package number:
  21         $msg = &do_id($args);
  22     } elsif ($args =~ /^(\S+\@\S+)$/) {
  23         # package email maintainer.
  24         $msg = &do_email($args);
  25     } elsif ($args =~ /^(\S+)$/) {
  26         # package name.
  27         $msg = &do_pkg($args);
  28     } else {
  29         # invalid.
  30         $msg = "error: could not parse $args";
  31     }
  32     &::msg($::who, $msg);
  33 }
  34
  35 sub debianBugs {
  36     my @results = &::getURL("http://master.debian.org/~wakkerma/bugs");
  37     my ($date, $rcbugs, $remove);
  38     my ($bugs_closed, $bugs_opened) = (0,0);
  39
  40     if (scalar @results) {
  41         foreach (@results) {
  42             s/<.*?>//g;
  43             $date   = $1 if (/status at (.*)\s*$/);
  44             $rcbugs = $1 if (/bugs: (\d+)/);
  45             $remove = $1 if (/REMOVE\S+ (\d+)\s*$/);
  46             if (/^(\d+) r\S+ b\S+ w\S+ c\S+ a\S+ (\d+)/) {
  47                 $bugs_closed = $1;
  48                 $bugs_opened = $2;
  49             }
  50         }
  51         my $xtxt = ($bugs_closed >=$bugs_opened) ?
  52                         "It's good to see " :
  53                         "Oh no, the bug count is rising -- ";
  54
  55         &::performStrictReply(
  56                 "Debian bugs statistics, last updated on $date... ".
  57                 "There are \002$rcbugs\002 release-critical bugs;  $xtxt".
  58                 "\002$bugs_closed\002 bugs closed, opening \002$bugs_opened\002 bugs.  ".
  59                 "About \002$remove\002 packages will be removed."
  60         );
  61     } else {
  62         &::msg($::who, "Couldn't retrieve data for debian bug stats.");
  63     }
  64 }
  65
  66 sub do_id($){
  67     my ($bug_num) = shift;
  68
  69     if (not $bug_num =~ /^\#?\d+$/) {
  70         return "Bug is not a number!";
  71     }
  72     $bug_num =~ s/^\#//;
  73     my @results = &::getURL("http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=$bug_num");
  74     my $report = join("\n", @results);
  75
  76     # strip down report to relevant header information.
  77     $report =~ s/\r//sig;
  78     $report =~ /<BODY[^>]*>(.+?)<HR>/si;
  79     $report = $1;
  80     my $bug = {};
  81     ($bug->{num}, $bug->{title}) = $report =~ m#\#(\d+)\<\/A\>\<BR\>(.+?)\<\/H1\>#is;
  82     &::DEBUG("Bugnum: $bug->{num}\n");
  83     $bug->{title} =~ s/&lt;/\</g;
  84     $bug->{title} =~ s/&gt;/\>/g;
  85     $bug->{title} =~ s/&quot;/\"/g;
  86     &::DEBUG("Title: $bug->{title}\n");
  87     $bug->{severity} = 'n'; #Default severity is normal
  88     my @bug_flags = split /(?<!\&.t);/s, $report;
  89     foreach my $bug_flag (@bug_flags) {
  90         $bug_flag =~ s/\n//g;
  91         &::DEBUG("Bug_flag: $bug_flag\n");
  92         if ($bug_flag =~ /Severity:/i) {
  93             ($bug->{severity}) = $bug_flag =~ /(wishlist|minor|normal|important|serious|grave)/i;
  94             # Just leave the leter instead of the whole thing.
  95             $bug->{severity} =~ s/^(.).+$/$1/;
  96         }
  97         elsif ($bug_flag =~ /Package:/) {
  98             ($bug->{package}) = $bug_flag =~ /\"\>\s*([^<>]+?)\s*\<\/a\>/;
  99             # take packagename out of title if it's there
 100             $bug->{title} =~ s/^$bug->{package}: //;
 101         }
 102         elsif ($bug_flag =~ /Reported by:/) {
 103             ($bug->{reporter}) = $bug_flag =~ /\"\>\s*(.+?)\s*\<\/a\>/;
 104             # strip &lt; and &gt;
 105             $bug->{reporter} =~ s/&lt;/\</g;
 106             $bug->{reporter} =~ s/&gt;/\>/g;
 107         }
 108         elsif ($bug_flag =~ /Date:/) {
 109             ($bug->{date}) = $bug_flag =~ /Date:\s*(\w.+?)\s*$/;
 110             #ditch extra whitespace
 111             $bug->{date} =~ s/\s{2,}/\ /;
 112         }
 113         elsif ($bug_flag =~ /Tags:/) {
 114             ($bug->{tags}) = $bug_flag =~ /strong\>\s*(.+?)\s*\<\/strong\>/;
 115         }
 116         elsif ($bug_flag =~ /merged with /) {
 117             $bug_flag =~ s/merged with\s*//;
 118             $bug_flag =~ s/\<[^\>]+\>//g;
 119             $bug_flag =~ s/\s//sg;
 120             $bug->{merged_with} = $bug_flag;
 121
 122         }
 123         elsif ($bug_flag =~ /\>Done:\</) {
 124             $bug->{done} = 1;
 125         }
 126     }
 127
 128     # report bug
 129
 130     $report = '';
 131     $report .= 'DONE:' if defined $bug->{done} and $bug->{done};
 132     $report .= '#'.$bug->{num}.':'.uc($bug->{severity}).'['.$bug->{package}.'] '.$bug->{title};
 133     $report .= ' ('.$bug->{tags}.')' if defined $bug->{tags};
 134     $report .= ' ' . $bug->{date};
 135     # Avoid reporting so many merged bugs.
 136     $report .= ' ['.join(',',splice(@{[split(/,/,$bug->{merged_with})]},0,3)).']' if defined $bug->{merged_with};
 137     if ($::DEBUG) {
 138         use Data::Dumper;
 139         &::DEBUG(Dumper($bug));
 140     }
 141     return $report;
 142 }
 143
 144 sub old_do_id {
 145     my($num) = @_;
 146     my $url = "http://bugs.debian.org/$num";
 147
 148     # FIXME
 149     return "do_id not supported yet.";
 150
 151     my @results = &::getURL($url);
 152     foreach (@results) {
 153         &::DEBUG("do_id: $_");
 154     }
 155 }
 156
 157 sub do_email {
 158     my($email) = @_;
 159     my $url = "http://bugs.debian.org/$email";
 160
 161     # FIXME
 162     return "do_email not supported yet.";
 163
 164     my @results = &::getURL($url);
 165     foreach (@results) {
 166         &::DEBUG("do_email: $_");
 167     }
 168 }
 169
 170 sub do_pkg {
 171     my($pkg) = @_;
 172     my $url = "http://bugs.debian.org/$pkg";
 173
 174     # FIXME
 175     return "do_pkg not supported yet.";
 176
 177     my @results = &::getURL($url);
 178     foreach (@results) {
 179         &::DEBUG("do_pkg: $_");
 180     }
 181 }
 182
 183 1;