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;
49 our %DEBBUGS_SOAP_COOKIES;
54 my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
56 Returns a hashref of bugs which have the specified usertags for the
61 use Debbugs::User qw(read_usertags);
64 my $VERSION = __populate_version(pop);
65 my ($self,$email, @tags) = @_;
67 read_usertags(\%ut, $email);
69 @tags{@tags} = (1) x @tags;
71 for my $tag (keys %ut) {
72 delete $ut{$tag} unless exists $tags{$tag};
83 my @statuses = get_status(@bugs);
85 Returns an arrayref of hashrefs which output the status for specific
88 See L<Debbugs::Status::get_bug_status> for details.
93 my $VERSION = __populate_version(pop);
94 my ($self,@bugs) = @_;
95 @bugs = make_list(@bugs);
99 my $bug_status = get_bug_status(bug => $bug);
100 if (defined $bug_status and keys %{$bug_status} > 0) {
101 $status{$bug} = $bug_status;
104 # __prepare_response($self);
110 my @bugs = get_bugs(...);
111 my @bugs = get_bugs([...]);
113 Returns a list of bugs. In the second case, allows the variable
114 parameters to be specified as an array reference in case your favorite
115 language's SOAP implementation is craptacular.
117 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
122 use Debbugs::Bugs qw();
125 my $VERSION = __populate_version(pop);
126 my ($self,@params) = @_;
127 # Because some soap implementations suck and can't handle
128 # variable numbers of arguments we allow get_bugs([]);
129 if (@params == 1 and ref($params[0]) eq 'ARRAY') {
130 @params = @{$params[0]};
133 # Because some clients can't handle passing arrayrefs, we allow
134 # options to be specified multiple times
135 while (my ($key,$value) = splice @params,0,2) {
136 push @{$params{$key}}, make_list($value);
138 # However, for singly specified options, we want to pull them
140 for my $key (keys %params) {
141 if (@{$params{$key}} == 1) {
142 ($params{$key}) = @{$params{$key}}
146 @bugs = Debbugs::Bugs::get_bugs(%params);
152 my @bugs = newest_bugs(5);
154 Returns a list of the newest bugs. [Note that all bugs are *not*
155 guaranteed to exist, but they should in the most common cases.]
160 my $VERSION = __populate_version(pop);
161 my ($self,$num) = @_;
162 my $newest_bug = Debbugs::bugs::newest_bug();
163 return [($newest_bug - $num + 1) .. $newest_bug];
169 my $bug_log = get_bug_log($bug);
170 my $bug_log = get_bug_log($bug,$msg_num);
172 Retuns a parsed set of the bug log; this is an array of hashes with
189 Currently $msg_num is completely ignored.
193 use Debbugs::Log qw();
194 use Debbugs::MIME qw(parse);
197 my $VERSION = __populate_version(pop);
198 my ($self,$bug,$msg_num) = @_;
200 my $location = getbuglocation($bug,'log');
201 my $bug_log = getbugcomponent($bug,'log',$location);
203 my $log_fh = IO::File->new($bug_log, 'r') or
204 die "Unable to open bug log $bug_log for reading: $!";
206 my $log = Debbugs::Log->new($log_fh) or
207 die "Debbugs::Log was unable to be initialized";
213 while (my $record = $log->read_record()) {
215 #next if defined $msg_num and ($current_msg ne $msg_num);
216 next unless $record->{type} eq 'incoming-recv';
217 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
218 next if defined $msg_id and exists $seen_msg_ids{$msg_id};
219 $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
220 next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
221 my $message = parse($record->{text});
222 my ($header,$body) = map {join("\n",make_list($_))}
223 @{$message}{qw(header body)};
224 push @messages,{header => $header,
227 msg_num => $current_msg,
234 =head1 VERSION COMPATIBILITY
236 The functionality provided by the SOAP interface will change over time.
238 To the greatest extent possible, we will attempt to provide backwards
239 compatibility with previous versions; however, in order to have
240 backwards compatibility, you need to specify the version with which
245 sub __populate_version{
247 return $request->{___debbugs_soap_version};