line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# ====================================================================== |
2
|
|
|
|
|
|
|
# |
3
|
|
|
|
|
|
|
# Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com) |
4
|
|
|
|
|
|
|
# SOAP::Lite is free software; you can redistribute it |
5
|
|
|
|
|
|
|
# and/or modify it under the same terms as Perl itself. |
6
|
|
|
|
|
|
|
# |
7
|
|
|
|
|
|
|
# $Id$ |
8
|
|
|
|
|
|
|
# |
9
|
|
|
|
|
|
|
# ====================================================================== |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
package XMLRPC::Test; |
12
|
|
|
|
|
|
|
|
13
|
1
|
|
|
1
|
|
7953
|
use 5.004; |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
52
|
|
14
|
1
|
|
|
1
|
|
7
|
use vars qw($VERSION $TIMEOUT); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
315
|
|
15
|
|
|
|
|
|
|
our $VERSION = 0.717; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
$TIMEOUT = 5; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# ====================================================================== |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
package My::PingPong; # we'll use this package in our tests |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub new { |
24
|
0
|
|
|
0
|
|
|
my $self = shift; |
25
|
0
|
|
0
|
|
|
|
my $class = ref($self) || $self; |
26
|
0
|
|
|
|
|
|
bless {_num=>shift} => $class; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub next { |
30
|
0
|
|
|
0
|
|
|
my $self = shift; |
31
|
0
|
|
|
|
|
|
$self->{_num}++; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
sub value { |
35
|
0
|
|
|
0
|
|
|
my $self = shift; |
36
|
0
|
|
|
|
|
|
$self->{_num}; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# ====================================================================== |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
package XMLRPC::Test::Server; |
42
|
|
|
|
|
|
|
|
43
|
1
|
|
|
1
|
|
6
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
44
|
|
44
|
1
|
|
|
1
|
|
1201
|
use Test; |
|
1
|
|
|
|
|
5828
|
|
|
1
|
|
|
|
|
152
|
|
45
|
1
|
|
|
1
|
|
731
|
use XMLRPC::Lite; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
sub run_for { |
48
|
|
|
|
|
|
|
my $proxy = shift or die "Proxy/endpoint is not specified"; |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
# ------------------------------------------------------ |
51
|
|
|
|
|
|
|
my $s = XMLRPC::Lite->proxy($proxy)->on_fault(sub{}); |
52
|
|
|
|
|
|
|
eval { $s->transport->timeout($XMLRPC::Test::TIMEOUT) }; |
53
|
|
|
|
|
|
|
my $r = $s->test_connection; |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
unless (defined $r && defined $r->envelope) { |
56
|
|
|
|
|
|
|
print "1..0 # Skip: ", $s->transport->status, "\n"; |
57
|
|
|
|
|
|
|
exit; |
58
|
|
|
|
|
|
|
} |
59
|
|
|
|
|
|
|
# ------------------------------------------------------ |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
plan tests => 17; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
eval q!use XMLRPC::Lite on_fault => sub{ref $_[1] ? $_[1] : new XMLRPC::SOM}; 1! or die; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
print "Perl XMLRPC server test(s)...\n"; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
$s = XMLRPC::Lite |
68
|
|
|
|
|
|
|
-> proxy($proxy) |
69
|
|
|
|
|
|
|
; |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
ok($s->call('My.Examples.getStateName', 1)->result eq 'Alabama'); |
72
|
|
|
|
|
|
|
ok($s->call('My.Examples.getStateNames', 1,4,6,13)->result =~ /^Alabama\s+Arkansas\s+Colorado\s+Illinois\s*$/); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
$r = $s->call('My.Examples.getStateList', [1,2,3,4])->result; |
75
|
|
|
|
|
|
|
ok(ref $r && $r->[0] eq 'Alabama'); |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
$r = $s->call('My.Examples.getStateStruct', {item1 => 1, item2 => 4})->result; |
78
|
|
|
|
|
|
|
ok(ref $r && $r->{item2} eq 'Arkansas'); |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
print "dispatch_from test(s)...\n"; |
81
|
|
|
|
|
|
|
eval "use XMLRPC::Lite |
82
|
|
|
|
|
|
|
dispatch_from => ['A', 'B'], |
83
|
|
|
|
|
|
|
proxy => '$proxy', |
84
|
|
|
|
|
|
|
; 1" or die; |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
eval { C->c }; |
87
|
|
|
|
|
|
|
ok($@ =~ /Can't locate object method "c"/); |
88
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
print "Object autobinding and XMLRPC:: prefix test(s)...\n"; |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
eval "use XMLRPC::Lite +autodispatch => |
92
|
|
|
|
|
|
|
proxy => '$proxy'; 1" or die; |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
ok(XMLRPC::Lite->autodispatched); |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# forget everything |
97
|
|
|
|
|
|
|
XMLRPC::Lite->self(undef); |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
{ |
100
|
|
|
|
|
|
|
my $on_fault_was_called = 0; |
101
|
|
|
|
|
|
|
print "Die in server method test(s)...\n"; |
102
|
|
|
|
|
|
|
my $s = XMLRPC::Lite |
103
|
|
|
|
|
|
|
-> proxy($proxy) |
104
|
|
|
|
|
|
|
-> on_fault(sub{$on_fault_was_called++;return}) |
105
|
|
|
|
|
|
|
; |
106
|
|
|
|
|
|
|
ok($s->call('My.Parameters.die_simply')->faultstring =~ /Something bad/); |
107
|
|
|
|
|
|
|
ok($on_fault_was_called > 0); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# get Fault as hash of subelements |
110
|
|
|
|
|
|
|
my $fault = $s->call('My.Parameters.die_with_fault'); |
111
|
|
|
|
|
|
|
ok($fault->faultcode =~ 'Server\.Custom'); |
112
|
|
|
|
|
|
|
ok($fault->faultstring eq 'Died in server method'); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
print "Number of parameters test(s)...\n"; |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
$s = XMLRPC::Lite |
118
|
|
|
|
|
|
|
-> proxy($proxy) |
119
|
|
|
|
|
|
|
; |
120
|
|
|
|
|
|
|
{ my @all = $s->call('My.Parameters.echo')->paramsall; ok(@all == 0) } |
121
|
|
|
|
|
|
|
{ my @all = $s->call('My.Parameters.echo', 1)->paramsall; ok(@all == 1) } |
122
|
|
|
|
|
|
|
{ my @all = $s->call('My.Parameters.echo', (1) x 10)->paramsall; ok(@all == 10) } |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
print "Memory refresh test(s)...\n"; |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
# Funny test. |
127
|
|
|
|
|
|
|
# Let's forget about ALL settings we did before with 'use XMLRPC::Lite...' |
128
|
|
|
|
|
|
|
XMLRPC::Lite->self(undef); |
129
|
|
|
|
|
|
|
ok(!defined XMLRPC::Lite->self); |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
eval "use XMLRPC::Lite |
132
|
|
|
|
|
|
|
proxy => '$proxy'; 1" or die; |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
print "Global settings test(s)...\n"; |
135
|
|
|
|
|
|
|
$s = new XMLRPC::Lite; |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
ok($s->call('My.Examples.getStateName', 1)->result eq 'Alabama'); |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
SOAP::Trace->import(transport => |
140
|
|
|
|
|
|
|
sub {$_[0]->content_type('something/wrong') if UNIVERSAL::isa($_[0] => 'HTTP::Request')} |
141
|
|
|
|
|
|
|
); |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
if ($proxy =~ /^tcp:/) { |
144
|
|
|
|
|
|
|
skip('No Content-Type checks for tcp: protocol on server side' => undef); |
145
|
|
|
|
|
|
|
} else { |
146
|
|
|
|
|
|
|
ok($s->call('My.Examples.getStateName', 1)->faultstring =~ /Content-Type must be/); |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
# check status for fault messages |
150
|
|
|
|
|
|
|
if ($proxy =~ /^http/) { |
151
|
|
|
|
|
|
|
ok($s->transport->status =~ /^200/); |
152
|
|
|
|
|
|
|
} else { |
153
|
|
|
|
|
|
|
skip('No Status checks for non http protocols on server side' => undef); |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# ====================================================================== |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
1; |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
__END__ |