[system] / trunk / xmlrpc / RPC / RPC-XML-0.25 / lib / RPC / XML / Server.pm Repository:
ViewVC logotype

Annotation of /trunk/xmlrpc/RPC/RPC-XML-0.25/lib/RPC/XML/Server.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 279 - (view) (download) (as text)

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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9