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 Storable qw(nstore retrieve);
48 our $CURRENT_VERSION = 1;
52 my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
53 my %ut = get_usertag('don@donarmstrong.com');
55 Returns a hashref of bugs which have the specified usertags for the
58 In the second case, returns all of the usertags for the user passed.
62 use Debbugs::User qw(read_usertags);
65 my $VERSION = __populate_version(pop);
66 my ($self,$email, @tags) = @_;
68 read_usertags(\%ut, $email);
70 @tags{@tags} = (1) x @tags;
72 for my $tag (keys %ut) {
73 delete $ut{$tag} unless exists $tags{$tag};
84 my @statuses = get_status(@bugs);
85 my @statuses = get_status([bug => 304234,
93 Returns an arrayref of hashrefs which output the status for specific
96 In the first case, no options are passed to
97 L<Debbugs::Status::get_bug_status> besides the bug number; in the
98 second the bug, dist, arch, bugusertags, sourceversions, and version
99 parameters are passed if they are present.
101 See L<Debbugs::Status::get_bug_status> for details.
106 my $VERSION = __populate_version(pop);
107 my ($self,@bugs) = @_;
110 for my $bug (@bugs) {
113 my %param = __collapse_params(@{$bug});
114 $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
115 qw(bug dist arch bugusertags sourceversions version)
119 $bug_status = get_bug_status(bug => $bug);
121 if (defined $bug_status and keys %{$bug_status} > 0) {
122 $status{$bug} = $bug_status;
125 # __prepare_response($self);
131 my @bugs = get_bugs(...);
132 my @bugs = get_bugs([...]);
134 Returns a list of bugs. In the second case, allows the variable
135 parameters to be specified as an array reference in case your favorite
136 language's SOAP implementation is craptacular.
138 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
143 use Debbugs::Bugs qw();
146 my $VERSION = __populate_version(pop);
147 my ($self,@params) = @_;
148 # Because some soap implementations suck and can't handle
149 # variable numbers of arguments we allow get_bugs([]);
150 if (@params == 1 and ref($params[0]) eq 'ARRAY') {
151 @params = @{$params[0]};
153 my %params = __collapse_params(@params);
155 @bugs = Debbugs::Bugs::get_bugs(%params);
161 my @bugs = newest_bugs(5);
163 Returns a list of the newest bugs. [Note that all bugs are *not*
164 guaranteed to exist, but they should in the most common cases.]
169 my $VERSION = __populate_version(pop);
170 my ($self,$num) = @_;
171 my $newest_bug = Debbugs::Bugs::newest_bug();
172 return [($newest_bug - $num + 1) .. $newest_bug];
178 my $bug_log = get_bug_log($bug);
179 my $bug_log = get_bug_log($bug,$msg_num);
181 Retuns a parsed set of the bug log; this is an array of hashes with
198 Currently $msg_num is completely ignored.
202 use Debbugs::Log qw();
203 use Debbugs::MIME qw(parse);
206 my $VERSION = __populate_version(pop);
207 my ($self,$bug,$msg_num) = @_;
209 my $location = getbuglocation($bug,'log');
210 my $bug_log = getbugcomponent($bug,'log',$location);
212 my $log_fh = IO::File->new($bug_log, 'r') or
213 die "Unable to open bug log $bug_log for reading: $!";
215 my $log = Debbugs::Log->new($log_fh) or
216 die "Debbugs::Log was unable to be initialized";
222 while (my $record = $log->read_record()) {
224 #next if defined $msg_num and ($current_msg ne $msg_num);
225 next unless $record->{type} eq 'incoming-recv';
226 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
227 next if defined $msg_id and exists $seen_msg_ids{$msg_id};
228 $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
229 next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
230 my $message = parse($record->{text});
231 my ($header,$body) = map {join("\n",make_list($_))}
232 @{$message}{qw(header body)};
233 push @messages,{header => $header,
236 msg_num => $current_msg,
243 =head1 VERSION COMPATIBILITY
245 The functionality provided by the SOAP interface will change over time.
247 To the greatest extent possible, we will attempt to provide backwards
248 compatibility with previous versions; however, in order to have
249 backwards compatibility, you need to specify the version with which
254 sub __populate_version{
256 return $request->{___debbugs_soap_version};
259 sub __collapse_params{
263 # Because some clients can't handle passing arrayrefs, we allow
264 # options to be specified multiple times
265 while (my ($key,$value) = splice @params,0,2) {
266 push @{$params{$key}}, make_list($value);
268 # However, for singly specified options, we want to pull them
270 for my $key (keys %params) {
271 if (@{$params{$key}} == 1) {
272 ($params{$key}) = @{$params{$key}}