X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=Debbugs%2FSOAP.pm;h=5cb08bb0f11eff7de6ab49dea880731a13dcb8b3;hb=e0b92922e7d92a6f1d0f6a91a5e6c3b3d174ae1c;hp=4a96b22cd6e13cc6cab873effc628be9aec3f345;hpb=35a7ee2e49868faa8b349ac1897e58d9a3d18e37;p=debbugs.git diff --git a/Debbugs/SOAP.pm b/Debbugs/SOAP.pm index 4a96b22..5cb08bb 100644 --- a/Debbugs/SOAP.pm +++ b/Debbugs/SOAP.pm @@ -24,6 +24,7 @@ None known. use warnings; use strict; use vars qw($DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT); +use Debbugs::SOAP::Server; use base qw(Exporter SOAP::Server::Parameters); BEGIN{ @@ -38,24 +39,27 @@ BEGIN{ } - use IO::File; use Debbugs::Status qw(get_bug_status); -use Debbugs::Common qw(make_list getbuglocation getbugcomponent); -use Storable qw(nstore retrieve); +use Debbugs::Common qw(make_list getbuglocation getbugcomponent :utf8); +use Debbugs::Packages; +use Storable qw(nstore retrieve dclone); +use Scalar::Util qw(looks_like_number); -our $CURRENT_VERSION = 1; -our %DEBBUGS_SOAP_COOKIES; +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); @@ -72,7 +76,7 @@ sub get_usertag { delete $ut{$tag} unless exists $tags{$tag}; } } - return \%ut; + return encode_utf8_structure(\%ut); } @@ -81,10 +85,28 @@ 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 @@ -92,17 +114,36 @@ See L for details. sub get_status { my $VERSION = __populate_version(pop); my ($self,@bugs) = @_; - @bugs = make_list(@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; for my $bug (@bugs) { - my $bug_status = get_bug_status(bug => $bug); + 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) + ); + } + else { + $bug_status = get_bug_status(bug => $bug); + } if (defined $bug_status and keys %{$bug_status} > 0) { $status{$bug} = $bug_status; } } # __prepare_response($self); - return \%status; + return encode_utf8_structure(\%status); } =head2 get_bugs @@ -129,22 +170,10 @@ sub get_bugs{ if (@params == 1 and ref($params[0]) eq 'ARRAY') { @params = @{$params[0]}; } - 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}} - } - } + my %params = __collapse_params(@params); my @bugs; @bugs = Debbugs::Bugs::get_bugs(%params); - return \@bugs; + return encode_utf8_structure(\@bugs); } =head2 newest_bugs @@ -159,8 +188,8 @@ guaranteed to exist, but they should in the most common cases.] sub newest_bugs{ my $VERSION = __populate_version(pop); my ($self,$num) = @_; - my $newest_bug = Debbugs::bugs::newest_bug(); - return [($newest_bug - $num + 1) .. $newest_bug]; + my $newest_bug = Debbugs::Bugs::newest_bug(); + return encode_utf8_structure([($newest_bug - $num + 1) .. $newest_bug]); } @@ -197,13 +226,7 @@ sub get_bug_log{ my $VERSION = __populate_version(pop); my ($self,$bug,$msg_num) = @_; - my $location = getbuglocation($bug,'log'); - my $bug_log = getbugcomponent($bug,'log',$location); - - my $log_fh = IO::File->new($bug_log, 'r') or - die "Unable to open bug log $bug_log for reading: $!"; - - my $log = Debbugs::Log->new($log_fh) or + my $log = Debbugs::Log->new(bug_num => $bug) or die "Debbugs::Log was unable to be initialized"; my %seen_msg_ids; @@ -227,9 +250,108 @@ sub get_bug_log{ msg_num => $current_msg, }; } - return \@messages; + 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 correponds 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 @@ -247,6 +369,26 @@ sub __populate_version{ 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;