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 :utf8);
45 use Debbugs::Packages;
47 use Storable qw(nstore retrieve dclone);
48 use Scalar::Util qw(looks_like_number);
51 our $CURRENT_VERSION = 2;
55 my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
56 my %ut = get_usertag('don@donarmstrong.com');
58 Returns a hashref of bugs which have the specified usertags for the
61 In the second case, returns all of the usertags for the user passed.
65 use Debbugs::User qw(read_usertags);
68 my $VERSION = __populate_version(pop);
69 my ($self,$email, @tags) = @_;
71 read_usertags(\%ut, $email);
73 @tags{@tags} = (1) x @tags;
75 for my $tag (keys %ut) {
76 delete $ut{$tag} unless exists $tags{$tag};
79 return encode_utf8_structure(\%ut);
87 my @statuses = get_status(@bugs);
88 my @statuses = get_status([bug => 304234,
96 Returns an arrayref of hashrefs which output the status for specific
99 In the first case, no options are passed to
100 L<Debbugs::Status::get_bug_status> besides the bug number; in the
101 second the bug, dist, arch, bugusertags, sourceversions, and version
102 parameters are passed if they are present.
104 As a special case for suboptimal SOAP implementations, if only one
105 argument is passed to get_status and it is an arrayref which either is
106 empty, has a number as the first element, or contains an arrayref as
107 the first element, the outer arrayref is dereferenced, and processed
108 as in the examples above.
110 See L<Debbugs::Status::get_bug_status> for details.
115 my $VERSION = __populate_version(pop);
116 my ($self,@bugs) = @_;
122 looks_like_number($bugs[0][0])
128 for my $bug (@bugs) {
131 my %param = __collapse_params(@{$bug});
132 next unless defined $param{bug};
134 $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
135 qw(bug dist arch bugusertags sourceversions version indicatesource)
139 $bug_status = get_bug_status(bug => $bug);
141 if (defined $bug_status and keys %{$bug_status} > 0) {
142 $status{$bug} = $bug_status;
145 # __prepare_response($self);
146 return encode_utf8_structure(\%status);
151 my @bugs = get_bugs(...);
152 my @bugs = get_bugs([...]);
154 Returns a list of bugs. In the second case, allows the variable
155 parameters to be specified as an array reference in case your favorite
156 language's SOAP implementation is craptacular.
158 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
163 use Debbugs::Bugs qw();
166 my $VERSION = __populate_version(pop);
167 my ($self,@params) = @_;
168 # Because some soap implementations suck and can't handle
169 # variable numbers of arguments we allow get_bugs([]);
170 if (@params == 1 and ref($params[0]) eq 'ARRAY') {
171 @params = @{$params[0]};
173 my %params = __collapse_params(@params);
175 @bugs = Debbugs::Bugs::get_bugs(%params);
176 return encode_utf8_structure(\@bugs);
181 my @bugs = newest_bugs(5);
183 Returns a list of the newest bugs. [Note that all bugs are *not*
184 guaranteed to exist, but they should in the most common cases.]
189 my $VERSION = __populate_version(pop);
190 my ($self,$num) = @_;
191 my $newest_bug = Debbugs::Bugs::newest_bug();
192 return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]);
198 my $bug_log = get_bug_log($bug);
199 my $bug_log = get_bug_log($bug,$msg_num);
201 Retuns a parsed set of the bug log; this is an array of hashes with
218 Currently $msg_num is completely ignored.
222 use Debbugs::Log qw();
223 use Debbugs::MIME qw(parse);
226 my $VERSION = __populate_version(pop);
227 my ($self,$bug,$msg_num) = @_;
229 my $log = Debbugs::Log->new(bug_num => $bug) or
230 die "Debbugs::Log was unable to be initialized";
236 while (my $record = $log->read_record()) {
238 #next if defined $msg_num and ($current_msg ne $msg_num);
239 next unless $record->{type} eq 'incoming-recv';
240 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
241 next if defined $msg_id and exists $seen_msg_ids{$msg_id};
242 $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
243 next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
244 my $message = parse($record->{text});
245 my ($header,$body) = map {join("\n",make_list($_))}
246 @{$message}{qw(header body)};
247 push @messages,{header => $header,
250 msg_num => $current_msg,
253 return encode_utf8_structure(\@messages);
256 =head2 binary_to_source
258 binary_to_source($binary_name,$binary_version,$binary_architecture)
260 Returns a reference to the source package name and version pair
261 corresponding to a given binary package name, version, and
262 architecture. If undef is passed as the architecture, returns a list
263 of references to all possible pairs of source package names and
264 versions for all architectures, with any duplicates removed.
266 As of comaptibility version 2, this has changed to use the more
267 powerful binary_to_source routine, which allows returning source only,
268 concatenated scalars, and other useful features.
270 See the documentation of L<Debbugs::Packages::binary_to_source> for
275 sub binary_to_source{
276 my $VERSION = __populate_version(pop);
277 my ($self,@params) = @_;
280 return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0],
281 (@params > 1)?(version => $params[1]):(),
282 (@params > 2)?(arch => $params[2]):(),
286 return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]);
290 =head2 source_to_binary
292 source_to_binary($source_name,$source_version);
294 Returns a reference to an array of references to binary package name,
295 version, and architecture corresponding to a given source package name
296 and version. In the case that the given name and version cannot be
297 found, the unversioned package to source map is consulted, and the
298 architecture is not returned.
300 (This function corresponds to L<Debbugs::Packages::sourcetobinary>)
304 sub source_to_binary {
305 my $VERSION = __populate_version(pop);
306 my ($self,@params) = @_;
308 return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]);
313 get_version(package=>'foopkg',
318 Returns a list of the versions of package in the distributions and
319 architectures listed. This routine only returns unique values.
323 =item package -- package to return list of versions
325 =item dist -- distribution (unstable, stable, testing); can be an
328 =item arch -- architecture (i386, source, ...); can be an arrayref
330 =item time -- returns a version=>time hash at which the newest package
331 matching this version was uploaded
333 =item source -- returns source/version instead of just versions
335 =item no_source_arch -- discards the source architecture when arch is
336 not passed. [Used for finding the versions of binary packages only.]
337 Defaults to 0, which does not discard the source architecture. (This
338 may change in the future, so if you care, please code accordingly.)
340 =item return_archs -- returns a version=>[archs] hash indicating which
341 architectures are at which versions.
345 This function correponds to L<Debbugs::Packages::get_versions>
350 my $VERSION = __populate_version(pop);
351 my ($self,@params) = @_;
353 return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params));
356 =head1 VERSION COMPATIBILITY
358 The functionality provided by the SOAP interface will change over time.
360 To the greatest extent possible, we will attempt to provide backwards
361 compatibility with previous versions; however, in order to have
362 backwards compatibility, you need to specify the version with which
367 sub __populate_version{
369 return $request->{___debbugs_soap_version};
372 sub __collapse_params{
376 # Because some clients can't handle passing arrayrefs, we allow
377 # options to be specified multiple times
378 while (my ($key,$value) = splice @params,0,2) {
379 push @{$params{$key}}, make_list($value);
381 # However, for singly specified options, we want to pull them
383 for my $key (keys %params) {
384 if (@{$params{$key}} == 1) {
385 ($params{$key}) = @{$params{$key}}