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 Debbugs::SOAP::Server;
28 use base qw(Exporter SOAP::Server::Parameters);
31 $DEBUG = 0 unless defined $DEBUG;
37 Exporter::export_ok_tags();
38 $EXPORT_TAGS{all} = [@EXPORT_OK];
43 use Debbugs::Status qw(get_bug_status);
44 use Debbugs::Common qw(make_list getbuglocation getbugcomponent);
46 use Debbugs::Packages;
48 use Storable qw(nstore retrieve dclone);
49 use Scalar::Util qw(looks_like_number);
52 our $CURRENT_VERSION = 2;
56 my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
57 my %ut = get_usertag('don@donarmstrong.com');
59 Returns a hashref of bugs which have the specified usertags for the
62 In the second case, returns all of the usertags for the user passed.
66 use Debbugs::User qw(read_usertags);
69 my $VERSION = __populate_version(pop);
70 my ($self,$email, @tags) = @_;
72 read_usertags(\%ut, $email);
74 @tags{@tags} = (1) x @tags;
76 for my $tag (keys %ut) {
77 delete $ut{$tag} unless exists $tags{$tag};
80 return encode_utf8_structure(\%ut);
88 my @statuses = get_status(@bugs);
89 my @statuses = get_status([bug => 304234,
97 Returns an arrayref of hashrefs which output the status for specific
100 In the first case, no options are passed to
101 L<Debbugs::Status::get_bug_status> besides the bug number; in the
102 second the bug, dist, arch, bugusertags, sourceversions, and version
103 parameters are passed if they are present.
105 As a special case for suboptimal SOAP implementations, if only one
106 argument is passed to get_status and it is an arrayref which either is
107 empty, has a number as the first element, or contains an arrayref as
108 the first element, the outer arrayref is dereferenced, and processed
109 as in the examples above.
111 See L<Debbugs::Status::get_bug_status> for details.
116 my $VERSION = __populate_version(pop);
117 my ($self,@bugs) = @_;
123 looks_like_number($bugs[0][0])
129 for my $bug (@bugs) {
132 my %param = __collapse_params(@{$bug});
133 next unless defined $param{bug};
135 $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
136 qw(bug dist arch bugusertags sourceversions version indicatesource)
140 $bug_status = get_bug_status(bug => $bug);
142 if (defined $bug_status and keys %{$bug_status} > 0) {
143 $status{$bug} = $bug_status;
146 # __prepare_response($self);
147 return encode_utf8_structure(\%status);
152 my @bugs = get_bugs(...);
153 my @bugs = get_bugs([...]);
155 Returns a list of bugs. In the second case, allows the variable
156 parameters to be specified as an array reference in case your favorite
157 language's SOAP implementation is craptacular.
159 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
164 use Debbugs::Bugs qw();
167 my $VERSION = __populate_version(pop);
168 my ($self,@params) = @_;
169 # Because some soap implementations suck and can't handle
170 # variable numbers of arguments we allow get_bugs([]);
171 if (@params == 1 and ref($params[0]) eq 'ARRAY') {
172 @params = @{$params[0]};
174 my %params = __collapse_params(@params);
176 @bugs = Debbugs::Bugs::get_bugs(%params);
177 return encode_utf8_structure(\@bugs);
182 my @bugs = newest_bugs(5);
184 Returns a list of the newest bugs. [Note that all bugs are *not*
185 guaranteed to exist, but they should in the most common cases.]
190 my $VERSION = __populate_version(pop);
191 my ($self,$num) = @_;
192 my $newest_bug = Debbugs::Bugs::newest_bug();
193 return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]);
199 my $bug_log = get_bug_log($bug);
200 my $bug_log = get_bug_log($bug,$msg_num);
202 Retuns a parsed set of the bug log; this is an array of hashes with
219 Currently $msg_num is completely ignored.
223 use Debbugs::Log qw();
224 use Debbugs::MIME qw(parse);
227 my $VERSION = __populate_version(pop);
228 my ($self,$bug,$msg_num) = @_;
230 my $log = Debbugs::Log->new(bug_num => $bug) or
231 die "Debbugs::Log was unable to be initialized";
237 while (my $record = $log->read_record()) {
239 #next if defined $msg_num and ($current_msg ne $msg_num);
240 next unless $record->{type} eq 'incoming-recv';
241 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
242 next if defined $msg_id and exists $seen_msg_ids{$msg_id};
243 $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
244 next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
245 my $message = parse($record->{text});
246 my ($header,$body) = map {join("\n",make_list($_))}
247 @{$message}{qw(header body)};
248 push @messages,{header => $header,
251 msg_num => $current_msg,
254 return encode_utf8_structure(\@messages);
257 =head2 binary_to_source
259 binary_to_source($binary_name,$binary_version,$binary_architecture)
261 Returns a reference to the source package name and version pair
262 corresponding to a given binary package name, version, and
263 architecture. If undef is passed as the architecture, returns a list
264 of references to all possible pairs of source package names and
265 versions for all architectures, with any duplicates removed.
267 As of comaptibility version 2, this has changed to use the more
268 powerful binary_to_source routine, which allows returning source only,
269 concatenated scalars, and other useful features.
271 See the documentation of L<Debbugs::Packages::binary_to_source> for
276 sub binary_to_source{
277 my $VERSION = __populate_version(pop);
278 my ($self,@params) = @_;
281 return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0],
282 (@params > 1)?(version => $params[1]):(),
283 (@params > 2)?(arch => $params[2]):(),
287 return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]);
291 =head2 source_to_binary
293 source_to_binary($source_name,$source_version);
295 Returns a reference to an array of references to binary package name,
296 version, and architecture corresponding to a given source package name
297 and version. In the case that the given name and version cannot be
298 found, the unversioned package to source map is consulted, and the
299 architecture is not returned.
301 (This function corresponds to L<Debbugs::Packages::sourcetobinary>)
305 sub source_to_binary {
306 my $VERSION = __populate_version(pop);
307 my ($self,@params) = @_;
309 return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]);
314 get_version(package=>'foopkg',
319 Returns a list of the versions of package in the distributions and
320 architectures listed. This routine only returns unique values.
324 =item package -- package to return list of versions
326 =item dist -- distribution (unstable, stable, testing); can be an
329 =item arch -- architecture (i386, source, ...); can be an arrayref
331 =item time -- returns a version=>time hash at which the newest package
332 matching this version was uploaded
334 =item source -- returns source/version instead of just versions
336 =item no_source_arch -- discards the source architecture when arch is
337 not passed. [Used for finding the versions of binary packages only.]
338 Defaults to 0, which does not discard the source architecture. (This
339 may change in the future, so if you care, please code accordingly.)
341 =item return_archs -- returns a version=>[archs] hash indicating which
342 architectures are at which versions.
346 This function correponds to L<Debbugs::Packages::get_versions>
351 my $VERSION = __populate_version(pop);
352 my ($self,@params) = @_;
354 return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params));
357 =head1 VERSION COMPATIBILITY
359 The functionality provided by the SOAP interface will change over time.
361 To the greatest extent possible, we will attempt to provide backwards
362 compatibility with previous versions; however, in order to have
363 backwards compatibility, you need to specify the version with which
368 sub __populate_version{
370 return $request->{___debbugs_soap_version};
373 sub __collapse_params{
377 # Because some clients can't handle passing arrayrefs, we allow
378 # options to be specified multiple times
379 while (my ($key,$value) = splice @params,0,2) {
380 push @{$params{$key}}, make_list($value);
382 # However, for singly specified options, we want to pull them
384 for my $key (keys %params) {
385 if (@{$params{$key}} == 1) {
386 ($params{$key}) = @{$params{$key}}