1 # This module is part of debbugs, and is released
2 # under the terms of the GPL version 2, or any later version at your option.
3 # See the file README and COPYING for more information.
4 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>.
26 use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
27 use base qw(Exporter SOAP::Server::Parameters);
30 $DEBUG = 0 unless defined $DEBUG;
36 Exporter::export_ok_tags();
37 $EXPORT_TAGS{all} = [@EXPORT_OK];
43 use Debbugs::Status qw(get_bug_status);
44 use Debbugs::Common qw(make_list getbuglocation getbugcomponent);
45 use Storable qw(nstore retrieve);
46 use Scalar::Util qw(looks_like_number);
49 our $CURRENT_VERSION = 1;
53 my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
54 my %ut = get_usertag('don@donarmstrong.com');
56 Returns a hashref of bugs which have the specified usertags for the
59 In the second case, returns all of the usertags for the user passed.
63 use Debbugs::User qw(read_usertags);
66 my $VERSION = __populate_version(pop);
67 my ($self,$email, @tags) = @_;
69 read_usertags(\%ut, $email);
71 @tags{@tags} = (1) x @tags;
73 for my $tag (keys %ut) {
74 delete $ut{$tag} unless exists $tags{$tag};
85 my @statuses = get_status(@bugs);
86 my @statuses = get_status([bug => 304234,
94 Returns an arrayref of hashrefs which output the status for specific
97 In the first case, no options are passed to
98 L<Debbugs::Status::get_bug_status> besides the bug number; in the
99 second the bug, dist, arch, bugusertags, sourceversions, and version
100 parameters are passed if they are present.
102 As a special case for suboptimal SOAP implementations, if only one
103 argument is passed to get_status and it is an arrayref which either is
104 empty, has a number as the first element, or contains an arrayref as
105 the first element, the outer arrayref is dereferenced, and processed
106 as in the examples above.
108 See L<Debbugs::Status::get_bug_status> for details.
113 my $VERSION = __populate_version(pop);
114 my ($self,@bugs) = @_;
121 looks_like_number($bugs[0][0])
127 for my $bug (@bugs) {
130 my %param = __collapse_params(@{$bug});
131 $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
132 qw(bug dist arch bugusertags sourceversions version)
136 $bug_status = get_bug_status(bug => $bug);
138 if (defined $bug_status and keys %{$bug_status} > 0) {
139 $status{$bug} = $bug_status;
142 # __prepare_response($self);
148 my @bugs = get_bugs(...);
149 my @bugs = get_bugs([...]);
151 Returns a list of bugs. In the second case, allows the variable
152 parameters to be specified as an array reference in case your favorite
153 language's SOAP implementation is craptacular.
155 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
160 use Debbugs::Bugs qw();
163 my $VERSION = __populate_version(pop);
164 my ($self,@params) = @_;
165 # Because some soap implementations suck and can't handle
166 # variable numbers of arguments we allow get_bugs([]);
167 if (@params == 1 and ref($params[0]) eq 'ARRAY') {
168 @params = @{$params[0]};
170 my %params = __collapse_params(@params);
172 @bugs = Debbugs::Bugs::get_bugs(%params);
178 my @bugs = newest_bugs(5);
180 Returns a list of the newest bugs. [Note that all bugs are *not*
181 guaranteed to exist, but they should in the most common cases.]
186 my $VERSION = __populate_version(pop);
187 my ($self,$num) = @_;
188 my $newest_bug = Debbugs::Bugs::newest_bug();
189 return [($newest_bug - $num + 1) .. $newest_bug];
195 my $bug_log = get_bug_log($bug);
196 my $bug_log = get_bug_log($bug,$msg_num);
198 Retuns a parsed set of the bug log; this is an array of hashes with
215 Currently $msg_num is completely ignored.
219 use Debbugs::Log qw();
220 use Debbugs::MIME qw(parse);
223 my $VERSION = __populate_version(pop);
224 my ($self,$bug,$msg_num) = @_;
226 my $location = getbuglocation($bug,'log');
227 my $bug_log = getbugcomponent($bug,'log',$location);
229 my $log_fh = IO::File->new($bug_log, 'r') or
230 die "Unable to open bug log $bug_log for reading: $!";
232 my $log = Debbugs::Log->new($log_fh) or
233 die "Debbugs::Log was unable to be initialized";
239 while (my $record = $log->read_record()) {
241 #next if defined $msg_num and ($current_msg ne $msg_num);
242 next unless $record->{type} eq 'incoming-recv';
243 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
244 next if defined $msg_id and exists $seen_msg_ids{$msg_id};
245 $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
246 next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
247 my $message = parse($record->{text});
248 my ($header,$body) = map {join("\n",make_list($_))}
249 @{$message}{qw(header body)};
250 push @messages,{header => $header,
253 msg_num => $current_msg,
260 =head1 VERSION COMPATIBILITY
262 The functionality provided by the SOAP interface will change over time.
264 To the greatest extent possible, we will attempt to provide backwards
265 compatibility with previous versions; however, in order to have
266 backwards compatibility, you need to specify the version with which
271 sub __populate_version{
273 return $request->{___debbugs_soap_version};
276 sub __collapse_params{
280 # Because some clients can't handle passing arrayrefs, we allow
281 # options to be specified multiple times
282 while (my ($key,$value) = splice @params,0,2) {
283 push @{$params{$key}}, make_list($value);
285 # However, for singly specified options, we want to pull them
287 for my $key (keys %params) {
288 if (@{$params{$key}} == 1) {
289 ($params{$key}) = @{$params{$key}}