]> git.donarmstrong.com Git - debbugs.git/blob - Debbugs/SOAP.pm
7ab55e2b04255561f089b0a2061385b4303f818c
[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 Storable qw(nstore retrieve);
46
47
48 our $CURRENT_VERSION = 1;
49 our %DEBBUGS_SOAP_COOKIES;
50
51
52 =head2 get_usertag
53
54      my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
55
56 Returns a hashref of bugs which have the specified usertags for the
57 user set.
58
59 =cut
60
61 use Debbugs::User qw(read_usertags);
62
63 sub get_usertag {
64      my $VERSION = __populate_version(pop);
65      my ($self,$email, @tags) = @_;
66      my %ut = ();
67      read_usertags(\%ut, $email);
68      my %tags;
69      @tags{@tags} = (1) x @tags;
70      if (keys %tags > 0) {
71           for my $tag (keys %ut) {
72                delete $ut{$tag} unless exists $tags{$tag};
73           }
74      }
75      return \%ut;
76 }
77
78
79 use Debbugs::Status;
80
81 =head2 get_status 
82
83      my @statuses = get_status(@bugs);
84
85 Returns an arrayref of hashrefs which output the status for specific
86 sets of bugs.
87
88 See L<Debbugs::Status::get_bug_status> for details.
89
90 =cut
91
92 sub get_status {
93      my $VERSION = __populate_version(pop);
94      my ($self,@bugs) = @_;
95      @bugs = make_list(@bugs);
96
97      my %status;
98      for my $bug (@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;
102           }
103      }
104 #     __prepare_response($self);
105      return \%status;
106 }
107
108 =head2 get_bugs
109
110      my @bugs = get_bugs(...);
111
112 See L<Debbugs::Bugs::get_bugs> for details.
113
114 =cut
115
116 use Debbugs::Bugs qw();
117
118 sub get_bugs{
119      my $VERSION = __populate_version(pop);
120      my ($self,@params) = @_;
121      my %params;
122      while (my ($key,$value) = splice @params,0,2) {
123           push @{$params{$key}}, make_list($value);
124      }
125      my @bugs;
126      @bugs = Debbugs::Bugs::get_bugs(%params);
127      return \@bugs;
128 }
129
130
131 =head2 get_bug_log
132
133      my $bug_log = get_bug_log($bug);
134      my $bug_log = get_bug_log($bug,$msg_num);
135
136 Retuns a parsed set of the bug log; this is an array of hashes with
137 the following
138
139  [{html => '',
140    header => '',
141    body    => '',
142    attachments => [],
143    msg_num     => 5,
144   },
145   {html => '',
146    header => '',
147    body    => '',
148    attachments => [],
149   },
150  ]
151
152
153 =cut
154
155 use Debbugs::Log qw();
156 use Debbugs::MIME qw(parse);
157
158 sub get_bug_log{
159      my ($self,$bug,$msg_num) = @_;
160
161      my $location = getbuglocation($bug,'log');
162      my $bug_log = getbugcomponent($bug,'log',$location);
163
164      my $log_fh = IO::File->new($bug_log, 'r') or
165           die "Unable to open bug log $bug_log for reading: $!";
166
167      my $log = Debbugs::Log->new($log_fh) or
168           die "Debbugs::Log was unable to be initialized";
169
170      my %seen_msg_ids;
171      my $current_msg=0;
172      my $status = {};
173      my @messages;
174      while (my $record = $log->read_record()) {
175           $current_msg++;
176           print STDERR "message $current_msg\n";
177           #next if defined $msg_num and ($current_msg ne $msg_num);
178           print STDERR "still message $current_msg\n";
179           next unless $record->{type} eq 'incoming-recv';
180           my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
181           next if defined $msg_id and exists $seen_msg_ids{$msg_id};
182           $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
183           next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
184           my $message = parse($record->{text});
185           my ($header,$body) = map {join("\n",make_list($_))}
186                values %{$message};
187           print STDERR "still still message $current_msg\n";
188           push @messages,{html => $record->{html},
189                           header => $header,
190                           body   => $body,
191                           attachments => [],
192                           msg_num => $current_msg,
193                          };
194      }
195      return \@messages;
196 }
197
198
199 =head1 VERSION COMPATIBILITY
200
201 The functionality provided by the SOAP interface will change over time.
202
203 To the greatest extent possible, we will attempt to provide backwards
204 compatibility with previous versions; however, in order to have
205 backwards compatibility, you need to specify the version with which
206 you are compatible.
207
208 =cut
209
210 sub __populate_version{
211      my ($request) = @_;
212      return $request->{___debbugs_soap_version};
213 }
214
215 1;
216
217
218 __END__
219
220
221
222
223
224