]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/SOAP.pm
merge changes from dla source branch
[debbugs.git] / Debbugs / SOAP.pm
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>.
5
6 package Debbugs::SOAP;
7
8 =head1 NAME
9
10 Debbugs::SOAP --
11
12 =head1 SYNOPSIS
13
14
15 =head1 DESCRIPTION
16
17
18 =head1 BUGS
19
20 None known.
21
22 =cut
23
24 use warnings;
25 use strict;
26 use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
27 use base qw(Exporter SOAP::Server::Parameters);
28
29 BEGIN{
30      $DEBUG = 0 unless defined $DEBUG;
31
32      @EXPORT = ();
33      %EXPORT_TAGS = (
34                     );
35      @EXPORT_OK = ();
36      Exporter::export_ok_tags();
37      $EXPORT_TAGS{all} = [@EXPORT_OK];
38
39 }
40
41
42 use IO::File;
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);
48
49
50 our $CURRENT_VERSION = 2;
51
52 =head2 get_usertag
53
54      my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
55      my %ut = get_usertag('don@donarmstrong.com');
56
57 Returns a hashref of bugs which have the specified usertags for the
58 user set.
59
60 In the second case, returns all of the usertags for the user passed.
61
62 =cut
63
64 use Debbugs::User qw(read_usertags);
65
66 sub get_usertag {
67      my $VERSION = __populate_version(pop);
68      my ($self,$email, @tags) = @_;
69      my %ut = ();
70      read_usertags(\%ut, $email);
71      my %tags;
72      @tags{@tags} = (1) x @tags;
73      if (keys %tags > 0) {
74           for my $tag (keys %ut) {
75                delete $ut{$tag} unless exists $tags{$tag};
76           }
77      }
78      return \%ut;
79 }
80
81
82 use Debbugs::Status;
83
84 =head2 get_status 
85
86      my @statuses = get_status(@bugs);
87      my @statuses = get_status([bug => 304234,
88                                 dist => 'unstable',
89                                ],
90                                [bug => 304233,
91                                 dist => 'unstable',
92                                ],
93                               )
94
95 Returns an arrayref of hashrefs which output the status for specific
96 sets of bugs.
97
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.
102
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.
108
109 See L<Debbugs::Status::get_bug_status> for details.
110
111 =cut
112
113 sub get_status {
114      my $VERSION = __populate_version(pop);
115      my ($self,@bugs) = @_;
116
117      if (@bugs == 1 and
118          ref($bugs[0]) and
119          (@{$bugs[0]} == 0 or
120           ref($bugs[0][0]) or
121           looks_like_number($bugs[0][0])
122          )
123         ) {
124               @bugs = @{$bugs[0]};
125      }
126      my %status;
127      for my $bug (@bugs) {
128           my $bug_status;
129           if (ref($bug)) {
130                my %param = __collapse_params(@{$bug});
131                next unless defined $param{bug};
132                $bug = $param{bug};
133                $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
134                                             qw(bug dist arch bugusertags sourceversions version indicatesource)
135                                            );
136           }
137           else {
138                $bug_status = get_bug_status(bug => $bug);
139           }
140           if (defined $bug_status and keys %{$bug_status} > 0) {
141                $status{$bug}  = $bug_status;
142           }
143      }
144 #     __prepare_response($self);
145      return \%status;
146 }
147
148 =head2 get_bugs
149
150      my @bugs = get_bugs(...);
151      my @bugs = get_bugs([...]);
152
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.
156
157 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
158 means.
159
160 =cut
161
162 use Debbugs::Bugs qw();
163
164 sub get_bugs{
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]};
171      }
172      my %params = __collapse_params(@params);
173      my @bugs;
174      @bugs = Debbugs::Bugs::get_bugs(%params);
175      return \@bugs;
176 }
177
178 =head2 newest_bugs
179
180      my @bugs = newest_bugs(5);
181
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.]
184
185 =cut
186
187 sub newest_bugs{
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];
192
193 }
194
195 =head2 get_bug_log
196
197      my $bug_log = get_bug_log($bug);
198      my $bug_log = get_bug_log($bug,$msg_num);
199
200 Retuns a parsed set of the bug log; this is an array of hashes with
201 the following
202
203  [{html => '',
204    header => '',
205    body    => '',
206    attachments => [],
207    msg_num     => 5,
208   },
209   {html => '',
210    header => '',
211    body    => '',
212    attachments => [],
213   },
214  ]
215
216
217 Currently $msg_num is completely ignored.
218
219 =cut
220
221 use Debbugs::Log qw();
222 use Debbugs::MIME qw(parse);
223
224 sub get_bug_log{
225      my $VERSION = __populate_version(pop);
226      my ($self,$bug,$msg_num) = @_;
227
228      my $log = Debbugs::Log->new(bug_num => $bug) or
229           die "Debbugs::Log was unable to be initialized";
230
231      my %seen_msg_ids;
232      my $current_msg=0;
233      my $status = {};
234      my @messages;
235      while (my $record = $log->read_record()) {
236           $current_msg++;
237           #next if defined $msg_num and ($current_msg ne $msg_num);
238           next unless $record->{type} eq 'incoming-recv';
239           my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
240           next if defined $msg_id and exists $seen_msg_ids{$msg_id};
241           $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
242           next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
243           my $message = parse($record->{text});
244           my ($header,$body) = map {join("\n",make_list($_))}
245                @{$message}{qw(header body)};
246           push @messages,{header => $header,
247                           body   => $body,
248                           attachments => [],
249                           msg_num => $current_msg,
250                          };
251      }
252      return \@messages;
253 }
254
255 =head2 binary_to_source
256
257      binary_to_source($binary_name,$binary_version,$binary_architecture)
258
259 Returns a reference to the source package name and version pair
260 corresponding to a given binary package name, version, and
261 architecture. If undef is passed as the architecture, returns a list
262 of references to all possible pairs of source package names and
263 versions for all architectures, with any duplicates removed.
264
265 As of comaptibility version 2, this has changed to use the more
266 powerful binary_to_source routine, which allows returning source only,
267 concatenated scalars, and other useful features.
268
269 See the documentation of L<Debbugs::Packages::binary_to_source> for
270 details.
271
272 =cut
273
274 sub binary_to_source{
275      my $VERSION = __populate_version(pop);
276      my ($self,@params) = @_;
277
278      if ($VERSION <= 1) {
279          return [Debbugs::Packages::binary_to_source(binary => $params[0],
280                                                      (@params > 1)?(version => $params[1]):(),
281                                                      (@params > 2)?(arch    => $params[2]):(),
282                                                     )];
283      }
284      else {
285          return [Debbugs::Packages::binary_to_source(@params)];
286      }
287 }
288
289 =head2 source_to_binary
290
291      source_to_binary($source_name,$source_version);
292
293 Returns a reference to an array of references to binary package name,
294 version, and architecture corresponding to a given source package name
295 and version. In the case that the given name and version cannot be
296 found, the unversioned package to source map is consulted, and the
297 architecture is not returned.
298
299 (This function corresponds to L<Debbugs::Packages::sourcetobinary>)
300
301 =cut
302
303 sub source_to_binary {
304      my $VERSION = __populate_version(pop);
305      my ($self,@params) = @_;
306
307      return [Debbugs::Packages::sourcetobinary(@params)];
308 }
309
310 =head2 get_versions
311
312      get_version(package=>'foopkg',
313                  dist => 'unstable',
314                  arch => 'i386',
315                 );
316
317 Returns a list of the versions of package in the distributions and
318 architectures listed. This routine only returns unique values.
319
320 =over
321
322 =item package -- package to return list of versions
323
324 =item dist -- distribution (unstable, stable, testing); can be an
325 arrayref
326
327 =item arch -- architecture (i386, source, ...); can be an arrayref
328
329 =item time -- returns a version=>time hash at which the newest package
330 matching this version was uploaded
331
332 =item source -- returns source/version instead of just versions
333
334 =item no_source_arch -- discards the source architecture when arch is
335 not passed. [Used for finding the versions of binary packages only.]
336 Defaults to 0, which does not discard the source architecture. (This
337 may change in the future, so if you care, please code accordingly.)
338
339 =item return_archs -- returns a version=>[archs] hash indicating which
340 architectures are at which versions.
341
342 =back
343
344 This function correponds to L<Debbugs::Packages::get_versions>
345
346 =cut
347
348 sub get_versions{
349      my $VERSION = __populate_version(pop);
350      my ($self,@params) = @_;
351
352      return scalar Debbugs::Packages::get_versions(@params);
353 }
354
355 =head1 VERSION COMPATIBILITY
356
357 The functionality provided by the SOAP interface will change over time.
358
359 To the greatest extent possible, we will attempt to provide backwards
360 compatibility with previous versions; however, in order to have
361 backwards compatibility, you need to specify the version with which
362 you are compatible.
363
364 =cut
365
366 sub __populate_version{
367      my ($request) = @_;
368      return $request->{___debbugs_soap_version};
369 }
370
371 sub __collapse_params{
372      my @params = @_;
373
374      my %params;
375      # Because some clients can't handle passing arrayrefs, we allow
376      # options to be specified multiple times
377      while (my ($key,$value) = splice @params,0,2) {
378           push @{$params{$key}}, make_list($value);
379      }
380      # However, for singly specified options, we want to pull them
381      # back out
382      for my $key (keys %params) {
383           if (@{$params{$key}} == 1) {
384                ($params{$key}) = @{$params{$key}}
385           }
386      }
387      return %params;
388 }
389
390
391 1;
392
393
394 __END__
395
396
397
398
399
400