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