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 Exporter qw(import);
29 use base qw(SOAP::Server::Parameters);
32 $DEBUG = 0 unless defined $DEBUG;
38 Exporter::export_ok_tags();
39 $EXPORT_TAGS{all} = [@EXPORT_OK];
44 use Debbugs::Status qw(get_bug_status);
45 use Debbugs::Common qw(make_list getbuglocation getbugcomponent);
47 use Debbugs::Packages;
49 use Storable qw(nstore retrieve dclone);
50 use Scalar::Util qw(looks_like_number);
53 our $CURRENT_VERSION = 2;
57 my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
58 my %ut = get_usertag('don@donarmstrong.com');
60 Returns a hashref of bugs which have the specified usertags for the
63 In the second case, returns all of the usertags for the user passed.
67 use Debbugs::User qw(read_usertags);
70 my $VERSION = __populate_version(pop);
71 my ($self,$email, @tags) = @_;
73 read_usertags(\%ut, $email);
75 @tags{@tags} = (1) x @tags;
77 for my $tag (keys %ut) {
78 delete $ut{$tag} unless exists $tags{$tag};
81 return encode_utf8_structure(\%ut);
89 my @statuses = get_status(@bugs);
90 my @statuses = get_status([bug => 304234,
98 Returns an arrayref of hashrefs which output the status for specific
101 In the first case, no options are passed to
102 L<Debbugs::Status::get_bug_status> besides the bug number; in the
103 second the bug, dist, arch, bugusertags, sourceversions, and version
104 parameters are passed if they are present.
106 As a special case for suboptimal SOAP implementations, if only one
107 argument is passed to get_status and it is an arrayref which either is
108 empty, has a number as the first element, or contains an arrayref as
109 the first element, the outer arrayref is dereferenced, and processed
110 as in the examples above.
112 See L<Debbugs::Status::get_bug_status> for details.
117 my $VERSION = __populate_version(pop);
118 my ($self,@bugs) = @_;
124 looks_like_number($bugs[0][0])
130 my %binary_to_source_cache;
131 for my $bug (@bugs) {
134 my %param = __collapse_params(@{$bug});
135 next unless defined $param{bug};
137 $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
138 qw(bug dist arch bugusertags sourceversions version indicatesource),
139 binary_to_source_cache => \%binary_to_source_cache,
143 $bug_status = get_bug_status(bug => $bug,
144 binary_to_source_cache => \%binary_to_source_cache,
147 if (defined $bug_status and keys %{$bug_status} > 0) {
148 $status{$bug} = $bug_status;
151 # __prepare_response($self);
152 return encode_utf8_structure(\%status);
157 my @bugs = get_bugs(...);
158 my @bugs = get_bugs([...]);
160 Returns a list of bugs. In the second case, allows the variable
161 parameters to be specified as an array reference in case your favorite
162 language's SOAP implementation is craptacular.
164 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
169 use Debbugs::Bugs qw();
172 my $VERSION = __populate_version(pop);
173 my ($self,@params) = @_;
174 # Because some soap implementations suck and can't handle
175 # variable numbers of arguments we allow get_bugs([]);
176 if (@params == 1 and ref($params[0]) eq 'ARRAY') {
177 @params = @{$params[0]};
179 my %params = __collapse_params(@params);
181 @bugs = Debbugs::Bugs::get_bugs(%params);
182 return encode_utf8_structure(\@bugs);
187 my @bugs = newest_bugs(5);
189 Returns a list of the newest bugs. [Note that all bugs are *not*
190 guaranteed to exist, but they should in the most common cases.]
195 my $VERSION = __populate_version(pop);
196 my ($self,$num) = @_;
197 my $newest_bug = Debbugs::Bugs::newest_bug();
198 return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]);
204 my $bug_log = get_bug_log($bug);
205 my $bug_log = get_bug_log($bug,$msg_num);
207 Retuns a parsed set of the bug log; this is an array of hashes with
224 Currently $msg_num is completely ignored.
228 use Debbugs::Log qw();
229 use Debbugs::MIME qw(parse);
232 my $VERSION = __populate_version(pop);
233 my ($self,$bug,$msg_num) = @_;
235 my $log = Debbugs::Log->new(bug_num => $bug) or
236 die "Debbugs::Log was unable to be initialized";
241 while (my $record = $log->read_record()) {
243 #next if defined $msg_num and ($current_msg ne $msg_num);
244 next unless $record->{type} eq 'incoming-recv';
245 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
246 next if defined $msg_id and exists $seen_msg_ids{$msg_id};
247 $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
248 next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
249 my $message = parse($record->{text});
250 my ($header,$body) = map {join("\n",make_list($_))}
251 @{$message}{qw(header body)};
252 push @messages,{header => $header,
255 msg_num => $current_msg,
258 return encode_utf8_structure(\@messages);
261 =head2 binary_to_source
263 binary_to_source($binary_name,$binary_version,$binary_architecture)
265 Returns a reference to the source package name and version pair
266 corresponding to a given binary package name, version, and
267 architecture. If undef is passed as the architecture, returns a list
268 of references to all possible pairs of source package names and
269 versions for all architectures, with any duplicates removed.
271 As of comaptibility version 2, this has changed to use the more
272 powerful binary_to_source routine, which allows returning source only,
273 concatenated scalars, and other useful features.
275 See the documentation of L<Debbugs::Packages::binary_to_source> for
280 sub binary_to_source{
281 my $VERSION = __populate_version(pop);
282 my ($self,@params) = @_;
285 return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0],
286 (@params > 1)?(version => $params[1]):(),
287 (@params > 2)?(arch => $params[2]):(),
291 return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]);
295 =head2 source_to_binary
297 source_to_binary($source_name,$source_version);
299 Returns a reference to an array of references to binary package name,
300 version, and architecture corresponding to a given source package name
301 and version. In the case that the given name and version cannot be
302 found, the unversioned package to source map is consulted, and the
303 architecture is not returned.
305 (This function corresponds to L<Debbugs::Packages::sourcetobinary>)
309 sub source_to_binary {
310 my $VERSION = __populate_version(pop);
311 my ($self,@params) = @_;
313 return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]);
318 get_version(package=>'foopkg',
323 Returns a list of the versions of package in the distributions and
324 architectures listed. This routine only returns unique values.
328 =item package -- package to return list of versions
330 =item dist -- distribution (unstable, stable, testing); can be an
333 =item arch -- architecture (i386, source, ...); can be an arrayref
335 =item time -- returns a version=>time hash at which the newest package
336 matching this version was uploaded
338 =item source -- returns source/version instead of just versions
340 =item no_source_arch -- discards the source architecture when arch is
341 not passed. [Used for finding the versions of binary packages only.]
342 Defaults to 0, which does not discard the source architecture. (This
343 may change in the future, so if you care, please code accordingly.)
345 =item return_archs -- returns a version=>[archs] hash indicating which
346 architectures are at which versions.
350 This function corresponds to L<Debbugs::Packages::get_versions>
355 my $VERSION = __populate_version(pop);
356 my ($self,@params) = @_;
358 return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params));
361 =head1 VERSION COMPATIBILITY
363 The functionality provided by the SOAP interface will change over time.
365 To the greatest extent possible, we will attempt to provide backwards
366 compatibility with previous versions; however, in order to have
367 backwards compatibility, you need to specify the version with which
372 sub __populate_version{
374 return $request->{___debbugs_soap_version};
377 sub __collapse_params{
381 # Because some clients can't handle passing arrayrefs, we allow
382 # options to be specified multiple times
383 while (my ($key,$value) = splice @params,0,2) {
384 push @{$params{$key}}, make_list($value);
386 # However, for singly specified options, we want to pull them
388 for my $key (keys %params) {
389 if (@{$params{$key}} == 1) {
390 ($params{$key}) = @{$params{$key}}