libdebbugs-perl 2.6.0 / usr / share / perl5 / Debbugs / SOAP.pm

# This module is part of debbugs, and is released
# under the terms of the GPL version 2, or any later version at your option.
# See the file README and COPYING for more information.
# Copyright 2007 by Don Armstrong <don@donarmstrong.com>.

package Debbugs::SOAP;

=head1 NAME

Debbugs::SOAP --

=head1 SYNOPSIS


=head1 DESCRIPTION


=head1 BUGS

None known.

=cut

use warnings;
use strict;
use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
use Debbugs::SOAP::Server;
use Exporter qw(import);
use base qw(SOAP::Server::Parameters);

BEGIN{
     $DEBUG = 0 unless defined $DEBUG;

     @EXPORT = ();
     %EXPORT_TAGS = (
		    );
     @EXPORT_OK = ();
     Exporter::export_ok_tags();
     $EXPORT_TAGS{all} = [@EXPORT_OK];

}

use IO::File;
use Debbugs::Status qw(get_bug_status);
use Debbugs::Common qw(make_list getbuglocation getbugcomponent);
use Debbugs::UTF8;
use Debbugs::Packages;

use Storable qw(nstore retrieve dclone);
use Scalar::Util qw(looks_like_number);


our $CURRENT_VERSION = 2;

=head2 get_usertag

     my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
     my %ut = get_usertag('don@donarmstrong.com');

Returns a hashref of bugs which have the specified usertags for the
user set.

In the second case, returns all of the usertags for the user passed.

=cut

use Debbugs::User qw(read_usertags);

sub get_usertag {
     my $VERSION = __populate_version(pop);
     my ($self,$email, @tags) = @_;
     my %ut = ();
     read_usertags(\%ut, $email);
     my %tags;
     @tags{@tags} = (1) x @tags;
     if (keys %tags > 0) {
	  for my $tag (keys %ut) {
	       delete $ut{$tag} unless exists $tags{$tag};
	  }
     }
     return encode_utf8_structure(\%ut);
}


use Debbugs::Status;

=head2 get_status 

     my @statuses = get_status(@bugs);
     my @statuses = get_status([bug => 304234,
                                dist => 'unstable',
                               ],
                               [bug => 304233,
                                dist => 'unstable',
                               ],
                              )

Returns an arrayref of hashrefs which output the status for specific
sets of bugs.

In the first case, no options are passed to
L<Debbugs::Status::get_bug_status> besides the bug number; in the
second the bug, dist, arch, bugusertags, sourceversions, and version
parameters are passed if they are present.

As a special case for suboptimal SOAP implementations, if only one
argument is passed to get_status and it is an arrayref which either is
empty, has a number as the first element, or contains an arrayref as
the first element, the outer arrayref is dereferenced, and processed
as in the examples above.

See L<Debbugs::Status::get_bug_status> for details.

=cut

sub get_status {
     my $VERSION = __populate_version(pop);
     my ($self,@bugs) = @_;

     if (@bugs == 1 and
	 ref($bugs[0]) and
	 (@{$bugs[0]} == 0 or
	  ref($bugs[0][0]) or
	  looks_like_number($bugs[0][0])
	 )
	) {
	      @bugs = @{$bugs[0]};
     }
     my %status;
     my %binary_to_source_cache;
     for my $bug (@bugs) {
	  my $bug_status;
	  if (ref($bug)) {
	       my %param = __collapse_params(@{$bug});
	       next unless defined $param{bug};
	       $bug = $param{bug};
	       $bug_status = get_bug_status(map {(exists $param{$_})?($_,$param{$_}):()}
					    qw(bug dist arch bugusertags sourceversions version indicatesource),
					    binary_to_source_cache => \%binary_to_source_cache,
					   );
	  }
	  else {
	      $bug_status = get_bug_status(bug => $bug,
					   binary_to_source_cache => \%binary_to_source_cache,
					  );
	  }
	  if (defined $bug_status and keys %{$bug_status} > 0) {
	       $status{$bug}  = $bug_status;
	  }
     }
#     __prepare_response($self);
     return encode_utf8_structure(\%status);
}

=head2 get_bugs

     my @bugs = get_bugs(...);
     my @bugs = get_bugs([...]);

Returns a list of bugs. In the second case, allows the variable
parameters to be specified as an array reference in case your favorite
language's SOAP implementation is craptacular.

See L<Debbugs::Bugs::get_bugs> for details on what C<...> actually
means.

=cut

use Debbugs::Bugs qw();

sub get_bugs{
     my $VERSION = __populate_version(pop);
     my ($self,@params) = @_;
     # Because some soap implementations suck and can't handle
     # variable numbers of arguments we allow get_bugs([]);
     if (@params == 1 and ref($params[0]) eq 'ARRAY') {
	  @params = @{$params[0]};
     }
     my %params = __collapse_params(@params);
     my @bugs;
     @bugs = Debbugs::Bugs::get_bugs(%params);
     return encode_utf8_structure(\@bugs);
}

=head2 newest_bugs

     my @bugs = newest_bugs(5);

Returns a list of the newest bugs. [Note that all bugs are *not*
guaranteed to exist, but they should in the most common cases.]

=cut

sub newest_bugs{
     my $VERSION = __populate_version(pop);
     my ($self,$num) = @_;
     my $newest_bug = Debbugs::Bugs::newest_bug();
     return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]);

}

