X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FSOAP.pm;fp=Debbugs%2FSOAP.pm;h=0000000000000000000000000000000000000000;hb=1e6633a3780f4fd53fc4303852e84d13cdad2dc6;hp=a0c3cbf2190d06ea3f5b04dfb9d9278039929990;hpb=466f7faff129a5699c7674f59900a92aa256175d;p=debbugs.git diff --git a/Debbugs/SOAP.pm b/Debbugs/SOAP.pm deleted file mode 100644 index a0c3cbf..0000000 --- a/Debbugs/SOAP.pm +++ /dev/null @@ -1,406 +0,0 @@ -# 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 . - -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 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 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 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 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) - -=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 - -=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__ - - - - - -