1 |
############################################################################### |
2 |
# |
3 |
# This file copyright (c) 2001 by Randy J. Ray <rjray@blackperl.com>, |
4 |
# all rights reserved |
5 |
# |
6 |
# Copying and distribution are permitted under the terms of the Artistic |
7 |
# License as distributed with Perl versions 5.002 and later. See |
8 |
# http://language.perl.com/misc/Artistic.html |
9 |
# |
10 |
############################################################################### |
11 |
# |
12 |
# $Id: Server.pm,v 1.26 2002/05/04 07:41:04 rjray Exp $ |
13 |
# |
14 |
# Description: This class implements an RPC::XML server, using the core |
15 |
# XML::RPC transaction code. The server may be created with |
16 |
# or without an HTTP::Daemon object instance to answer the |
17 |
# requests. |
18 |
# |
19 |
# Functions: new |
20 |
# version |
21 |
# url |
22 |
# product_tokens |
23 |
# started |
24 |
# path |
25 |
# host |
26 |
# port |
27 |
# requests |
28 |
# response |
29 |
# xpl_path |
30 |
# add_method |
31 |
# method_from_file |
32 |
# get_method |
33 |
# server_loop |
34 |
# post_configure_hook |
35 |
# pre_loop_hook |
36 |
# process_request |
37 |
# dispatch |
38 |
# call |
39 |
# add_default_methods |
40 |
# add_methods_in_dir |
41 |
# delete_method |
42 |
# list_methods |
43 |
# share_methods |
44 |
# copy_methods |
45 |
# timeout |
46 |
# |
47 |
# Libraries: AutoLoader |
48 |
# HTTP::Daemon |
49 |
# HTTP::Status |
50 |
# RPC::XML |
51 |
# RPC::XML::Parser |
52 |
# RPC::XML::Method |
53 |
# RPC::XML::Procedure |
54 |
# |
55 |
# Global Consts: $VERSION |
56 |
# $INSTALL_DIR |
57 |
# |
58 |
############################################################################### |
59 |
|
60 |
package RPC::XML::Server; |
61 |
|
62 |
use 5.005; |
63 |
use strict; |
64 |
use vars qw($VERSION @ISA $INSTANCE $INSTALL_DIR @XPL_PATH); |
65 |
|
66 |
use Carp 'carp'; |
67 |
use AutoLoader 'AUTOLOAD'; |
68 |
use File::Spec; |
69 |
|
70 |
BEGIN { |
71 |
$INSTALL_DIR = (File::Spec->splitpath(__FILE__))[1]; |
72 |
@XPL_PATH = ($INSTALL_DIR, File::Spec->curdir); |
73 |
} |
74 |
|
75 |
require HTTP::Daemon; |
76 |
require HTTP::Response; |
77 |
require HTTP::Status; |
78 |
require URI; |
79 |
|
80 |
require RPC::XML; |
81 |
require RPC::XML::Parser; |
82 |
require RPC::XML::Procedure; |
83 |
|
84 |
$VERSION = do { my @r=(q$Revision: 1.26 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r }; |
85 |
|
86 |
1; |
87 |
|
88 |
############################################################################### |
89 |
# |
90 |
# Sub Name: new |
91 |
# |
92 |
# Description: Create a new RPC::XML::Server object. This entails getting |
93 |
# a HTTP::Daemon object, saving several internal values, and |
94 |
# other operations. |
95 |
# |
96 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
97 |
# $class in scalar Ref or string for the class |
98 |
# %args in hash Additional arguments |
99 |
# |
100 |
# Returns: Success: object reference |
101 |
# Failure: error string |
102 |
# |
103 |
############################################################################### |
104 |
sub new |
105 |
{ |
106 |
my $class = shift; |
107 |
my %args = @_; |
108 |
|
109 |
my ($self, $http, $resp, $host, $port, $queue, $path, $URI, $srv_name, |
110 |
$srv_version, $timeout); |
111 |
|
112 |
$class = ref($class) || $class; |
113 |
$self = bless {}, $class; |
114 |
|
115 |
$srv_version = $args{server_version} || $self->version; |
116 |
$srv_name = $args{server_name} || $class; |
117 |
$self->{__version} = "$srv_name/$srv_version"; |
118 |
|
119 |
if ($args{no_http}) |
120 |
{ |
121 |
$self->{__host} = $args{host} || ''; |
122 |
$self->{__port} = $args{port} || ''; |
123 |
delete @args{qw(host port)}; |
124 |
} |
125 |
else |
126 |
{ |
127 |
$host = $args{host} || ''; |
128 |
$port = $args{port} || ''; |
129 |
$queue = $args{queue} || 5; |
130 |
$http = HTTP::Daemon->new(Reuse => 1, |
131 |
($host ? (LocalHost => $host) : ()), |
132 |
($port ? (LocalPort => $port) : ()), |
133 |
($queue ? (Listen => $queue) : ())); |
134 |
return "${class}::new: Unable to create HTTP::Daemon object" |
135 |
unless $http; |
136 |
$URI = URI->new($http->url); |
137 |
$self->{__host} = $URI->host; |
138 |
$self->{__port} = $URI->port; |
139 |
$self->{__daemon} = $http; |
140 |
|
141 |
# Remove those we've processed |
142 |
delete @args{qw(host port queue)}; |
143 |
} |
144 |
$resp = HTTP::Response->new(); |
145 |
return "${class}::new: Unable to create HTTP::Response object" |
146 |
unless $resp; |
147 |
$resp->header(# This is essentially the same string returned by the |
148 |
# default "identity" method that may be loaded from a |
149 |
# XPL file. But it hasn't been loaded yet, and may not |
150 |
# be, hence we set it here (possibly from option values) |
151 |
RPC_Server => $self->{__version}, |
152 |
RPC_Encoding => 'XML-RPC'); |
153 |
$resp->code(&HTTP::Status::RC_OK); |
154 |
$resp->message('OK'); |
155 |
$self->{__response} = $resp; |
156 |
|
157 |
$self->{__path} = $args{path} || ''; |
158 |
$self->{__started} = 0; |
159 |
$self->{__method_table} = {}; |
160 |
$self->{__requests} = 0; |
161 |
$self->{__auto_methods} = $args{auto_methods} || 0; |
162 |
$self->{__auto_updates} = $args{auto_updates} || 0; |
163 |
$self->{__debug} = $args{debug} || 0; |
164 |
$self->{__parser} = RPC::XML::Parser->new(); |
165 |
$self->{__xpl_path} = $args{xpl_path} || []; |
166 |
$self->{__timeout} = $args{timeout} || 10; |
167 |
|
168 |
$self->add_default_methods unless ($args{no_default}); |
169 |
|
170 |
# Remove the args we've already dealt with directly |
171 |
delete @args{qw(no_default no_http debug path server_name server_version)}; |
172 |
# Copy the rest over untouched |
173 |
$self->{$_} = $args{$_} for (keys %args); |
174 |
|
175 |
$self; |
176 |
} |
177 |
|
178 |
# Most of these tiny subs are accessors to the internal hash keys. They not |
179 |
# only control access to the internals, they ease sub-classing. |
180 |
|
181 |
sub version { $RPC::XML::Server::VERSION } |
182 |
|
183 |
sub INSTALL_DIR { $INSTALL_DIR } |
184 |
|
185 |
sub url |
186 |
{ |
187 |
my $self = shift; |
188 |
|
189 |
return $self->{__daemon}->url if $self->{__daemon}; |
190 |
return undef unless ($self->{__host}); |
191 |
|
192 |
if ($self->{__port} == 443) |
193 |
{ |
194 |
return "https://$self->{__host}$self->{__path}"; |
195 |
} |
196 |
elsif ($self->{__port} == 80) |
197 |
{ |
198 |
return "http://$self->{__host}$self->{__path}"; |
199 |
} |
200 |
else |
201 |
{ |
202 |
return "http://$self->{__host}:$self->{__port}$self->{__path}"; |
203 |
} |
204 |
} |
205 |
|
206 |
sub product_tokens |
207 |
{ |
208 |
sprintf "%s/%s", (ref $_[0] || $_[0]), $_[0]->version; |
209 |
} |
210 |
|
211 |
# This fetches/sets the internal "started" timestamp |
212 |
sub started |
213 |
{ |
214 |
my $self = shift; |
215 |
my $set = shift || 0; |
216 |
|
217 |
my $old = $self->{__started} || 0; |
218 |
$self->{__started} = time if $set; |
219 |
|
220 |
$old; |
221 |
} |
222 |
|
223 |
sub path { shift->{__path} } |
224 |
sub host { shift->{__host} } |
225 |
sub port { shift->{__port} } |
226 |
sub requests { shift->{__requests} } |
227 |
sub response { shift->{__response} } |
228 |
|
229 |
# Get/set the search path for XPL files |
230 |
sub xpl_path |
231 |
{ |
232 |
my $self = shift; |
233 |
my $ret = $self->{__xpl_path}; |
234 |
|
235 |
$self->{__xpl_path} = $_[0] if ($_[0] and ref($_[0]) eq 'ARRAY'); |
236 |
$ret; |
237 |
} |
238 |
|
239 |
############################################################################### |
240 |
# |
241 |
# Sub Name: add_method |
242 |
# |
243 |
# Description: Add a funtion-to-method mapping to the server object. |
244 |
# |
245 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
246 |
# $self in ref Object to add to |
247 |
# $meth in scalar Hash ref of data or file name |
248 |
# |
249 |
# Returns: Success: $self |
250 |
# Failure: error string |
251 |
# |
252 |
############################################################################### |
253 |
sub add_method |
254 |
{ |
255 |
my $self = shift; |
256 |
my $meth = shift; |
257 |
|
258 |
my ($name, $val); |
259 |
|
260 |
my $me = ref($self) . '::add_method'; |
261 |
|
262 |
if (! ref($meth)) |
263 |
{ |
264 |
$val = $self->method_from_file($meth); |
265 |
if (! ref($val)) |
266 |
{ |
267 |
return "$me: Error loading from file $meth: $val"; |
268 |
} |
269 |
else |
270 |
{ |
271 |
$meth = $val; |
272 |
} |
273 |
} |
274 |
elsif (ref($meth) eq 'HASH') |
275 |
{ |
276 |
my $class = 'RPC::XML::' . ucfirst ($meth->{type} || 'method'); |
277 |
$meth = $class->new($meth); |
278 |
} |
279 |
elsif (! UNIVERSAL::isa($meth, 'RPC::XML::Procedure')) |
280 |
{ |
281 |
return "$me: Method argument must be a file name, a hash " . |
282 |
'reference or an object derived from RPC::XML::Procedure'; |
283 |
} |
284 |
|
285 |
# Do some sanity-checks |
286 |
return "$me: Method missing required data; check name, code and/or " . |
287 |
'signature' unless $meth->is_valid; |
288 |
|
289 |
$name = $meth->name; |
290 |
$self->{__method_table}->{$name} = $meth; |
291 |
|
292 |
$self; |
293 |
} |
294 |
|
295 |
=pod |
296 |
|
297 |
=head1 NAME |
298 |
|
299 |
RPC::XML::Server - A sample server implementation based on RPC::XML |
300 |
|
301 |
=head1 SYNOPSIS |
302 |
|
303 |
use RPC::XML::Server; |
304 |
|
305 |
... |
306 |
$srv = RPC::XML::Server->new(port => 9000); |
307 |
# Several of these, most likely: |
308 |
$srv->add_method(...); |
309 |
... |
310 |
$srv->server_loop; # Never returns |
311 |
|
312 |
=head1 DESCRIPTION |
313 |
|
314 |
This is a sample XML-RPC server built upon the B<RPC::XML> data classes, and |
315 |
using B<HTTP::Daemon> and B<HTTP::Response> for the communication layer. |
316 |
|
317 |
=head1 USAGE |
318 |
|
319 |
Use of the B<RPC::XML::Server> is based on an object model. A server is |
320 |
instantiated from the class, methods (subroutines) are made public by adding |
321 |
them through the object interface, and then the server object is responsible |
322 |
for dispatching requests (and possibly for the HTTP listening, as well). |
323 |
|
324 |
=head2 Methods |
325 |
|
326 |
The following methods are provided by the B<RPC::XML::Server> class. Unless |
327 |
otherwise explicitly noted, all methods return the invoking object reference |
328 |
upon success, and a non-reference error string upon failure. |
329 |
|
330 |
=over 4 |
331 |
|
332 |
=item new(OPTIONS) |
333 |
|
334 |
Creates a new object of the class and returns the blessed reference. Depending |
335 |
on the options, the object will contain some combination of an HTTP listener, |
336 |
a pre-populated B<HTTP::Response> object, a B<RPC::XML::Parser> object, and |
337 |
a dispatch table with the set of default methods pre-loaded. The options that |
338 |
B<new> accepts are passed as a hash of key/value pairs (not a hash reference). |
339 |
The accepted options are: |
340 |
|
341 |
=over 4 |
342 |
|
343 |
=item B<no_http> |
344 |
|
345 |
If passed with a C<true> value, prevents the creation and storage of the |
346 |
B<HTTP::Daemon> and the pre-configured B<HTTP::Response> objects. This allows |
347 |
for deployment of a server object in other environments. Note that if this is |
348 |
set, the B<accept_loop> method described below will silently return |
349 |
immediately. |
350 |
|
351 |
=item B<no_default> |
352 |
|
353 |
If passed with a C<true> value, prevents the loading of the default methods |
354 |
provided with the B<RPC::XML> distribution. These may be later loaded using |
355 |
the B<add_default_methods> interface described later. The methods themselves |
356 |
are described below (see L<"The Default Methods Provided">). |
357 |
|
358 |
=item B<path> |
359 |
|
360 |
=item B<host> |
361 |
|
362 |
=item B<port> |
363 |
|
364 |
=item B<queue> |
365 |
|
366 |
These four are specific to the HTTP-based nature of the server. The last |
367 |
three are not used at all if C<no_http> is set. The B<path> argument sets the |
368 |
additional URI path information that clients would use to contact the server. |
369 |
Internally, it is not used except in outgoing status and introspection |
370 |
reports. The B<host>, B<port> and B<queue> arguments are passed to the |
371 |
B<HTTP::Daemon> constructor if they are passed. They set the hostname, TCP/IP |
372 |
port, and socket listening queue, respectively. Again, they are not used if |
373 |
the C<no_http> argument was set. |
374 |
|
375 |
=item B<xpl_path> |
376 |
|
377 |
If you plan to add methods to the server object by passing filenames to the |
378 |
C<add_method> call, this argument may be used to specify one or more |
379 |
additional directories to be searched when the passed-in filename is a |
380 |
relative path. The value for this must be an array reference. See also |
381 |
B<add_method> and B<xpl_path>, below. |
382 |
|
383 |
=item B<timeout> |
384 |
|
385 |
You can call this method to set the timeout of new connections after |
386 |
they are received. This function returns the old timeout value. If |
387 |
you pass in no value then it will return the old value without |
388 |
modifying the current value. The default value is 10 seconds. |
389 |
|
390 |
=item B<auto_methods> |
391 |
|
392 |
If specified and set to a true value, enables the automatic searching for a |
393 |
requested remote method that is unknown to the server object handling the |
394 |
request. If set to "no" (or not set at all), then a request for an unknown |
395 |
function causes the object instance to report an error. If the routine is |
396 |
still not found, the error is reported. Enabling this is a security risk, and |
397 |
should only be permitted by a server administrator with fully informed |
398 |
acknowledgement and consent. |
399 |
|
400 |
=item B<auto_updates> |
401 |
|
402 |
If specified and set to a "true" value, enables the checking of the |
403 |
modification time of the file from which a method was originally loaded. If |
404 |
the file has changed, the method is re-loaded before execution is handed |
405 |
off. As with the auto-loading of methods, this represents a security risk, and |
406 |
should only be permitted by a server administrator with fully informed |
407 |
acknowledgement and consent. |
408 |
|
409 |
=back |
410 |
|
411 |
Any other keys in the options hash not explicitly used by the constructor are |
412 |
copied over verbatim onto the object, for the benefit of sub-classing this |
413 |
class. All internal keys are prefixed with C<__> to avoid confusion. Feel |
414 |
free to use this prefix only if you wish to re-introduce confusion. |
415 |
|
416 |
=item version |
417 |
|
418 |
Returns the version string associated with this package. |
419 |
|
420 |
=item product_tokens |
421 |
|
422 |
This returns the identifying string for the server, in the format |
423 |
C<NAME/VERSION> consistent with other applications such as Apache and |
424 |
B<LWP>. It is provided here as part of the compatibility with B<HTTP::Daemon> |
425 |
that is required for effective integration with B<Net::Server>. |
426 |
|
427 |
=item url |
428 |
|
429 |
This returns the HTTP URL that the server will be responding to, when it is in |
430 |
the connection-accept loop. If the server object was created without a |
431 |
built-in HTTP listener, then this method returns C<undef>. |
432 |
|
433 |
=item requests |
434 |
|
435 |
Returns the number of requests this server object has marshalled. Note that in |
436 |
multi-process environments (such as Apache or Net::Server::PreFork) the value |
437 |
returned will only reflect the messages dispatched by the specific process |
438 |
itself. |
439 |
|
440 |
=item response |
441 |
|
442 |
Each instance of this class (and any subclasses that do not completely |
443 |
override the C<new> method) creates and stores an instance of |
444 |
B<HTTP::Response>, which is then used by the B<HTTP::Daemon> or B<Net::Server> |
445 |
processing loops in constructing the response to clients. The response object |
446 |
has all common headers pre-set for efficiency. This method returns a reference |
447 |
to that object. |
448 |
|
449 |
=item started([BOOL]) |
450 |
|
451 |
Gets and possibly sets the clock-time when the server starts accepting |
452 |
connections. If a value is passed that evaluates to true, then the current |
453 |
clock time is marked as the starting time. In either case, the current value |
454 |
is returned. The clock-time is based on the internal B<time> command of Perl, |
455 |
and thus is represented as an integer number of seconds since the system |
456 |
epoch. Generally, it is suitable for passing to either B<localtime> or to the |
457 |
C<time2iso8601> routine exported by the B<RPC::XML> package. |
458 |
|
459 |
=item add_method(FILE | HASHREF | OBJECT) |
460 |
|
461 |
=item add_proc(FILE | HASHREF | OBJECT) |
462 |
|
463 |
This adds a new published method or procedure to the server object that |
464 |
invokes it. The new method may be specified in one of three ways: as a |
465 |
filename, a hash reference or an existing object (generally of either |
466 |
B<RPC::XML::Procedure> or B<RPC::XML::Method> classes). |
467 |
|
468 |
If passed as a hash reference, the following keys are expected: |
469 |
|
470 |
=over 4 |
471 |
|
472 |
=item B<name> |
473 |
|
474 |
The published (externally-visible) name for the method. |
475 |
|
476 |
=item B<version> |
477 |
|
478 |
An optional version stamp. Not used internally, kept mainly for informative |
479 |
purposes. |
480 |
|
481 |
=item B<hidden> |
482 |
|
483 |
If passed and evaluates to a C<true> value, then the method should be hidden |
484 |
from any introspection API implementations. This parameter is optional, the |
485 |
default behavior being to make the method publically-visible. |
486 |
|
487 |
=item B<code> |
488 |
|
489 |
A code reference to the actual Perl subroutine that handles this method. A |
490 |
symbolic reference is not accepted. The value can be passed either as a |
491 |
reference to an existing routine, or possibly as a closure. See |
492 |
L</"How Methods are Called"> for the semantics the referenced subroutine must |
493 |
follow. |
494 |
|
495 |
=item B<signature> |
496 |
|
497 |
A list reference of the signatures by which this routine may be invoked. Every |
498 |
method has at least one signature. Though less efficient for cases of exactly |
499 |
one signature, a list reference is always used for sake of consistency. |
500 |
|
501 |
=item B<help> |
502 |
|
503 |
Optional documentation text for the method. This is the text that would be |
504 |
returned, for example, by a B<system.methodHelp> call (providing the server |
505 |
has such an externally-visible method). |
506 |
|
507 |
=back |
508 |
|
509 |
If a file is passed, then it is expected to be in the XML-based format, |
510 |
described in the B<RPC::XML::Procedure> manual (see L<RPC::XML::Procedure>). |
511 |
If the name passed is not an absolute pathname, then the file will be searched |
512 |
for in any directories specified when the object was instantiated, then in the |
513 |
directory into which this module was installed, and finally in the current |
514 |
working directory. If the operation fails, the return value will be a |
515 |
non-reference, an error message. Otherwise, the return value is the object |
516 |
reference. |
517 |
|
518 |
The B<add_method> and B<add_proc> calls are essentialy identical unless called |
519 |
with hash references. Both files and objects contain the information that |
520 |
defines the type (method vs. procedure) of the funtionality to be added to the |
521 |
server. If B<add_method> is called with a file that describes a procedure, the |
522 |
resulting addition to the server object will be a B<RPC::XML::Procedure> |
523 |
object, not a method object. |
524 |
|
525 |
For more on the creation and manipulation of procedures and methods as |
526 |
objects, see L<RPC::XML::Procedure>. |
527 |
|
528 |
=item delete_method(NAME) |
529 |
|
530 |
=item delete_proc(NAME) |
531 |
|
532 |
Delete the named method or procedure from the calling object. Removes the |
533 |
entry from the internal table that the object maintains. If the method is |
534 |
shared across more than one server object (see L</share_methods>), then the |
535 |
underlying object for it will only be destroyed when the last server object |
536 |
releases it. On error (such as no method by that name known), an error string |
537 |
is returned. |
538 |
|
539 |
The B<delete_proc> call is identical, supplied for the sake of symmetry. Both |
540 |
calls return the matched object regardless of its underlying type. |
541 |
|
542 |
=item list_methods |
543 |
|
544 |
=item list_procs |
545 |
|
546 |
This returns a list of the names of methods and procedures the server current |
547 |
has published. Note that the returned values are not the method objects, but |
548 |
rather the names by which they are externally known. The "hidden" status of a |
549 |
method is not consulted when this list is created; all methods and procedures |
550 |
known are listed. The list is not sorted in any specific order. |
551 |
|
552 |
The <list_procs> call is provided for symmetry. Both calls list all published |
553 |
routines on the calling server object, regardless of underlying type. |
554 |
|
555 |
=item xpl_path([LISTREF]) |
556 |
|
557 |
Get and/or set the object-specific search path for C<*.xpl> files (files that |
558 |
specify methods) that are specified in calls to B<add_method>, above. If a |
559 |
list reference is passed, it is installed as the new path (each element of the |
560 |
list being one directory name to search). Regardless of argument, the current |
561 |
path is returned as a list reference. When a file is passed to B<add_method>, |
562 |
the elements of this path are searched first, in order, before the |
563 |
installation directory or the current working directory are searched. |
564 |
|
565 |
=item get_method(NAME) |
566 |
|
567 |
=item get_proc(NAME) |
568 |
|
569 |
Returns a reference to an object of the class B<RPC::XML::Method> or |
570 |
B<RPC::XML::Procedure>, which is the current binding for the published method |
571 |
NAME. If there is no such method known to the server, then C<undef> is |
572 |
returned. The object is implemented as a hash, and has the same key and value |
573 |
pairs as for C<add_method>, above. Thus, the reference returned is suitable |
574 |
for passing back to C<add_method>. This facilitates temporary changes in what |
575 |
a published name maps to. Note that this is a referent to the object as stored |
576 |
on the server object itself, and thus changes to it could affect the behavior |
577 |
of the server. |
578 |
|
579 |
The B<get_proc> interface is provided for symmetry. |
580 |
|
581 |
=item server_loop(HASH) |
582 |
|
583 |
Enters the connection-accept loop, which generally does not return. This is |
584 |
the C<accept()>-based loop of B<HTTP::Daemon> if the object was created with |
585 |
an instance of that class as a part. Otherwise, this enters the run-loop of |
586 |
the B<Net::Server> class. It listens for requests, and marshalls them out via |
587 |
the C<dispatch> method described below. It answers HTTP-HEAD requests |
588 |
immediately (without counting them on the server statistics) and efficiently |
589 |
by using a cached B<HTTP::Response> object. |
590 |
|
591 |
Because infinite loops requiring a C<HUP> or C<KILL> signal to terminate are |
592 |
generally in poor taste, the B<HTTP::Daemon> side of this sets up a localized |
593 |
signal handler which causes an exit when triggered. By default, this is |
594 |
attached to the C<INT> signal. If the B<Net::Server> module is being used |
595 |
instead, it provides its own signal management. |
596 |
|
597 |
The arguments, if passed, are interpreted as a hash of key/value options (not |
598 |
a hash reference, please note). For B<HTTP::Daemon>, only one is recognized: |
599 |
|
600 |
=over 4 |
601 |
|
602 |
=item B<signal> |
603 |
|
604 |
If passed, should be the traditional name for the signal that should be bound |
605 |
to the exit function. If desired, a reference to an array of signal names may |
606 |
be passed, in which case all signals will be given the same handler. The user |
607 |
is responsible for not passing the name of a non-existent signal, or one that |
608 |
cannot be caught. If the value of this argument is 0 (a C<false> value) or the |
609 |
string C<B<NONE>>, then the signal handler will I<not> be installed, and the |
610 |
loop may only be broken out of by killing the running process (unless other |
611 |
arrangements are made within the application). |
612 |
|
613 |
=back |
614 |
|
615 |
The options that B<Net::Server> responds to are detailed in the manual pages |
616 |
for that package. All options passed to C<server_loop> in this situation are |
617 |
passed unaltered to the C<run()> method in B<Net::Server>. |
618 |
|
619 |
=item dispatch(REQUEST) |
620 |
|
621 |
This is the server method that actually manages the marshalling of an incoming |
622 |
request into an invocation of a Perl subroutine. The parameter passed in may |
623 |
be one of: a scalar containing the full XML text of the request, a scalar |
624 |
reference to such a string, or a pre-constructed B<RPC::XML::request> object. |
625 |
Unless an object is passed, the text is parsed with any errors triggering an |
626 |
early exit. Once the object representation of the request is on hand, the |
627 |
parameter data is extracted, as is the method name itself. The call is sent |
628 |
along to the appropriate subroutine, and the results are collated into an |
629 |
object of the B<RPC::XML::response> class, which is returned. Any non-reference |
630 |
return value should be presumed to be an error string. If the dispatched |
631 |
method encountered some sort of error, it will not be propagated upward here, |
632 |
but rather encoded as an object of the B<RPC::XML::fault> class, and returned |
633 |
as the result of the dispatch. This distinguishes between server-centric |
634 |
errors, and general run-time errors. |
635 |
|
636 |
=item add_default_methods([DETAILS]) |
637 |
|
638 |
This method adds all the default methods (those that are shipped with this |
639 |
extension) to the calling server object. The files are denoted by their |
640 |
C<*.xpl> extension, and are installed into the same directory as this |
641 |
B<Server.pm> file. The set of default methods are described below (see |
642 |
L<"The Default Methods Provided">). |
643 |
|
644 |
If any names are passed as a list of arguments to this call, then only those |
645 |
methods specified are actually loaded. If the C<*.xpl> extension is absent on |
646 |
any of these names, then it is silently added for testing purposes. Note that |
647 |
the methods shipped with this package have file names without the leading |
648 |
C<status.> part of the method name. If the very first element of the list of |
649 |
arguments is C<except> (or C<-except>), then the rest of the list is |
650 |
treated as a set of names to I<not> load, while all others do get read. The |
651 |
B<Apache::RPC::Server> module uses this to prevent the loading of the default |
652 |
C<system.status> method while still loading all the rest of the defaults. (It |
653 |
then provides a more Apache-centric status method.) |
654 |
|
655 |
Note that there is no symmetric call in this case. The provided API is |
656 |
implemented as methods, and thus only this interface is provided. |
657 |
|
658 |
=item add_methods_in_dir(DIR [, DETAILS]) |
659 |
|
660 |
=item add_procs_in_dir(DIR [, DETAILS]) |
661 |
|
662 |
This is exactly like B<add_default_methods> above, save that the caller |
663 |
specifies which directory to scan for C<*.xpl> files. In fact, the |
664 |
B<add_default_methods> routine simply calls this routine with the installation |
665 |
directory as the first argument. The definition of the additional arguments is |
666 |
the same as above. |
667 |
|
668 |
B<add_procs_in_dir> is provided for symmetry. |
669 |
|
670 |
=item share_methods(SERVER, NAMES) |
671 |
|
672 |
=item share_procs(SERVER, NAMES) |
673 |
|
674 |
The calling server object shares the methods and/or procedures listed in |
675 |
B<NAMES> with the source-server passed as the first object. The source must |
676 |
derive from this package in order for this operation to be permitted. At least |
677 |
one method must be specified, and all are specified by name (not by object |
678 |
refernce). Both objects will reference the same exact B<RPC::XML::Procedure> |
679 |
(or B<Method>, or derivative thereof) object in this case, meaning that |
680 |
call-statistics and the like will reflect the combined data. If one or more of |
681 |
the passed names are not present on the source server, an error message is |
682 |
returned and none are copied to the calling object. |
683 |
|
684 |
Alternately, one or more of the name parameters passed to this call may be |
685 |
regular-expression objects (the result of the B<qr> operator). Any of these |
686 |
detected are applied against the list of all available methods known to the |
687 |
source server. All matching ones are inserted into the list (the list is pared |
688 |
for redundancies in any case). This allows for easier addition of whole |
689 |
classes such as those in the C<system.*> name space (via B<C<qr/^system\./>>), |
690 |
for example. There is no substring matching provided. Names listed in the |
691 |
parameters to this routine must be either complete strings or regular |
692 |
expressions. |
693 |
|
694 |
The B<share_procs> interface is provided for symmetry. |
695 |
|
696 |
=item copy_methods(SERVER, NAMES) |
697 |
|
698 |
=item copy_procs(SERVER, NAMES) |
699 |
|
700 |
This behaves like the method B<share_methods> above, with the exception that |
701 |
the calling object is given a clone of each method, rather than referencing |
702 |
the same exact method as the source server. The code reference part of the |
703 |
method is shared between the two, but all other data are copied (including a |
704 |
fresh copy of any list references used) into a completely new |
705 |
B<RPC::XML::Procedure> (or derivative) object, using the C<clone()> method |
706 |
from that class. Thus, while the calling object has the same methods |
707 |
available, and is re-using existing code in the Perl runtime, the method |
708 |
objects (and hence the statistics and such) are kept separate. As with the |
709 |
above, an error is flagged if one or more are not found. |
710 |
|
711 |
This routine also accepts regular-expression objects with the same behavior |
712 |
and limitations. Again, B<copy_procs> is simply provided for symmetry. |
713 |
|
714 |
=back |
715 |
|
716 |
=head2 Specifying Server-Side Remote Methods |
717 |
|
718 |
Specifying the methods themselves can be a tricky undertaking. Some packages |
719 |
(in other languages) delegate a specific class to handling incoming requests. |
720 |
This works well, but it can lead to routines not intended for public |
721 |
availability to in fact be available. There are also issues around the access |
722 |
that the methods would then have to other resources within the same running |
723 |
system. |
724 |
|
725 |
The approach taken by B<RPC::XML::Server> (and the B<Apache::RPC::Server> |
726 |
subclass of it) require that methods be explicitly published in one of the |
727 |
several ways provided. Methods may be added directly within code by using |
728 |
C<add_method> as described above, with full data provided for the code |
729 |
reference, signature list, etc. The C<add_method> technique can also be used |
730 |
with a file that conforms to a specific XML-based format (detailed in the |
731 |
manual page for the B<RPC::XML::Procedure> class, see L<RPC::XML::Procedure>). |
732 |
Entire directories of files may be added using C<add_methods_in_dir>, which |
733 |
merely reads the given directory for files that appear to be method |
734 |
definitions. |
735 |
|
736 |
=head2 How Methods Are Called |
737 |
|
738 |
When a routine is called via the server dispatcher, it is called with the |
739 |
arguments that the client request passed. Depending on whether the routine is |
740 |
considered a "procedure" or a "method", there may be an extra argument at the |
741 |
head of the list. The extra argument is present when the routine being |
742 |
dispatched is part of a B<RPC::XML::Method> object. The extra argument is a |
743 |
reference to a B<RPC::XML::Server> object (or a subclass thereof). This is |
744 |
derived from a hash reference, and will include two special keys: |
745 |
|
746 |
=over 4 |
747 |
|
748 |
=item method_name |
749 |
|
750 |
This is the name by which the method was called in the client. Most of the |
751 |
time, this will probably be consistent for all calls to the server-side |
752 |
method. But it does not have to be, hence the passing of the value. |
753 |
|
754 |
=item signature |
755 |
|
756 |
This is the signature that was used, when dispatching. Perl has a liberal |
757 |
view of lists and scalars, so it is not always clear what arguments the client |
758 |
specifically has in mind when calling the method. The signature is an array |
759 |
reference containing one or more datatypes, each a simple string. The first |
760 |
of the datatypes specifies the expected return type. The remainder (if any) |
761 |
refer to the arguments themselves. |
762 |
|
763 |
=back |
764 |
|
765 |
Note that by passing the server object reference first, method-classed |
766 |
routines are essentially expected to behave as actual methods of the server |
767 |
class, as opposed to ordinary functions. Of course, they can also discard the |
768 |
initial argument completely. |
769 |
|
770 |
The routines should not make (excessive) use of global variables, for obvious |
771 |
reasons. When the routines are loaded from XPL files, the code is created as a |
772 |
closure that forces execution in the B<RPC::XML::Procedure> package. If the |
773 |
code element of a procedure/method is passed in as a direct code reference by |
774 |
one of the other syntaxes allowed by the constructor, the package may well be |
775 |
different. Thus, routines should strive to be as localized as possible, |
776 |
independant of specific namespaces. If a group of routines are expected to |
777 |
work in close concert, each should explicitly set the namespace with a |
778 |
C<package> declaration as the first statement within the routines themselves. |
779 |
|
780 |
=head2 The Default Methods Provided |
781 |
|
782 |
The following methods are provided with this package, and are the ones |
783 |
installed on newly-created server objects unless told not to. These are |
784 |
identified by their published names, as they are compiled internally as |
785 |
anonymous subroutines and thus cannot be called directly: |
786 |
|
787 |
=over 4 |
788 |
|
789 |
=item B<system.identity> |
790 |
|
791 |
Returns a B<string> value identifying the server name, version, and possibly a |
792 |
capability level. Takes no arguments. |
793 |
|
794 |
=item B<system.introspection> |
795 |
|
796 |
Returns a series of B<struct> objects that give overview documentation of one |
797 |
or more of the published methods. It may be called with a B<string> |
798 |
identifying a single routine, in which case the return value is a |
799 |
B<struct>. It may be called with an B<array> of B<string> values, in which |
800 |
case an B<array> of B<struct> values, one per element in, is returned. Lastly, |
801 |
it may be called with no input parameters, in which case all published |
802 |
routines are documented. Note that routines may be configured to be hidden |
803 |
from such introspection queries. |
804 |
|
805 |
=item B<system.listMethods> |
806 |
|
807 |
Returns a list of the published methods or a subset of them as an B<array> of |
808 |
B<string> values. If called with no parameters, returns all (non-hidden) |
809 |
method names. If called with a single B<string> pattern, returns only those |
810 |
names that contain the string as a substring of their name (case-sensitive, |
811 |
and this is I<not> a regular expression evaluation). |
812 |
|
813 |
=item B<system.methodHelp> |
814 |
|
815 |
Takes either a single method name as a B<string>, or a series of them as an |
816 |
B<array> of B<string>. The return value is the help text for the method, as |
817 |
either a B<string> or B<array> of B<string> value. If the method(s) have no |
818 |
help text, the string will be null. |
819 |
|
820 |
=item B<system.methodSignature> |
821 |
|
822 |
As above, but returns the signatures that the method accepts, as B<array> of |
823 |
B<string> representations. If only one method is requests via a B<string> |
824 |
parameter, then the return value is the corresponding array. If the parameter |
825 |
in is an B<array>, then the returned value will be an B<array> of B<array> of |
826 |
B<string>. |
827 |
|
828 |
=item B<system.multicall> |
829 |
|
830 |
This is a simple implementation of composite function calls in a single |
831 |
request. It takes an B<array> of B<struct> values. Each B<struct> has at least |
832 |
a C<methodName> member, which provides the name of the method to call. If |
833 |
there is also a C<params> member, it refers to an B<array> of the parameters |
834 |
that should be passed to the call. |
835 |
|
836 |
=item B<system.status> |
837 |
|
838 |
Takes no arguments and returns a B<struct> containing a number of system |
839 |
status values including (but not limited to) the current time on the server, |
840 |
the time the server was started (both of these are returned in both ISO 8601 |
841 |
and UNIX-style integer formats), number of requests dispatched, and some |
842 |
identifying information (hostname, port, etc.). |
843 |
|
844 |
=back |
845 |
|
846 |
In addition, each of these has an accompanying help file in the C<methods> |
847 |
sub-directory of the distribution. |
848 |
|
849 |
These methods are installed as C<*.xpl> files, which are generated from files |
850 |
in the C<methods> directory of the distribution using the B<make_method> tool |
851 |
(see L<make_method>). The files there provide the Perl code that implements |
852 |
these, their help files and other information. |
853 |
|
854 |
=head1 DIAGNOSTICS |
855 |
|
856 |
Unless explicitly stated otherwise, all methods return some type of reference |
857 |
on success, or an error string on failure. Non-reference return values should |
858 |
always be interpreted as errors unless otherwise noted. |
859 |
|
860 |
=head1 CAVEATS |
861 |
|
862 |
This began as a reference implementation in which clarity of process and |
863 |
readability of the code took precedence over general efficiency. It is now |
864 |
being maintained as production code, but may still have parts that could be |
865 |
written more efficiently. |
866 |
|
867 |
=head1 CREDITS |
868 |
|
869 |
The B<XML-RPC> standard is Copyright (c) 1998-2001, UserLand Software, Inc. |
870 |
See <http://www.xmlrpc.com> for more information about the B<XML-RPC> |
871 |
specification. A helpful patch was sent in by Tino Wuensche to fix problems |
872 |
in the signal-setting and signal-catching code in server_loop(). |
873 |
|
874 |
=head1 LICENSE |
875 |
|
876 |
This module is licensed under the terms of the Artistic License that covers |
877 |
Perl. See <http://language.perl.com/misc/Artistic.html> for the |
878 |
license. |
879 |
|
880 |
=head1 SEE ALSO |
881 |
|
882 |
L<RPC::XML>, L<RPC::XML::Client>, L<RPC::XML::Parser> |
883 |
|
884 |
=head1 AUTHOR |
885 |
|
886 |
Randy J. Ray <rjray@blackperl.com> |
887 |
|
888 |
=cut |
889 |
|
890 |
__END__ |
891 |
|
892 |
############################################################################### |
893 |
# |
894 |
# Sub Name: add_proc |
895 |
# |
896 |
# Description: This filters through to add_method, but unlike the other |
897 |
# front-ends defined later, this one may have to alter the |
898 |
# data in one type of calling-convention. |
899 |
# |
900 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
901 |
# $self in ref Object reference |
902 |
# $meth in scalar Procedure to add |
903 |
# |
904 |
# Returns: threads through to add_method |
905 |
# |
906 |
############################################################################### |
907 |
sub add_proc |
908 |
{ |
909 |
my ($self, $meth) = @_; |
910 |
|
911 |
# Anything else but a hash-reference goes through unaltered |
912 |
$meth->{type} = 'procedure' if (ref($meth) eq 'HASH'); |
913 |
|
914 |
$self->add_method($meth); |
915 |
} |
916 |
|
917 |
############################################################################### |
918 |
# |
919 |
# Sub Name: method_from_file |
920 |
# |
921 |
# Description: Create a RPC::XML::Procedure (or ::Method) object from the |
922 |
# passed-in file name, using the object's search path if the |
923 |
# name is not already absolute. |
924 |
# |
925 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
926 |
# $self in ref Object of this class |
927 |
# $file in scalar Name of file to load |
928 |
# |
929 |
# Returns: Success: Method-object reference |
930 |
# Failure: error message |
931 |
# |
932 |
############################################################################### |
933 |
sub method_from_file |
934 |
{ |
935 |
my $self = shift; |
936 |
my $file = shift; |
937 |
|
938 |
unless (File::Spec->file_name_is_absolute($file)) |
939 |
{ |
940 |
my ($path, @path); |
941 |
push(@path, @{$self->xpl_path}) if (ref $self); |
942 |
for (@path, @XPL_PATH) |
943 |
{ |
944 |
$path = File::Spec->catfile($_, $file); |
945 |
if (-e $path) { $file = File::Spec->canonpath($path); last; } |
946 |
} |
947 |
} |
948 |
# Just in case it still didn't appear in the path, we really want an |
949 |
# absolute path: |
950 |
$file = File::Spec->rel2abs($file) |
951 |
unless (File::Spec->file_name_is_absolute($file)); |
952 |
|
953 |
RPC::XML::Procedure::new(undef, $file); |
954 |
} |
955 |
|
956 |
# Same as above, but for name-symmetry |
957 |
sub proc_from_file { shift->method_from_file(@_) } |
958 |
|
959 |
############################################################################### |
960 |
# |
961 |
# Sub Name: get_method |
962 |
# |
963 |
# Description: Get the current binding for the remote-side method $name. |
964 |
# Returns undef if the method is not defined for the server |
965 |
# instance. |
966 |
# |
967 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
968 |
# $self in ref Class instance |
969 |
# $name in scalar Name of the method being looked |
970 |
# up |
971 |
# |
972 |
# Returns: Success: Method-class reference |
973 |
# Failure: error string |
974 |
# |
975 |
############################################################################### |
976 |
sub get_method |
977 |
{ |
978 |
my $self = shift; |
979 |
my $name = shift; |
980 |
|
981 |
my $meth = $self->{__method_table}->{$name}; |
982 |
unless (defined $meth) |
983 |
{ |
984 |
if ($self->{__auto_methods}) |
985 |
{ |
986 |
# Try to load this dynamically on the fly, from any of the dirs |
987 |
# that are in this object's @xpl_path |
988 |
(my $loadname = $name) =~ s/^system\.//; |
989 |
$self->add_method("$loadname.xpl"); |
990 |
} |
991 |
# If method is still not in the table, we were unable to load it |
992 |
return "Unknown method: $name" |
993 |
unless $meth = $self->{__method_table}->{$name}; |
994 |
} |
995 |
# Check the mod-time of the file the method came from, if the test is on |
996 |
if ($self->{__auto_updates} && $meth->{file} && |
997 |
($meth->{mtime} < (stat $meth->{file})[9])) |
998 |
{ |
999 |
$ret = $meth->reload; |
1000 |
return "Reload of method $name failed: $ret" unless ref($ret); |
1001 |
} |
1002 |
|
1003 |
$meth; |
1004 |
} |
1005 |
|
1006 |
# Same as above, but for name-symmetry |
1007 |
sub get_proc { shift->get_method(@_) } |
1008 |
|
1009 |
############################################################################### |
1010 |
# |
1011 |
# Sub Name: server_loop |
1012 |
# |
1013 |
# Description: Enter a server-loop situation, using the accept() loop of |
1014 |
# HTTP::Daemon if $self has such an object, or falling back |
1015 |
# Net::Server otherwise. |
1016 |
# |
1017 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1018 |
# $self in ref Object of this class |
1019 |
# %args in hash Additional parameters to set up |
1020 |
# before calling the superclass |
1021 |
# Run method |
1022 |
# |
1023 |
# Returns: string if error, otherwise void |
1024 |
# |
1025 |
############################################################################### |
1026 |
sub server_loop |
1027 |
{ |
1028 |
my $self = shift; |
1029 |
my %args = @_; |
1030 |
|
1031 |
if ($self->{__daemon}) |
1032 |
{ |
1033 |
my ($conn, $req, $resp, $reqxml, $return, $respxml, $exit_now, |
1034 |
$timeout); |
1035 |
|
1036 |
# Localize and set the signal handler as an exit route |
1037 |
my @exit_signals; |
1038 |
|
1039 |
if (exists $args{signal} and $args{signal} ne 'NONE') |
1040 |
{ |
1041 |
@exit_signals = |
1042 |
(ref $args{signal}) ? @{$args{signal}} : $args{signal}; |
1043 |
} |
1044 |
else |
1045 |
{ |
1046 |
push @exit_signals, 'INT'; |
1047 |
} |
1048 |
|
1049 |
local @SIG{@exit_signals} = ( sub { $exit_now++ } ) x @exit_signals; |
1050 |
|
1051 |
$self->started('set'); |
1052 |
$exit_now = 0; |
1053 |
$timeout = $self->{__daemon}->timeout(1); |
1054 |
while (! $exit_now) |
1055 |
{ |
1056 |
$conn = $self->{__daemon}->accept; |
1057 |
|
1058 |
last if $exit_now; |
1059 |
next unless $conn; |
1060 |
$conn->timeout($self->{__timeout}); |
1061 |
$self->process_request($conn); |
1062 |
$conn->close; |
1063 |
undef $conn; # Free up any lingering resources |
1064 |
} |
1065 |
|
1066 |
$self->{__daemon}->timeout($timeout) if defined $timeout; |
1067 |
} |
1068 |
else |
1069 |
{ |
1070 |
# This is the Net::Server block |
1071 |
|
1072 |
# Don't do this next part if they've already given a port, or are |
1073 |
# pointing to a config file: |
1074 |
|
1075 |
# An explicitly-given conf-file trumps any specified at creation |
1076 |
$args{conf_file} = $self->{conf_file} |
1077 |
if (exists($self->{conf_file}) and (! exists $args{conf_file})); |
1078 |
unless ($args{conf_file} or $args{port}) |
1079 |
{ |
1080 |
$args{port} = $self->{port} || $self->{__port} || 9000; |
1081 |
$args{host} = $self->{host} || $self->{__host} || '*'; |
1082 |
} |
1083 |
|
1084 |
# Try to load the Net::Server::MultiType module |
1085 |
eval { require Net::Server::MultiType; }; |
1086 |
return ref($self) . |
1087 |
"::server_loop: Error loading Net::Server::MultiType: $@" |
1088 |
if ($@); |
1089 |
unshift(@RPC::XML::Server::ISA, 'Net::Server::MultiType'); |
1090 |
|
1091 |
$self->started('set'); |
1092 |
# ...and we're off! |
1093 |
$self->run(%args); |
1094 |
} |
1095 |
|
1096 |
return; |
1097 |
} |
1098 |
|
1099 |
############################################################################### |
1100 |
# |
1101 |
# Sub Name: post_configure_loop |
1102 |
# |
1103 |
# Description: Called by the Net::Server classes after all the config |
1104 |
# steps have been done and merged. |
1105 |
# |
1106 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1107 |
# $self in ref Class object |
1108 |
# |
1109 |
# Returns: $self |
1110 |
# |
1111 |
############################################################################### |
1112 |
sub post_configure_hook |
1113 |
{ |
1114 |
my $self = shift; |
1115 |
|
1116 |
$self->{__host} = $self->{server}->{host}; |
1117 |
$self->{__port} = $self->{server}->{port}; |
1118 |
|
1119 |
$self; |
1120 |
} |
1121 |
|
1122 |
############################################################################### |
1123 |
# |
1124 |
# Sub Name: pre_loop_hook |
1125 |
# |
1126 |
# Description: Called by Net::Server classes after the post_bind method, |
1127 |
# but before the socket-accept loop starts. |
1128 |
# |
1129 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1130 |
# $self in ref Object instance |
1131 |
# |
1132 |
# Globals: %ENV |
1133 |
# |
1134 |
# Returns: $self |
1135 |
# |
1136 |
############################################################################### |
1137 |
sub pre_loop_hook |
1138 |
{ |
1139 |
# We have to disable the __DIE__ handler for the sake of XML::Parser::Expat |
1140 |
$SIG{__DIE__} = ''; |
1141 |
} |
1142 |
|
1143 |
############################################################################### |
1144 |
# |
1145 |
# Sub Name: process_request |
1146 |
# |
1147 |
# Description: This is provided for the case when we run as a subclass |
1148 |
# of Net::Server. |
1149 |
# |
1150 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1151 |
# $self in ref This class object |
1152 |
# $conn in ref If present, it's a connection |
1153 |
# object from HTTP::Daemon |
1154 |
# |
1155 |
# Returns: void |
1156 |
# |
1157 |
############################################################################### |
1158 |
sub process_request |
1159 |
{ |
1160 |
my $self = shift; |
1161 |
my $conn = shift; |
1162 |
|
1163 |
my ($req, $reqxml, $resp, $respxml); |
1164 |
|
1165 |
unless ($conn and ref($conn)) |
1166 |
{ |
1167 |
$conn = $self->{server}->{client}; |
1168 |
bless $conn, 'HTTP::Daemon::ClientConn'; |
1169 |
${*$conn}{'httpd_daemon'} = $self; |
1170 |
} |
1171 |
|
1172 |
while ($req = $conn->get_request) |
1173 |
{ |
1174 |
if ($req->method eq 'HEAD') |
1175 |
{ |
1176 |
# The HEAD method will be answered with our return headers, |
1177 |
# both as a means of self-identification and a verification |
1178 |
# of live-status. All the headers were pre-set in the cached |
1179 |
# HTTP::Response object. Also, we don't count this for stats. |
1180 |
$conn->send_response($self->{__response}); |
1181 |
} |
1182 |
elsif ($req->method eq 'POST') |
1183 |
{ |
1184 |
$reqxml = $req->content; |
1185 |
# Dispatch will always return a RPC::XML::response |
1186 |
$resp = $self->dispatch(\$reqxml); |
1187 |
$respxml = $resp->as_string; |
1188 |
# Now clone the pre-fab response and add content |
1189 |
$resp = $self->{__response}->clone; |
1190 |
$resp->content($respxml); |
1191 |
$conn->send_response($resp); |
1192 |
undef $resp; |
1193 |
} |
1194 |
else |
1195 |
{ |
1196 |
$conn->send_error(&HTTP::Status::RC_FORBIDDEN); |
1197 |
} |
1198 |
} |
1199 |
|
1200 |
return; |
1201 |
} |
1202 |
|
1203 |
############################################################################### |
1204 |
# |
1205 |
# Sub Name: dispatch |
1206 |
# |
1207 |
# Description: Route the request by parsing it, determining what the |
1208 |
# Perl routine should be, etc. |
1209 |
# |
1210 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1211 |
# $self in ref Object of this class |
1212 |
# $xml in ref Reference to the XML text, or |
1213 |
# a RPC::XML::request object. |
1214 |
# If it is a listref, assume |
1215 |
# [ name, @args ]. |
1216 |
# $reftable in hashref If present, a reference to the |
1217 |
# current-running table of |
1218 |
# back-references |
1219 |
# |
1220 |
# Returns: RPC::XML::response object |
1221 |
# |
1222 |
############################################################################### |
1223 |
sub dispatch |
1224 |
{ |
1225 |
my ($self, $xml) = @_; |
1226 |
|
1227 |
my ($reqobj, @data, $response, $name, $meth); |
1228 |
|
1229 |
if (ref($xml) eq 'SCALAR') |
1230 |
{ |
1231 |
$reqobj = $self->{__parser}->parse($$xml); |
1232 |
return RPC::XML::response |
1233 |
->new(RPC::XML::fault->new(200, "XML parse failure: $reqobj")) |
1234 |
unless (ref $reqobj); |
1235 |
} |
1236 |
elsif (ref($xml) eq 'ARRAY') |
1237 |
{ |
1238 |
# This is sort of a cheat, to make the system.multicall API call a |
1239 |
# lot easier. The syntax isn't documented in the manual page, for good |
1240 |
# reason. |
1241 |
$reqobj = RPC::XML::request->new(shift(@$xml), @$xml); |
1242 |
} |
1243 |
elsif (UNIVERSAL::isa($xml, 'RPC::XML::request')) |
1244 |
{ |
1245 |
$reqobj = $xml; |
1246 |
} |
1247 |
else |
1248 |
{ |
1249 |
$reqobj = $self->{__parser}->parse($xml); |
1250 |
return RPC::XML::response |
1251 |
->new(RPC::XML::fault->new(200, "XML parse failure: $reqobj")) |
1252 |
unless (ref $reqobj); |
1253 |
} |
1254 |
|
1255 |
@data = @{$reqobj->args}; |
1256 |
$name = $reqobj->name; |
1257 |
|
1258 |
# Get the method, call it, and bump the internal requests counter. Create |
1259 |
# a fault object if there is problem with the method object itself. |
1260 |
if (ref($meth = $self->get_method($name))) |
1261 |
{ |
1262 |
$response = $meth->call($self, @data); |
1263 |
$self->{__requests}++; |
1264 |
} |
1265 |
else |
1266 |
{ |
1267 |
$response = RPC::XML::fault->new(300, $meth); |
1268 |
} |
1269 |
|
1270 |
# All the eval'ing and error-trapping happened within the method class |
1271 |
RPC::XML::response->new($response); |
1272 |
} |
1273 |
|
1274 |
############################################################################### |
1275 |
# |
1276 |
# Sub Name: call |
1277 |
# |
1278 |
# Description: This is an internal, end-run-around-dispatch() method to |
1279 |
# allow the RPC methods that this server has and knows about |
1280 |
# to call each other through their reference to the server |
1281 |
# object. |
1282 |
# |
1283 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1284 |
# $self in ref Object of this class |
1285 |
# $name in scalar Name of the method to call |
1286 |
# @args in list Arguments (if any) to pass |
1287 |
# |
1288 |
# Returns: Success: return value of the call |
1289 |
# Failure: error string |
1290 |
# |
1291 |
############################################################################### |
1292 |
sub call |
1293 |
{ |
1294 |
my ($self, $name, @args) = @_; |
1295 |
|
1296 |
my $meth; |
1297 |
|
1298 |
# |
1299 |
# Two VERY important notes here: The values in @args are not pre-treated |
1300 |
# in any way, so not only should the receiver understand what they're |
1301 |
# getting, there's no signature checking taking place, either. |
1302 |
# |
1303 |
# Second, if the normal return value is not distinguishable from a string, |
1304 |
# then the caller may not recognize if an error occurs. |
1305 |
# |
1306 |
|
1307 |
return $meth unless ref($meth = $self->get_method($name)); |
1308 |
$meth->call($self, @args); |
1309 |
} |
1310 |
|
1311 |
############################################################################### |
1312 |
# |
1313 |
# Sub Name: add_default_methods |
1314 |
# |
1315 |
# Description: This adds all the methods that were shipped with this |
1316 |
# package, by threading through to add_methods_in_dir() |
1317 |
# with the global constant $INSTALL_DIR. |
1318 |
# |
1319 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1320 |
# $self in ref Object reference/static class |
1321 |
# @details in ref Details of names to add or skip |
1322 |
# |
1323 |
# Globals: $INSTALL_DIR |
1324 |
# |
1325 |
# Returns: $self |
1326 |
# |
1327 |
############################################################################### |
1328 |
sub add_default_methods |
1329 |
{ |
1330 |
shift->add_methods_in_dir($INSTALL_DIR, @_); |
1331 |
} |
1332 |
|
1333 |
############################################################################### |
1334 |
# |
1335 |
# Sub Name: add_methods_in_dir |
1336 |
# |
1337 |
# Description: This adds all methods specified in the directory passed, |
1338 |
# in accordance with the details specified. |
1339 |
# |
1340 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1341 |
# $self in ref Class instance |
1342 |
# $dir in scalar Directory to scan |
1343 |
# @details in list Possible hanky-panky with the |
1344 |
# list of methods to install |
1345 |
# |
1346 |
# Returns: $self |
1347 |
# |
1348 |
############################################################################### |
1349 |
sub add_methods_in_dir |
1350 |
{ |
1351 |
my $self = shift; |
1352 |
my $dir = shift; |
1353 |
my @details = @_; |
1354 |
|
1355 |
my $negate = 0; |
1356 |
my $detail = 0; |
1357 |
my (%details, $ret); |
1358 |
|
1359 |
if (@details) |
1360 |
{ |
1361 |
$detail = 1; |
1362 |
if ($details[0] =~ /^-?except/i) |
1363 |
{ |
1364 |
$negate = 1; |
1365 |
shift(@details); |
1366 |
} |
1367 |
for (@details) { $_ .= '.xpl' unless /\.xpl$/ } |
1368 |
@details{@details} = (1) x @details; |
1369 |
} |
1370 |
|
1371 |
local(*D); |
1372 |
opendir(D, $dir) || return "Error opening $dir for reading: $!"; |
1373 |
my @files = grep($_ =~ /\.xpl$/, readdir(D)); |
1374 |
closedir D; |
1375 |
|
1376 |
for (@files) |
1377 |
{ |
1378 |
# Use $detail as a short-circuit to avoid the other tests when we can |
1379 |
next if ($detail and |
1380 |
$negate ? $details{$_} : ! $details{$_}); |
1381 |
# n.b.: Giving the full path keeps add_method from having to search |
1382 |
$ret = $self->add_method(File::Spec->catfile($dir, $_)); |
1383 |
return $ret unless ref $ret; |
1384 |
} |
1385 |
|
1386 |
$self; |
1387 |
} |
1388 |
|
1389 |
# Same as above, but for name-symmetry |
1390 |
sub add_procs_in_dir { shift->add_methods_in_dir(@_) } |
1391 |
|
1392 |
############################################################################### |
1393 |
# |
1394 |
# Sub Name: delete_method |
1395 |
# |
1396 |
# Description: Remove any current binding for the named method on the |
1397 |
# calling server object. Note that if this method is shared |
1398 |
# across other server objects, it won't be destroyed until |
1399 |
# the last server deletes it. |
1400 |
# |
1401 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1402 |
# $self in ref Object of this class |
1403 |
# $name in scalar Name of method to lost |
1404 |
# |
1405 |
# Returns: Success: $self |
1406 |
# Failure: error message |
1407 |
# |
1408 |
############################################################################### |
1409 |
sub delete_method |
1410 |
{ |
1411 |
my $self = shift; |
1412 |
my $name = shift; |
1413 |
|
1414 |
if ($name) |
1415 |
{ |
1416 |
if ($self->{__method_table}->{$name}) |
1417 |
{ |
1418 |
delete $self->{__method_table}->{$name}; |
1419 |
return $self; |
1420 |
} |
1421 |
} |
1422 |
else |
1423 |
{ |
1424 |
return ref($self) . "::delete_method: No such method $name"; |
1425 |
} |
1426 |
} |
1427 |
|
1428 |
# Same as above, but for name-symmetry |
1429 |
sub delete_proc { shift->delete_method(@_) } |
1430 |
|
1431 |
############################################################################### |
1432 |
# |
1433 |
# Sub Name: list_methods |
1434 |
# |
1435 |
# Description: Return a list of the methods this object has published. |
1436 |
# Returns the names, not the objects. |
1437 |
# |
1438 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1439 |
# $self in ref Object of this class |
1440 |
# |
1441 |
# Returns: List of names, possibly empty |
1442 |
# |
1443 |
############################################################################### |
1444 |
sub list_methods |
1445 |
{ |
1446 |
keys %{$_[0]->{__method_table}}; |
1447 |
} |
1448 |
|
1449 |
# Same as above, but for name-symmetry |
1450 |
sub list_procs { shift->list_methods(@_) } |
1451 |
|
1452 |
############################################################################### |
1453 |
# |
1454 |
# Sub Name: share_methods |
1455 |
# |
1456 |
# Description: Share the named methods as found on $src_srv into the |
1457 |
# method table of the calling object. |
1458 |
# |
1459 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1460 |
# $self in ref Object of this class |
1461 |
# $src_srv in ref Another object of this class |
1462 |
# @names in list One or more method names |
1463 |
# |
1464 |
# Returns: Success: $self |
1465 |
# Failure: error message |
1466 |
# |
1467 |
############################################################################### |
1468 |
sub share_methods |
1469 |
{ |
1470 |
my $self = shift; |
1471 |
my $src_srv = shift; |
1472 |
my @names = @_; |
1473 |
|
1474 |
my ($me, $pkg, %tmp, @tmp, $tmp, $meth, @list, @missing); |
1475 |
|
1476 |
$me = ref($self) . '::share_methods'; |
1477 |
$pkg = __PACKAGE__; # So it can go inside quoted strings |
1478 |
|
1479 |
return "$me: First arg not derived from $pkg, cannot share" |
1480 |
unless ((ref $src_srv) && (UNIVERSAL::isa($src_srv, $pkg))); |
1481 |
return "$me: Must specify at least one method name for sharing" |
1482 |
unless @names; |
1483 |
|
1484 |
# |
1485 |
# Scan @names for any regez objects, and if found insert the matches into |
1486 |
# the list. |
1487 |
# |
1488 |
# Only do this once: |
1489 |
# |
1490 |
@tmp = keys %{$src_srv->{__method_table}}; |
1491 |
for $tmp (@names) |
1492 |
{ |
1493 |
if (ref($names[$tmp]) eq 'Regexp') |
1494 |
{ |
1495 |
$tmp{$_}++ for (grep($_ =~ $tmp, @tmp)); |
1496 |
} |
1497 |
else |
1498 |
{ |
1499 |
$tmp{$tmp}++; |
1500 |
} |
1501 |
} |
1502 |
# This has the benefit of trimming any redundancies caused by regex's |
1503 |
@names = keys %tmp; |
1504 |
|
1505 |
# |
1506 |
# Note that the method refs are saved until we've verified all of them. |
1507 |
# If we have to return a failure message, I don't want to leave a half- |
1508 |
# finished job or have to go back and undo (n-1) additions because of one |
1509 |
# failure. |
1510 |
# |
1511 |
for (@names) |
1512 |
{ |
1513 |
$meth = $src_srv->get_method($_); |
1514 |
if (ref $meth) |
1515 |
{ |
1516 |
push(@list, $meth); |
1517 |
} |
1518 |
else |
1519 |
{ |
1520 |
push(@missing, $_); |
1521 |
} |
1522 |
} |
1523 |
|
1524 |
if (@missing) |
1525 |
{ |
1526 |
return "$me: One or more methods not found on source object: @missing"; |
1527 |
} |
1528 |
else |
1529 |
{ |
1530 |
$self->add_method($_) for (@list); |
1531 |
} |
1532 |
|
1533 |
$self; |
1534 |
} |
1535 |
|
1536 |
# Same as above, but for name-symmetry |
1537 |
sub share_procs { shift->share_methods(@_) } |
1538 |
|
1539 |
############################################################################### |
1540 |
# |
1541 |
# Sub Name: copy_methods |
1542 |
# |
1543 |
# Description: Copy the named methods as found on $src_srv into the |
1544 |
# method table of the calling object. This differs from |
1545 |
# share() above in that only the coderef is shared, the |
1546 |
# rest of the method is a completely new object. |
1547 |
# |
1548 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1549 |
# $self in ref Object of this class |
1550 |
# $src_srv in ref Another object of this class |
1551 |
# @names in list One or more method names |
1552 |
# |
1553 |
# Returns: Success: $self |
1554 |
# Failure: error message |
1555 |
# |
1556 |
############################################################################### |
1557 |
sub copy_methods |
1558 |
{ |
1559 |
my $self = shift; |
1560 |
my $src_srv = shift; |
1561 |
my @names = shift; |
1562 |
|
1563 |
my ($me, $pkg, %tmp, @tmp, $tmp, $meth, @list, @missing); |
1564 |
|
1565 |
$me = ref($self) . '::copy_methods'; |
1566 |
$pkg = __PACKAGE__; # So it can go inside quoted strings |
1567 |
|
1568 |
return "$me: First arg not derived from $pkg, cannot copy" |
1569 |
unless ((ref $src_srv) && (UNIVERSAL::isa($src_srv, $pkg))); |
1570 |
return "$me: Must specify at least one method name/regex for copying" |
1571 |
unless @names; |
1572 |
|
1573 |
# |
1574 |
# Scan @names for any regez objects, and if found insert the matches into |
1575 |
# the list. |
1576 |
# |
1577 |
# Only do this once: |
1578 |
# |
1579 |
@tmp = keys %{$src_srv->{__method_table}}; |
1580 |
for $tmp (@names) |
1581 |
{ |
1582 |
if (ref($names[$tmp]) eq 'Regexp') |
1583 |
{ |
1584 |
$tmp{$_}++ for (grep($_ =~ $tmp, @tmp)); |
1585 |
} |
1586 |
else |
1587 |
{ |
1588 |
$tmp{$tmp}++; |
1589 |
} |
1590 |
} |
1591 |
# This has the benefit of trimming any redundancies caused by regex's |
1592 |
@names = keys %tmp; |
1593 |
|
1594 |
# |
1595 |
# Note that the method clones are saved until we've verified all of them. |
1596 |
# If we have to return a failure message, I don't want to leave a half- |
1597 |
# finished job or have to go back and undo (n-1) additions because of one |
1598 |
# failure. |
1599 |
# |
1600 |
for (@names) |
1601 |
{ |
1602 |
$meth = $src_srv->get_method($_); |
1603 |
if (ref $meth) |
1604 |
{ |
1605 |
push(@list, $meth->clone); |
1606 |
} |
1607 |
else |
1608 |
{ |
1609 |
push(@missing, $_); |
1610 |
} |
1611 |
} |
1612 |
|
1613 |
if (@missing) |
1614 |
{ |
1615 |
return "$me: One or more methods not found on source object: @missing"; |
1616 |
} |
1617 |
else |
1618 |
{ |
1619 |
$self->add_method($_) for (@list); |
1620 |
} |
1621 |
|
1622 |
$self; |
1623 |
} |
1624 |
|
1625 |
# Same as above, but for name-symmetry |
1626 |
sub copy_procs { shift->copy_methods(@_) } |
1627 |
|
1628 |
############################################################################### |
1629 |
# |
1630 |
# Sub Name: timeout |
1631 |
# |
1632 |
# Description: This sets the timeout for processing connections after |
1633 |
# a new connection has been accepted. It returns the old |
1634 |
# timeout value. If you pass in no value, it returns |
1635 |
# the current timeout. |
1636 |
# |
1637 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
1638 |
# $self in ref Object reference/static class |
1639 |
# $timeout in ref New timeout value |
1640 |
# |
1641 |
# Returns: $self->{__timeout} |
1642 |
# |
1643 |
############################################################################### |
1644 |
sub timeout |
1645 |
{ |
1646 |
my $self = shift; |
1647 |
my $timeout = shift; |
1648 |
|
1649 |
my $old_timeout = $self->{__timeout}; |
1650 |
if ($timeout) |
1651 |
{ |
1652 |
$self->{__timeout} = $timeout; |
1653 |
} |
1654 |
return $old_timeout; |
1655 |
} |