=head2 get_bug_log

     my $bug_log = get_bug_log($bug);
     my $bug_log = get_bug_log($bug,$msg_num);

Retuns a parsed set of the bug log; this is an array of hashes with
the following

 [{html => '',
   header => '',
   body    => '',
   attachments => [],
   msg_num     => 5,
  },
  {html => '',
   header => '',
   body    => '',
   attachments => [],
  },
 ]


Currently $msg_num is completely ignored.

=cut

use Debbugs::Log qw();
use Debbugs::MIME qw(parse);

sub get_bug_log{
     my $VERSION = __populate_version(pop);
     my ($self,$bug,$msg_num) = @_;

     my $log = Debbugs::Log->new(bug_num => $bug) or
	  die "Debbugs::Log was unable to be initialized";

     my %seen_msg_ids;
     my $current_msg=0;
     my @messages;
     while (my $record = $log->read_record()) {
	  $current_msg++;
	  #next if defined $msg_num and ($current_msg ne $msg_num);
	  next unless $record->{type} eq 'incoming-recv';
	  my ($msg_id) = $record->{text} =~ /^Message-Id:\s+<(.+)>/im;
	  next if defined $msg_id and exists $seen_msg_ids{$msg_id};
	  $seen_msg_ids{$msg_id} = 1 if defined $msg_id;
	  next if defined $msg_id and $msg_id =~ /handler\..+\.ack(?:info)?\@/;
	  my $message = parse($record->{text});
	  my ($header,$body) = map {join("\n",make_list($_))}
	       @{$message}{qw(header body)};
	  push @messages,{header => $header,
			  body   => $body,
			  attachments => [],
			  msg_num => $current_msg,
			 };
     }
     return encode_utf8_structure(\@messages);
}

=head2 binary_to_source

     binary_to_source($binary_name,$binary_version,$binary_architecture)

Returns a reference to the source package name and version pair
corresponding to a given binary package name, version, and
architecture. If undef is passed as the architecture, returns a list
of references to all possible pairs of source package names and
versions for all architectures, with any duplicates removed.

As of comaptibility version 2, this has changed to use the more
powerful binary_to_source routine, which allows returning source only,
concatenated scalars, and other useful features.

See the documentation of L<Debbugs::Packages::binary_to_source> for
details.

=cut

sub binary_to_source{
     my $VERSION = __populate_version(pop);
     my ($self,@params) = @_;

     if ($VERSION <= 1) {
	 return encode_utf8_structure([Debbugs::Packages::binary_to_source(binary => $params[0],
						     (@params > 1)?(version => $params[1]):(),
						     (@params > 2)?(arch    => $params[2]):(),
						    )]);
     }
     else {
	 return encode_utf8_structure([Debbugs::Packages::binary_to_source(@params)]);
     }
}

=head2 source_to_binary

     source_to_binary($source_name,$source_version);

Returns a reference to an array of references to binary package name,
version, and architecture corresponding to a given source package name
and version. In the case that the given name and version cannot be
found, the unversioned package to source map is consulted, and the
architecture is not returned.

(This function corresponds to L<Debbugs::Packages::sourcetobinary>)

=cut

sub source_to_binary {
     my $VERSION = __populate_version(pop);
     my ($self,@params) = @_;

     return encode_utf8_structure([Debbugs::Packages::sourcetobinary(@params)]);
}

=head2 get_versions

     get_version(package=>'foopkg',
                 dist => 'unstable',
                 arch => 'i386',
                );

Returns a list of the versions of package in the distributions and
architectures listed. This routine only returns unique values.

=over

=item package -- package to return list of versions

=item dist -- distribution (unstable, stable, testing); can be an
arrayref

=item arch -- architecture (i386, source, ...); can be an arrayref

=item time -- returns a version=>time hash at which the newest package
matching this version was uploaded

=item source -- returns source/version instead of just versions

=item no_source_arch -- discards the source architecture when arch is
not passed. [Used for finding the versions of binary packages only.]
Defaults to 0, which does not discard the source architecture. (This
may change in the future, so if you care, please code accordingly.)

=item return_archs -- returns a version=>[archs] hash indicating which
architectures are at which versions.

=back

This function corresponds to L<Debbugs::Packages::get_versions>

=cut

sub get_versions{
     my $VERSION = __populate_version(pop);
     my ($self,@params) = @_;

     return encode_utf8_structure(scalar Debbugs::Packages::get_versions(@params));
}

=head1 VERSION COMPATIBILITY

The functionality provided by the SOAP interface will change over time.

To the greatest extent possible, we will attempt to provide backwards
compatibility with previous versions; however, in order to have
backwards compatibility, you need to specify the version with which
you are compatible.

=cut

sub __populate_version{
     my ($request) = @_;
     return $request->{___debbugs_soap_version};
}

sub __collapse_params{
     my @params = @_;

     my %params;
     # Because some clients can't handle passing arrayrefs, we allow
     # options to be specified multiple times
     while (my ($key,$value) = splice @params,0,2) {
	  push @{$params{$key}}, make_list($value);
     }
     # However, for singly specified options, we want to pull them
     # back out
     for my $key (keys %params) {
	  if (@{$params{$key}} == 1) {
	       ($params{$key}) = @{$params{$key}}
	  }
     }
     return %params;
}


1;


__END__