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