--- /dev/null
+# 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 base qw(Exporter SOAP::Server::Parameters);
+
+BEGIN{
+ $DEBUG = 0 unless defined $DEBUG;
+
+ @EXPORT = ();
+ %EXPORT_TAGS = (
+ );
+ @EXPORT_OK = ();
+ Exporter::export_ok_tags();
+ $EXPORT_TAGS{all} = [@EXPORT_OK];
+
+}
+
+
+use Debbugs::Status qw(get_bug_status);
+use Debbugs::Common qw(make_list);
+use Storable qw(nstore retrieve);
+use Debbugs::Cookies;
+
+
+our $CURRENT_VERSION = 1;
+our %DEBBUGS_SOAP_COOKIES;
+
+
+=head2 get_usertag
+
+ my %ut = get_usertag('don@donarmstrong.com','this-bug-sucks','eat-this-bug');
+
+Returns a hashref of bugs which have the specified usertags for the
+user set.
+
+=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 \%ut;
+}
+
+
+use Debbugs::Status;
+
+=head2 get_status
+
+ my @statuses = get_status(@bugs);
+
+Returns an arrayref of hashrefs which output the status for specific
+sets of bugs.
+
+See L<Debbugs::Status::get_bug_status> for details.
+
+=cut
+
+sub get_status {
+ my $VERSION = __populate_version(pop);
+ my ($self,@bugs) = @_;
+ @bugs = make_list(@bugs);
+
+ my %status;
+ for my $bug (@bugs) {
+ my $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;
+}
+
+=head2 get_bugs
+
+ my @bugs = get_bugs(...);
+
+See L<Debbugs::Bugs::get_bugs> for details.
+
+=cut
+
+use Debbugs::Bugs qw();
+
+sub get_bugs{
+ my $VERSION = __populate_version(pop);
+ my ($self,@params) = @_;
+ my %params;
+ while (my ($key,$value) = splice @params,0,2) {
+ push @{$params{$key}}, $value;
+ }
+ my @bugs;
+ @bugs = Debbugs::Bugs::get_bugs(%params);
+ return \@bugs;
+}
+
+
+=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};
+}
+
+1;
+
+
+__END__
+
+
+
+
+
+
--- /dev/null
+# 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::Server;
+
+=head1 NAME
+
+Debbugs::SOAP::Server -- Server Transport module
+
+=head1 SYNOPSIS
+
+
+=head1 DESCRIPTION
+
+
+=head1 BUGS
+
+None known.
+
+=cut
+
+use warnings;
+use strict;
+use vars qw(@ISA);
+use SOAP::Transport::HTTP;
+BEGIN{
+ # Eventually we'll probably change this to just be HTTP::Server and
+ # have the soap.cgi declare a class which inherits from both
+ push @ISA,qw(SOAP::Transport::HTTP::CGI);
+}
+
+use Debbugs::SOAP;
+
+sub find_target {
+ my ($self,$request) = @_;
+
+ # WTF does this do?
+ $request->match((ref $request)->method);
+ my $method_uri = $request->namespaceuriof || 'Debbugs/SOAP';
+ my $method_name = $request->dataof->name;
+ $method_uri =~ s{(?:/?Status/?|/?Usertag/?)}{};
+ $method_uri =~ s{(Debbugs/SOAP/)[vV](\d+)/?}{$1};
+ my ($soap_version) = $2 if defined $2;
+ $self->dispatched('Debbugs:::SOAP');
+ $request->{___debbugs_soap_version} = $soap_version || '';
+ return ('Debbugs::SOAP',$method_uri,$method_name);
+}
+
+
+1;
+
+
+__END__
+
+
+
+
+
+
+++ /dev/null
-package Debbugs::SOAP::Status;
-
-# This is a hack that must be removed
-require '/home/don/projects/debbugs/source/cgi/common.pl';
-#use Debbugs::Status qw(getbugstatus);
-
-sub get_status {
- my ($class, @bugs) = @_;
- @bugs = map {ref($_)?@{$_}:$_} @bugs;
-
- my %s;
- foreach (@bugs) {
- my $hash = getbugstatus($_);
- if (scalar(%{$hash}) > 0) {
- $s{$_} = $hash;
- }
- }
-
- return \%s;
-}
-
-1;
+++ /dev/null
-package Debbugs::SOAP::Usertag;
-
-use Debbugs::User;
-
-sub get_usertag {
- my ($class, $email, $tag) = @_;
- my %ut = ();
- Debbugs::User::read_usertags(\%ut, $email);
- if (defined($tag) and $tag ne "") {
- # Remove unwanted tags
- foreach (keys %ut) {
- delete $ut{$_} unless $_ eq $tag;
- }
- }
- return \%ut;
-}
-
-1;
}
else {
my $location = getbuglocation($param{bug}, 'summary');
- return {} if not length $location;
+ return {} if not defined $location or not length $location;
%status = %{ readbug( $param{bug}, $location ) };
}
$status{id} = $param{bug};
#!/usr/bin/perl -wT
-package debbugs;
-
-use SOAP::Transport::HTTP;
+#use SOAP::Transport::HTTP;
use Debbugs::SOAP::Usertag;
use Debbugs::SOAP::Status;
+use Debbugs::SOAP::Server;
+
+# Work around stupid soap bug on line 411
+if (not exists $ENV{EXPECT}) {
+ $ENV{EXPECT} = '';
+}
-my $soap = SOAP::Transport::HTTP::CGI
- -> dispatch_to('Debbugs::SOAP::Usertag', 'Debbugs::SOAP::Status');
-$soap->serializer()->soapversion(1.2);
+my $soap = Debbugs::SOAP::Server
+#my $soap = SOAP::Transport::HTTP::CGI
+ -> dispatch_to('Debbugs::SOAP');
+#$soap->serializer()->soapversion(1.2);
# soapy is stupid, and is using the 1999 schema; override it.
*SOAP::XMLSchema1999::Serializer::as_base64Binary = \&SOAP::XMLSchema2001::Serializer::as_base64Binary;
$soap-> handle;
--- /dev/null
+# -*- mode: cperl;-*-
+
+
+use Test::More tests => 4;
+
+use warnings;
+use strict;
+
+# Here, we're going to shoot messages through a set of things that can
+# happen.
+
+# First, we're going to send mesages to receive.
+# To do so, we'll first send a message to submit,
+# then send messages to the newly created bugnumber.
+
+use IO::File;
+use File::Temp qw(tempdir);
+use Cwd qw(getcwd);
+use Debbugs::MIME qw(create_mime_message);
+use File::Basename qw(dirname basename);
+use Test::WWW::Mechanize;
+# The test functions are placed here to make things easier
+use lib qw(t/lib);
+use DebbugsTest qw(:configuration);
+use Cwd;
+
+my %config;
+eval {
+ %config = create_debbugs_configuration(debug => exists $ENV{DEBUG}?$ENV{DEBUG}:0);
+};
+if ($@) {
+ BAIL_OUT($@);
+}
+
+# Output some debugging information if there's an error
+END{
+ if ($ENV{DEBUG}) {
+ foreach my $key (keys %config) {
+ diag("$key: $config{$key}\n");
+ }
+ }
+}
+
+# create a bug
+send_message(to=>'submit@bugs.something',
+ headers => [To => 'submit@bugs.something',
+ From => 'foo@bugs.something',
+ Subject => 'Submitting a bug',
+ ],
+ body => <<EOF) or fail('Unable to send message');
+Package: foo
+Severity: normal
+
+This is a silly bug
+EOF
+
+
+# test bugreport.cgi
+
+my $port = 11342;
+
+# We'd like to use soap.cgi here instead of testing the module
+# directly, but I can't quite get it to work with
+# HTTP::Server::Simple.
+use_ok('Debbugs::SOAP');
+use_ok('Debbugs::SOAP::Server');
+
+our $child_pid = undef;
+
+END{
+ if (defined $child_pid) {
+ kill(15,$child_pid);
+ waitpid(-1,0);
+ }
+}
+
+my $pid = fork;
+die "Unable to fork child" if not defined $pid;
+if ($pid) {
+ $child_pid = $pid;
+ # Wait for a second to let the child start
+ sleep 1;
+}
+else {
+ # UGH.
+ eval q(
+ use Debbugs::SOAP::Server;
+ @Debbugs::SOAP::Server::ISA = qw(SOAP::Transport::HTTP::Daemon);
+ Debbugs::SOAP::Server
+ ->new(LocalAddr => 'localhost', LocalPort => $port)
+ ->dispatch_to('/','Debbugs::SOAP')
+ ->handle;
+ );
+}
+
+use SOAP::Lite;
+my $soap = SOAP::Lite->uri('Debbugs/SOAP')->proxy('http://localhost:'.$port.'/');
+#ok($soap->get_soap_version->result == 1,'Version set and got correctly');
+my $bugs = $soap->get_bugs(package => 'foo')->result;
+use Data::Dumper;
+ok(@{$bugs} == 1 && $bugs->[0] == 1, 'get_bugs returns bug number 1') or fail(Dumper($bugs));
+my $status = $soap->get_status(1)->result;
+ok($status->{1}{package} eq 'foo','get_status thinks that bug 1 belongs in foo') or fail(Dumper($status));
+
+# Test the usertags at some point
projects / debbugs.git / commitdiff