/usr/share/perl5/Debian/PkgPerl/Bug.pm is in pkg-perl-tools 0.42.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | package Debian::PkgPerl::Bug;
use strict;
use warnings;
use autodie;
use Carp;
=head1 NAME
Debian::PkgPerl::Bug - Retrieves bug information to be forwarded.
=head1 SYNOPSIS
use Debian::PkgPerl::Bug;
my $msg = Debian::PkgPerl::Bug->new();
my %info = $msg->retrieve_bug_info();
=head1 DESCRIPTION
Helper class that retrieves information related to the bug being
forwarded upstream.
=cut
sub new {
my $class = shift;
my %params = @_;
return bless \%params, $class;
}
sub retrieve_bug_info {
my $self = shift;
my %bug_info;
my $bug = $self->{bug};
my $opt_offline_test = $self->{offline};
my $opt_force = $self->{force};
$bug_info{bug} = $bug;
$bug_info{url} = "https://bugs.debian.org/$bug";
if ($opt_offline_test) {
$bug_info{Subject} = 'Test bug subject';
$bug_info{msg} = "Test bug message\n";
return;
}
# See http://wiki.debian.org/DebbugsSoapInterface
require SOAP::Lite;
my $soap = SOAP::Lite->uri('Debbugs/SOAP')
->proxy('http://bugs.debian.org/cgi-bin/soap.cgi');
my $info = $soap->get_status($bug)->result()->{$bug};
die "Err: Bug #$bug already closed\n" if $info->{done};
if ( $info->{forwarded} ) {
if ($opt_force) {
warn "Wrn: Bug #$bug already forwarded to $info->{forwarded}\n";
}
else {
die "Err: Bug #$bug already forwarded to $info->{forwarded}\n";
}
}
$bug_info{Subject} = $info->{subject};
# try to get the body of the first message
# get_bug_log() fails with a SOAP error for some bugs. cf. #635018
my $ok = eval {
my $log = $soap->get_bug_log($bug)->result();
$bug_info{msg} = $log->[0]->{body};
$bug_info{msg} .= "\n" unless $bug_info{msg} =~ /\n$/;
1;
};
unless ($ok) {
my $err = $@;
warn "W: Failed to retrieve content of bug #$bug:\n";
warn "W: $err";
}
return %bug_info;
}
=head1 LICENSE AND COPYRIGHT
=over
=item Copyright 2016 Alex Muntada.
=item Copyright 2014 Salvatore Bonaccorso.
=item Copyright 2014 Damyan Ivanov.
=item Copyright 2011 Alessandro Ghedini.
=back
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
=cut
1;
|