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(...);
112 Returns a list of bugs.
114 See L<Debbugs::Bugs::get_bugs> for details.
118 use Debbugs::Bugs qw();
121 my $VERSION = __populate_version(pop);
122 my ($self,@params) = @_;
124 # Because some clients can't handle passing arrayrefs, we allow
125 # options to be specified multiple times
126 while (my ($key,$value) = splice @params,0,2) {
127 push @{$params{$key}}, make_list($value);
129 # However, for singly specified options, we want to pull them
131 for my $key (keys %params) {
132 if (@{$params{$key}} == 1) {
133 ($params{$key}) = @{$params{$key}}
137 @bugs = Debbugs::Bugs::get_bugs(%params);
143 my @bugs = newest_bugs(5);
145 Returns a list of the newest bugs. [Note that all bugs are *not*
146 guaranteed to exist, but they should in the most common cases.]
151 my $VERSION = __populate_version(pop);
152 my ($self,$num) = @_;
153 my $newest_bug = Debbugs::bugs::newest_bug();
154 return [($newest_bug - $num + 1) .. $newest_bug];
160 my $bug_log = get_bug_log($bug);
161 my $bug_log = get_bug_log($bug,$msg_num);
163 Retuns a parsed set of the bug log; this is an array of hashes with
182 use Debbugs::Log qw();
183 use Debbugs::MIME qw(parse);
186 my ($self,$bug,$msg_num) = @_;
188 my $location = getbuglocation($bug,'log');
189 my $bug_log = getbugcomponent($bug,'log',$location);
191 my $log_fh = IO::File->new($bug_log, 'r') or
192 die "Unable to open bug log $bug_log for reading: $!";
194 my $log = Debbugs::Log->new($log_fh) or
195 die "Debbugs::Log was unable to be initialized";
201 while (my $record = $log->read_record()) {
203 #next if defined $msg_num and ($current_msg ne $msg_num);
204 next unless $record->{type} eq 'incoming-recv';
205 my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
206 next if defined $msg_id and exists $seen_msg_ids{$msg_id};
207 $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
208 next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
209 my $message = parse($record->{text});
210 my ($header,$body) = map {join("\n",make_list($_))}
211 @{$message}{qw(header body)};
212 push @messages,{header => $header,
215 msg_num => $current_msg,
222 =head1 VERSION COMPATIBILITY
224 The functionality provided by the SOAP interface will change over time.
226 To the greatest extent possible, we will attempt to provide backwards
227 compatibility with previous versions; however, in order to have
228 backwards compatibility, you need to specify the version with which
233 sub __populate_version{
235 return $request->{___debbugs_soap_version};