diff options
Diffstat (limited to 'share/perl/lib/XML/RPC.pm')
-rw-r--r-- | share/perl/lib/XML/RPC.pm | 217 |
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 @@ | |||
1 | package XML::RPC; | ||
2 | |||
3 | use strict; | ||
4 | use XML::TreePP; | ||
5 | use Data::Dumper; | ||
6 | use vars qw($VERSION $faultCode); | ||
7 | no strict 'refs'; | ||
8 | |||
9 | $VERSION = 0.5; | ||
10 | |||
11 | sub 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 | |||
20 | sub 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 | |||
43 | sub 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 | |||
57 | sub 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 | |||
65 | sub 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 | |||
79 | sub 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 | |||
86 | sub 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 | |||
104 | sub 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 | |||
122 | sub 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 | |||
132 | sub 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 | |||
139 | sub 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 | |||
153 | sub 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 | |||
165 | sub 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 | |||
185 | sub 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 | |||
194 | sub 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 | |||
201 | sub 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 | |||
209 | sub 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 | |||
217 | 1; | ||