Devscripts/Debbugs.pm

   1 # This is Debbugs.pm from the Debian devscripts package
   2 #
   3 #   Copyright (C) 2008 Adam D. Barratt
   4 #   select() is Copyright (C) 2007 Don Armstrong
   5 #
   6 # This program is free software; you can redistribute it and/or modify
   7 # it under the terms of the GNU General Public License as published by
   8 # the Free Software Foundation; either version 2 of the License, or
   9 # (at your option) any later version.
  10 #
  11 # This program is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 # GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along
  17 # with this program; if not, write to the Free Software Foundation, Inc.,
  18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 package Devscripts::Debbugs;
  21
  22 =head1 OPTIONS
  23
  24 =item select [key:value  ...]
  25
  26 Uses the SOAP interface to output a list of bugs which match the given
  27 selection requirements.
  28
  29 The following keys are allowed, and may be given multiple times.
  30
  31 =over 8
  32
  33 =item package
  34
  35 Binary package name.
  36
  37 =item source
  38
  39 Source package name.
  40
  41 =item maintainer
  42
  43 E-mail address of the maintainer.
  44
  45 =item submitter
  46
  47 E-mail address of the submitter.
  48
  49 =item severity
  50
  51 Bug severity.
  52
  53 =item status
  54
  55 Status of the bug.
  56
  57 =item tag
  58
  59 Tags applied to the bug. If I<users> is specified, may include
  60 usertags in addition to the standard tags.
  61
  62 =item owner
  63
  64 Bug's owner.
  65
  66 =item correspondent
  67
  68 Address of someone who sent mail to the log.
  69
  70 =item affects
  71
  72 Bugs which affect this package.
  73
  74 =item bugs
  75
  76 List of bugs to search within.
  77
  78 =item users
  79
  80 Users to use when looking up usertags.
  81
  82 =item archive
  83
  84 Whether to search archived bugs or normal bugs; defaults to 0
  85 (i.e. only search normal bugs). As a special case, if archive is
  86 'both', both archived and unarchived bugs are returned.
  87
  88 =back
  89
  90 For example, to select the set of bugs submitted by
  91 jrandomdeveloper@example.com and tagged wontfix, one would use
  92
  93 select("submitter:jrandomdeveloper@example.com", "tag:wontfix")
  94
  95 =cut
  96
  97 use strict;
  98 use warnings;
  99
 100 my $soapurl='Debbugs/SOAP/1';
 101 our $btsurl='http://bugs.debian.org/';
 102 my @errors;
 103
 104 sub init_soap {
 105     my $soapproxyurl;
 106     if ($btsurl =~ m%^https?://(.*)/?$%) {
 107         $soapproxyurl = $btsurl . '/';
 108     } else {
 109         $soapproxyurl = 'http://' . $btsurl . '/';
 110     }
 111     $soapproxyurl =~ s%//$%/%;
 112     $soapproxyurl .= 'cgi-bin/soap.cgi';
 113     my $soap = SOAP::Lite->uri($soapurl)->proxy($soapproxyurl);
 114
 115     $soap->transport->env_proxy();
 116     $soap->on_fault(\&getSOAPError);
 117
 118     return $soap;
 119 }
 120
 121 my $soap_broken;
 122 sub have_soap {
 123     return ($soap_broken ? 0 : 1) if defined $soap_broken;
 124     eval {
 125         require SOAP::Lite;
 126     };
 127
 128     if ($@) {
 129         if ($@ =~ m%^Can't locate SOAP/%) {
 130             $soap_broken="the libsoap-lite-perl package is not installed";
 131         } else {
 132             $soap_broken="couldn't load SOAP::Lite: $@";
 133         }
 134     }
 135     else {
 136         $soap_broken = 0;
 137     }
 138     return ($soap_broken ? 0 : 1);
 139 }
 140
 141 sub getSOAPError {
 142     my ($soap, $result) = @_;
 143     my $err;
 144     if (ref($result)) {
 145         $err = $result->faultstring;
 146     } else {
 147         $err = $soap->transport->status;
 148     }
 149     chomp $err;
 150     push @errors, $err;
 151
 152     return new SOAP::SOM;
 153 }
 154
 155 sub usertags {
 156     die "Couldn't run usertags: $soap_broken\n" unless have_soap();
 157
 158     my @args = @_;
 159
 160     my $soap = init_soap();
 161     my $usertags = $soap->get_usertag(@_);
 162
 163     if (@errors or not defined $usertags) {
 164         my $error = join("\n", @errors);
 165         die "Error retrieving usertags from SOAP server: $error\n";
 166     }
 167
 168     my $result = $usertags->result();
 169
 170     if (@errors or not defined $result) {
 171         my $error = join("\n", @errors);
 172         die "Error retrieving usertags from SOAP server: $error\n";
 173     }
 174
 175     return $result;
 176 }
 177
 178 sub select {
 179     die "Couldn't run select: $soap_broken\n" unless have_soap();
 180     my @args = @_;
 181     my %valid_keys = (package => 'package',
 182                       pkg     => 'package',
 183                       src     => 'src',
 184                       source  => 'src',
 185                       maint   => 'maint',
 186                       maintainer => 'maint',
 187                       submitter => 'submitter',
 188                       from => 'submitter',
 189                       status    => 'status',
 190                       tag       => 'tag',
 191                       tags      => 'tag',
 192                       usertag   => 'tag',
 193                       usertags  => 'tag',
 194                       owner     => 'owner',
 195                       dist      => 'dist',
 196                       distribution => 'dist',
 197                       bugs       => 'bugs',
 198                       archive    => 'archive',
 199                       severity   => 'severity',
 200                       correspondent => 'correspondent',
 201                       affects       => 'affects',
 202     );
 203     my %users;
 204     my %search_parameters;
 205     my $soap = init_soap();
 206     for my $arg (@args) {
 207         my ($key,$value) = split /:/, $arg, 2;
 208         next unless $key;
 209         if (exists $valid_keys{$key}) {
 210             if ($valid_keys{$key} eq 'archive') {
 211                 $search_parameters{$valid_keys{$key}} = $value
 212                     if $value;
 213             } else {
 214                 push @{$search_parameters{$valid_keys{$key}}},
 215                     $value if $value;
 216             }
 217         } elsif ($key =~/users?$/) {
 218             $users{$value} = 1 if $value;
 219         } else {
 220             warn "select(): Unrecognised key: $key\n";
 221         }
 222     }
 223     my %usertags;
 224     for my $user (keys %users) {
 225         my $ut = usertags($user);
 226         next unless defined $ut and $ut ne "";
 227         for my $tag (keys %{$ut}) {
 228             push @{$usertags{$tag}},
 229             @{$ut->{$tag}};
 230         }
 231     }
 232     my $bugs = $soap->get_bugs(%search_parameters,
 233         (keys %usertags)?(usertags=>\%usertags):()
 234     );
 235
 236     if (@errors or not defined $bugs) {
 237         my $error = join("\n", @errors);
 238         die "Error while retrieving bugs from SOAP server: $error\n";
 239     }
 240
 241     my $result = $bugs->result();
 242     if (@errors or not defined $result) {
 243         my $error = join( "\n", @errors );
 244         die "Error while retrieving bugs from SOAP server: $error\n";
 245     }
 246
 247     return $result;
 248 }
 249
 250 sub status {
 251     die "Couldn't run status: $soap_broken\n" unless have_soap();
 252     my @args = @_;
 253
 254     my $soap = init_soap();
 255
 256     my $bugs = $soap->get_status(@args);
 257
 258     if (@errors or not defined $bugs) {
 259         my $error = join("\n", @errors);
 260         die "Error while retrieving bug statuses from SOAP server: $error\n";
 261     }
 262
 263     my $result = $bugs->result();
 264
 265     if (@errors or not defined $result) {
 266         my $error = join("\n", @errors);
 267         die "Error while retrieving bug statuses from SOAP server: $error\n";
 268     }
 269
 270     return $result;
 271 }
 272
 273 sub versions {
 274     die "Couldn't run versions: $soap_broken\n" unless have_soap();
 275
 276     my @args = @_;
 277     my %valid_keys = (package => 'package',
 278                       pkg     => 'package',
 279                       src => 'source',
 280                       source => 'source',
 281                       time => 'time',
 282                       binary => 'no_source_arch',
 283                       notsource => 'no_source_arch',
 284                       archs => 'return_archs',
 285                       displayarch => 'return_archs',
 286     );
 287
 288     my %search_parameters;
 289     my @archs = ();
 290     my @dists = ();
 291
 292     for my $arg (@args) {
 293         my ($key,$value) = split /:/, $arg, 2;
 294         $value ||= "1";
 295         if ($key =~ /^arch(itecture)?$/) {
 296             push @archs, $value;
 297         } elsif ($key =~ /^dist(ribution)?$/) {
 298             push @dists, $value;
 299         } elsif (exists $valid_keys{$key}) {
 300             $search_parameters{$valid_keys{$key}} = $value;
 301         }
 302     }
 303
 304     $search_parameters{arch} = \@archs if @archs;
 305     $search_parameters{dist} = \@dists if @dists;
 306
 307     my $soap = init_soap();
 308
 309     my $versions = $soap->get_versions(%search_parameters);
 310
 311     if (@errors or not defined $versions) {
 312         my $error = join("\n", @errors);
 313         die "Error while retrieving package versions from SOAP server: $error\n";
 314     }
 315
 316     my $result = $versions->result();
 317
 318     if (@errors or not defined $result) {
 319         my $error = join("\n", @errors);
 320         die "Error while retrieivng package versions from SOAP server: $error";
 321     }
 322
 323     return $result;
 324 }
 325
 326 sub versions_with_arch {
 327     die "Couldn't run versions_with_arch: $soap_broken\n" unless have_soap();
 328     my @args = @_;
 329
 330     my $versions = versions(@args, 'displayarch:1');
 331
 332     if (not defined $versions) {
 333         die "Error while retrieivng package versions from SOAP server: $@";
 334     }
 335
 336     return $versions;
 337 }
 338
 339 sub newest_bugs {
 340     die "Couldn't run newest_bugs: $soap_broken\n" unless have_soap();
 341     my $count = shift || '';
 342
 343     return if $count !~ /^\d+$/;
 344
 345     my $soap = init_soap();
 346
 347     my $bugs = $soap->newest_bugs($count);
 348
 349     if (@errors or not defined $bugs) {
 350         my $error = join("\n", @errors);
 351         die "Error while retrieving newest bug list from SOAP server: $error";
 352     }
 353
 354     my $result = $bugs->result();
 355
 356     if (@errors or not defined $result) {
 357         my $error = join("\n", @errors);
 358         die "Error while retrieving newest bug list from SOAP server: $error";
 359     }
 360
 361     return $result;
 362 }
 363
 364 # debbugs currently ignores the $msg_num parameter
 365 # but eventually it might not, so we support passing it
 366
 367 sub bug_log {
 368     die "Couldn't run bug_log: $soap_broken\n" unless have_soap();
 369
 370     my $bug = shift || '';
 371     my $message = shift;
 372
 373     return if $bug !~ /^\d+$/;
 374
 375     my $soap = init_soap();
 376
 377     my $log = $soap->get_bug_log($bug, $message);
 378
 379     if (@errors or not defined $log) {
 380         my $error = join("\n", @errors);
 381         die "Error while retrieving bug log from SOAP server: $error\n";
 382     }
 383
 384     my $result = $log->result();
 385
 386     if (@errors or not defined $result) {
 387         my $error = join("\n", @errors);
 388         die "Error while retrieving bug log from SOAP server: $error\n";
 389     }
 390
 391     return $result;
 392 }
 393
 394 sub binary_to_source {
 395     die "Couldn't run binary_to_source: $soap_broken\n"
 396         unless have_soap();
 397
 398     my $soap = init_soap();
 399
 400     my $binpkg = shift;
 401     my $binver = shift;
 402     my $arch = shift;
 403
 404     return if not defined $binpkg or not defined $binver;
 405
 406     my $mapping = $soap->binary_to_source($binpkg, $binver, $arch);
 407
 408     if (@errors or not defined $mapping) {
 409         my $error = join("\n", @errors);
 410         die "Error while retrieving binary to source mapping from SOAP server: $error\n";
 411     }
 412
 413     my $result = $mapping->result();
 414
 415     if (@errors or not defined $result) {
 416         my $error = join("\n", @errors);
 417         die "Error while retrieving binary to source mapping from SOAP server: $error\n";
 418     }
 419
 420     return $result;
 421 }
 422
 423 sub source_to_binary {
 424     die "Couldn't run source_to_binary: $soap_broken\n"
 425         unless have_soap();
 426
 427     my $soap = init_soap();
 428
 429     my $srcpkg = shift;
 430     my $srcver = shift;
 431
 432     return if not defined $srcpkg or not defined $srcver;
 433
 434     my $mapping = $soap->source_to_binary($srcpkg, $srcver);
 435
 436     if (@errors or not defined $mapping) {
 437         my $error = join("\n", @errors);
 438         die "Error while retrieving source to binary mapping from SOAP server: $error\n";
 439     }
 440
 441     my $result = $mapping->result();
 442
 443     if (@errors or not defined $result) {
 444         my $error = join("\n", @errors);
 445         die "Error while retrieving source to binary mapping from SOAP server: $error\n";
 446     }
 447
 448     return $result;
 449 }
 450
 451 1;
 452
 453 __END__
 454