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 use SOAP::Lite;
  77
  78 sub do_id($) {
  79     my ($bug_num,$options) = @_;
  80
  81     $options ||= {};
  82
  83     if ( not $bug_num =~ /^\#?\d+$/ ) {
  84         warn "Bug is not a number!" and return undef
  85           if not $options->{return_warnings};
  86         return "Bug is not a number!";
  87     }
  88     $bug_num =~ s/^\#//;
  89     my $soap = SOAP::Lite->uri('Debbugs/SOAP/1')->
  90         proxy('http://bugs.debian.org/cgi-bin/soap.cgi');
  91     $soap->transport->env_proxy();
  92     my $temp = $soap->get_status($bug_num);
  93     use Data::Dumper;
  94     # enabling this will cause amazing amounts of output
  95     # &::DEBUG(Dumper($temp));
  96     if ($temp->fault) {
  97         return "Some failure (".$temp->fault->{faultstring}.")";
  98     }
  99     my $result = $temp->result();
 100     &::DEBUG(Dumper($result));
 101     if (not defined $result) {
 102         return "No such bug (or some kind of error)";
 103     }
 104     ($result) = values %{$result};
 105     my $bug = {};
 106     $bug->{num} = $result->{bug_num};
 107     $bug->{title} = $result->{subject};
 108     $bug->{severity} = $result->{severity};    #Default severity is normal
 109     # Just leave the leter instead of the whole thing.
 110     $bug->{severity} =~ s/^(.).+$/$1/;
 111     $bug->{package} = $result->{package};
 112     $bug->{reporter} = $result->{submitter};
 113     $bug->{date} = $result->{date};
 114     $bug->{tags} = $result->{keywords};
 115     $bug->{done} = defined $result->{done} && length($result->{done}) > 0;
 116     $bug->{merged_with} = $result->{mergedwith};
 117     # report bug
 118
 119     my $report = '';
 120     $report .= 'DONE:' if defined $bug->{done} and $bug->{done};
 121     $report .= '#'
 122       . $bug->{num} . ':'
 123       . uc( $bug->{severity} ) . '['
 124       . $bug->{package} . '] '
 125       . $bug->{title};
 126     $report .= ' (' . $bug->{tags} . ')' if defined $bug->{tags};
 127     $report .= '; ' . $bug->{date};
 128
 129     # Avoid reporting so many merged bugs.
 130     $report .= ' ['
 131       . join( ',', splice( @{ [ split( /,/, $bug->{merged_with} ) ] }, 0, 3 ) )
 132       . ']'
 133       if defined $bug->{merged_with};
 134     return $report;
 135 }
 136
 137 sub old_do_id {
 138     my ($num) = @_;
 139     my $url = "http://bugs.debian.org/$num";
 140
 141     # FIXME
 142     return "do_id not supported yet.";
 143 }
 144
 145 sub do_email {
 146     my ($email) = @_;
 147     my $url = "http://bugs.debian.org/$email";
 148
 149     # FIXME
 150     return "do_email not supported yet.";
 151
 152     my @results = &::getURL($url);
 153     foreach (@results) {
 154         &::DEBUG("do_email: $_");
 155     }
 156 }
 157
 158 sub do_pkg {
 159     my ($pkg) = @_;
 160     my $url = "http://bugs.debian.org/$pkg";
 161
 162     # FIXME
 163     return "do_pkg not supported yet.";
 164
 165     my @results = &::getURL($url);
 166     foreach (@results) {
 167         &::DEBUG("do_pkg: $_");
 168     }
 169 }
 170
 171 1;
 172
 173 # vim:ts=4:sw=4:expandtab:tw=80