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