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 Debbugs::Packages;
46 use Storable qw(nstore retrieve);
47 use Scalar::Util qw(looks_like_number);
50 our $CURRENT_VERSION = 1;
54 my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
55 my %ut = get_usertag('don@donarmstrong.com');
57 Returns a hashref of bugs which have the specified usertags for the
60 In the second case, returns all of the usertags for the user passed.
64 use Debbugs::User qw(read_usertags);
67 my $VERSION = __populate_version(pop);
68 my ($self,$email, @tags) = @_;
70 read_usertags(\%ut, $email);
72 @tags{@tags} = (1) x @tags;
74 for my $tag (keys %ut) {
75 delete $ut{$tag} unless exists $tags{$tag};
86 my @statuses = get_status(@bugs);
87 my @statuses = get_status([bug => 304234,
95 Returns an arrayref of hashrefs which output the status for specific
98 In the first case, no options are passed to
99 L<Debbugs::Status::get_bug_status> besides the bug number; in the
100 second the bug, dist, arch, bugusertags, sourceversions, and version
101 parameters are passed if they are present.
103 As a special case for suboptimal SOAP implementations, if only one
104 argument is passed to get_status and it is an arrayref which either is
105 empty, has a number as the first element, or contains an arrayref as
106 the first element, the outer arrayref is dereferenced, and processed
107 as in the examples above.
109 See L<Debbugs::Status::get_bug_status> for details.
114 my $VERSION = __populate_version(pop);
115 my ($self,@bugs) = @_;
121 looks_like_number($bugs[0][0])
127 for my $bug (@bugs) {
130 my %param = __collapse_params(@{$bug});
131 next unless defined $param{bug};
133 $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
134 qw(bug dist arch bugusertags sourceversions version indicatesource)
138 $bug_status = get_bug_status(bug => $bug);
140 if (defined $bug_status and keys %{$bug_status} > 0) {
141 $status{$bug} = $bug_status;
144 # __prepare_response($self);
150 my @bugs = get_bugs(...);
151 my @bugs = get_bugs([...]);
153 Returns a list of bugs. In the second case, allows the variable
154 parameters to be specified as an array reference in case your favorite
155 language's SOAP implementation is craptacular.
157 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
162 use Debbugs::Bugs qw();
165 my $VERSION = __populate_version(pop);
166 my ($self,@params) = @_;
167 # Because some soap implementations suck and can't handle
168 # variable numbers of arguments we allow get_bugs([]);
169 if (@params == 1 and ref($params[0]) eq 'ARRAY') {
170 @params = @{$params[0]};
172 my %params = __collapse_params(@params);
174 @bugs = Debbugs::Bugs::get_bugs(%params);
180 my @bugs = newest_bugs(5);
182 Returns a list of the newest bugs. [Note that all bugs are *not*
183 guaranteed to exist, but they should in the most common cases.]
188 my $VERSION = __populate_version(pop);
189 my ($self,$num) = @_;
190 my $newest_bug = Debbugs::Bugs::newest_bug();
191 return [($newest_bug - $num + 1) .. $newest_bug];
197 my $bug_log = get_bug_log($bug);
198 my $bug_log = get_bug_log($bug,$msg_num);
200 Retuns a parsed set of the bug log; this is an array of hashes with
217 Currently $msg_num is completely ignored.
221 use Debbugs::Log qw();
222 use Debbugs::MIME qw(parse);
225 my $VERSION = __populate_version(pop);
226 my ($self,$bug,$msg_num) = @_;
228 my $location = getbuglocation($bug,'log');
229 my $bug_log = getbugcomponent($bug,'log',$location);
231 my $log_fh = IO::File->new($bug_log, 'r') or
232 die "Unable to open bug log $bug_log for reading: $!";
234 my $log = Debbugs::Log->new($log_fh) or
235 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,
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 (This function corresponds to L<Debbugs::Packages::binarytosource>)
275 sub binary_to_source{
276 my $VERSION = __populate_version(pop);
277 my ($self,@params) = @_;
279 return [binarytosource(@params)];
282 =head2 source_to_binary
284 source_to_binary($source_name,$source_version);
286 Returns a reference to an array of references to binary package name,
287 version, and architecture corresponding to a given source package name
288 and version. In the case that the given name and version cannot be
289 found, the unversioned package to source map is consulted, and the
290 architecture is not returned.
292 (This function corresponds to L<Debbugs::Packages::sourcetobinary>)
296 sub source_to_binary {
297 my $VERSION = __populate_version(pop);
298 my ($self,@params) = @_;
300 return [source_to_binary(@params)];
305 get_version(package=>'foopkg',
310 Returns a list of the versions of package in the distributions and
311 architectures listed. This routine only returns unique values.
315 =item package -- package to return list of versions
317 =item dist -- distribution (unstable, stable, testing); can be an
320 =item arch -- architecture (i386, source, ...); can be an arrayref
322 =item time -- returns a version=>time hash at which the newest package
323 matching this version was uploaded
325 =item source -- returns source/version instead of just versions
327 =item no_source_arch -- discards the source architecture when arch is
328 not passed. [Used for finding the versions of binary packages only.]
329 Defaults to 0, which does not discard the source architecture. (This
330 may change in the future, so if you care, please code accordingly.)
332 =item return_archs -- returns a version=>[archs] hash indicating which
333 architectures are at which versions.
337 This function correponds to L<Debbugs::Packages::get_versions>
342 my $VERSION = __populate_version(pop);
343 my ($self,@params) = @_;
345 return scalar Debbugs::Packages::get_versions(@params);
348 =head1 VERSION COMPATIBILITY
350 The functionality provided by the SOAP interface will change over time.
352 To the greatest extent possible, we will attempt to provide backwards
353 compatibility with previous versions; however, in order to have
354 backwards compatibility, you need to specify the version with which
359 sub __populate_version{
361 return $request->{___debbugs_soap_version};
364 sub __collapse_params{
368 # Because some clients can't handle passing arrayrefs, we allow
369 # options to be specified multiple times
370 while (my ($key,$value) = splice @params,0,2) {
371 push @{$params{$key}}, make_list($value);
373 # However, for singly specified options, we want to pull them
375 for my $key (keys %params) {
376 if (@{$params{$key}} == 1) {
377 ($params{$key}) = @{$params{$key}}