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');
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);
88 Returns an arrayref of hashrefs which output the status for specific
91 See L<Debbugs::Status::get_bug_status> for details.
96 my $VERSION = __populate_version(pop);
97 my ($self,@bugs) = @_;
98 @bugs = make_list(@bugs);
101 for my $bug (@bugs) {
102 my $bug_status = get_bug_status(bug => $bug);
103 if (defined $bug_status and keys %{$bug_status} > 0) {
104 $status{$bug} = $bug_status;
107 # __prepare_response($self);
113 my @bugs = get_bugs(...);
114 my @bugs = get_bugs([...]);
116 Returns a list of bugs. In the second case, allows the variable
117 parameters to be specified as an array reference in case your favorite
118 language's SOAP implementation is craptacular.
120 See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
125 use Debbugs::Bugs qw();
128 my $VERSION = __populate_version(pop);
129 my ($self,@params) = @_;
130 # Because some soap implementations suck and can't handle
131 # variable numbers of arguments we allow get_bugs([]);
132 if (@params == 1 and ref($params[0]) eq 'ARRAY') {
133 @params = @{$params[0]};
136 # Because some clients can't handle passing arrayrefs, we allow
137 # options to be specified multiple times
138 while (my ($key,$value) = splice @params,0,2) {
139 push @{$params{$key}}, make_list($value);
141 # However, for singly specified options, we want to pull them
143 for my $key (keys %params) {
144 if (@{$params{$key}} == 1) {
145 ($params{$key}) = @{$params{$key}}
149 @bugs = Debbugs::Bugs::get_bugs(%params);
155 my @bugs = newest_bugs(5);
157 Returns a list of the newest bugs. [Note that all bugs are *not*
158 guaranteed to exist, but they should in the most common cases.]
163 my $VERSION = __populate_version(pop);
164 my ($self,$num) = @_;
165 my $newest_bug = Debbugs::bugs::newest_bug();
166 return [($newest_bug - $num + 1) .. $newest_bug];
172 my $bug_log = get_bug_log($bug);
173 my $bug_log = get_bug_log($bug,$msg_num);
175 Retuns a parsed set of the bug log; this is an array of hashes with
192 Currently $msg_num is completely ignored.
196 use Debbugs::Log qw();
197 use Debbugs::MIME qw(parse);
200 my $VERSION = __populate_version(pop);
201 my ($self,$bug,$msg_num) = @_;
203 my $location = getbuglocation($bug,'log');
204 my $bug_log = getbugcomponent($bug,'log',$location);
206 my $log_fh = IO::File->new($bug_log, 'r') or
207 die "Unable to open bug log $bug_log for reading: $!";
209 my $log = Debbugs::Log->new($log_fh) or
210 die "Debbugs::Log was unable to be initialized";
216 while (my $record = $log->read_record()) {
218 #next if defined $msg_num and ($current_msg ne $msg_num);
219 next unless $record->{type} eq 'incoming-recv';
220 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
221 next if defined $msg_id and exists $seen_msg_ids{$msg_id};
222 $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
223 next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
224 my $message = parse($record->{text});
225 my ($header,$body) = map {join("\n",make_list($_))}
226 @{$message}{qw(header body)};
227 push @messages,{header => $header,
230 msg_num => $current_msg,
237 =head1 VERSION COMPATIBILITY
239 The functionality provided by the SOAP interface will change over time.
241 To the greatest extent possible, we will attempt to provide backwards
242 compatibility with previous versions; however, in order to have
243 backwards compatibility, you need to specify the version with which
248 sub __populate_version{
250 return $request->{___debbugs_soap_version};