aboutsummaryrefslogtreecommitdiffstatshomepage
path: root/share/perl/lib/XML/RPC.pm
diff options
context:
space:
mode:
Diffstat (limited to 'share/perl/lib/XML/RPC.pm')
-rw-r--r--share/perl/lib/XML/RPC.pm217
1 files changed, 0 insertions, 217 deletions
diff --git a/share/perl/lib/XML/RPC.pm b/share/perl/lib/XML/RPC.pm
deleted file mode 100644
index 2e08867..0000000
--- a/share/perl/lib/XML/RPC.pm
+++ /dev/null
@@ -1,217 +0,0 @@
1package XML::RPC;
2
3use strict;
4use XML::TreePP;
5use Data::Dumper;
6use vars qw($VERSION $faultCode);
7no strict 'refs';
8
9$VERSION = 0.5;
10
11sub new {
12 my $package = shift;
13 my $self = { };
14 bless $self, $package;
15 $self->{url} = shift;
16 $self->{tpp} = XML::TreePP->new(@_);
17 return $self;
18}
19
20sub call {
21 my $self = shift;
22 my ( $methodname, @params ) = @_;
23
24 die 'no url' if ( !$self->{url} );
25
26 $faultCode = 0;
27 my $xml = $self->create_call_xml( $methodname, @params );
28#print STDERR $xml;
29 my $result = $self->{tpp}->parsehttp(
30 POST => $self->{url},
31 $xml,
32 {
33 'Content-Type' => 'text/xml',
34 'User-Agent' => 'XML-RPC/' . $VERSION,
35 'Content-Length' => length($xml)
36 }
37 );
38
39 my @data = $self->unparse_response($result);
40 return @data == 1 ? $data[0] : @data;
41}
42
43sub receive {
44 my $self = shift;
45 my $result = eval {
46 my $xml = shift || die 'no xml';
47 my $handler = shift || die 'no handler';
48 my $hash = $self->{tpp}->parse($xml);
49 my ( $methodname, @params ) = $self->unparse_call($hash);
50 $self->create_response_xml( $handler->( $methodname, @params ) );
51 };
52 return $self->create_fault_xml($@) if ($@);
53 return $result;
54
55}
56
57sub create_fault_xml {
58 my $self = shift;
59 my $error = shift;
60 chomp($error);
61 return $self->{tpp}
62 ->write( { methodResponse => { fault => $self->parse( { faultString => $error, faultCode => $faultCode } ) } } );
63}
64
65sub create_call_xml {
66 my $self = shift;
67 my ( $methodname, @params ) = @_;
68
69 return $self->{tpp}->write(
70 {
71 methodCall => {
72 methodName => $methodname,
73 params => { param => [ map { $self->parse($_) } @params ] }
74 }
75 }
76 );
77}
78
79sub create_response_xml {
80 my $self = shift;
81 my @params = @_;
82
83 return $self->{tpp}->write( { methodResponse => { params => { param => [ map { $self->parse($_) } @params ] } } } );
84}
85
86sub parse {
87 my $self = shift;
88 my $p = shift;
89 my $result;
90
91 if ( ref($p) eq 'HASH' ) {
92 $result = $self->parse_struct($p);
93 }
94 elsif ( ref($p) eq 'ARRAY' ) {
95 $result = $self->parse_array($p);
96 }
97 else {
98 $result = $self->parse_scalar($p);
99 }
100
101 return { value => $result };
102}
103
104sub parse_scalar {
105 my $self = shift;
106 my $scalar = shift;
107 local $^W = undef;
108
109 if ( ( $scalar =~ m/^[\-+]?\d+$/ )
110 && ( abs($scalar) <= ( 0xffffffff >> 1 ) ) )
111 {
112 return { i4 => $scalar };
113 }
114 elsif ( $scalar =~ m/^[\-+]?\d+\.\d+$/ ) {
115 return { double => $scalar };
116 }
117 else {
118 return { string => \$scalar };
119 }
120}
121
122sub parse_struct {
123 my $self = shift;
124 my $hash = shift;
125 my @members;
126 while ( my ( $k, $v ) = each(%$hash) ) {
127 push @members, { name => $k, %{ $self->parse($v) } };
128 }
129 return { struct => { member => \@members } };
130}
131
132sub parse_array {
133 my $self = shift;
134 my $array = shift;
135
136 return { array => { data => { value => [ map { $self->parse($_)->{value} } $self->list($array) ] } } };
137}
138
139sub unparse_response {
140 my $self = shift;
141 my $hash = shift;
142
143 my $response = $hash->{methodResponse} || die 'no data';
144
145 if ( $response->{fault} ) {
146 return $self->unparse_value( $response->{fault}->{value} );
147 }
148 else {
149 return map { $self->unparse_value( $_->{value} ) } $self->list( $response->{params}->{param} );
150 }
151}
152
153sub unparse_call {
154 my $self = shift;
155 my $hash = shift;
156
157 my $response = $hash->{methodCall} || die 'no data';
158
159 my $methodname = $response->{methodName};
160 my @args =
161 map { $self->unparse_value( $_->{value} ) } $self->list( $response->{params}->{param} );
162 return ( $methodname, @args );
163}
164
165sub unparse_value {
166 my $self = shift;
167 my $value = shift;
168 my $result;
169
170 return $value if ( ref($value) ne 'HASH' ); # for unspecified params
171 if ( $value->{struct} ) {
172 $result = $self->unparse_struct( $value->{struct} );
173 return !%$result
174 ? undef
175 : $result; # fix for empty hashrefs from XML::TreePP
176 }
177 elsif ( $value->{array} ) {
178 return $self->unparse_array( $value->{array} );
179 }
180 else {
181 return $self->unparse_scalar($value);
182 }
183}
184
185sub unparse_scalar {
186 my $self = shift;
187 my $scalar = shift;
188 my ($result) = values(%$scalar);
189 return ( ref($result) eq 'HASH' && !%$result )
190 ? undef
191 : $result; # fix for empty hashrefs from XML::TreePP
192}
193
194sub unparse_struct {
195 my $self = shift;
196 my $struct = shift;
197
198 return { map { $_->{name} => $self->unparse_value( $_->{value} ) } $self->list( $struct->{member} ) };
199}
200
201sub unparse_array {
202 my $self = shift;
203 my $array = shift;
204 my $data = $array->{data};
205
206 return [ map { $self->unparse_value($_) } $self->list( $data->{value} ) ];
207}
208
209sub list {
210 my $self = shift;
211 my $param = shift;
212 return () if ( !$param );
213 return @$param if ( ref($param) eq 'ARRAY' );
214 return ($param);
215}
216
2171;