1 |
############################################################################### |
2 |
# |
3 |
# This file copyright (c) 2001 by Randy J. Ray, all rights reserved |
4 |
# |
5 |
# Copying and distribution are permitted under the terms of the Artistic |
6 |
# License as distributed with Perl versions 5.005 and later. See |
7 |
# http://language.perl.com/misc/Artistic.html |
8 |
# |
9 |
############################################################################### |
10 |
# |
11 |
# $Id: Procedure.pm,v 1.5 2002/05/22 09:45:59 rjray Exp $ |
12 |
# |
13 |
# Description: This class abstracts out all the procedure-related |
14 |
# operations from the RPC::XML::Server class |
15 |
# |
16 |
# Functions: new |
17 |
# name \ |
18 |
# code \ |
19 |
# signature \ These are the accessor functions for the |
20 |
# help / data in the object, though it's visible. |
21 |
# version / |
22 |
# hidden / |
23 |
# clone |
24 |
# is_valid |
25 |
# add_signature |
26 |
# delete_signature |
27 |
# make_sig_table |
28 |
# match_signature |
29 |
# reload |
30 |
# load_XPL_file |
31 |
# |
32 |
# Libraries: XML::Parser (used only on demand in load_XPL_file) |
33 |
# File::Spec |
34 |
# |
35 |
# Global Consts: $VERSION |
36 |
# |
37 |
# Environment: None. |
38 |
# |
39 |
############################################################################### |
40 |
|
41 |
package RPC::XML::Procedure; |
42 |
|
43 |
use 5.005; |
44 |
use strict; |
45 |
use vars qw($VERSION); |
46 |
use subs qw(new is_valid name code signature help version hidden |
47 |
add_signature delete_signature make_sig_table match_signature |
48 |
reload load_XPL_file); |
49 |
|
50 |
use AutoLoader 'AUTOLOAD'; |
51 |
require File::Spec; |
52 |
|
53 |
$VERSION = do { my @r=(q$Revision: 1.5 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r }; |
54 |
|
55 |
1; |
56 |
|
57 |
############################################################################### |
58 |
# |
59 |
# Sub Name: new |
60 |
# |
61 |
# Description: Create a new object of this class, storing the info on |
62 |
# regular keys (no obfuscation used here). |
63 |
# |
64 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
65 |
# $class in scalar Class to bless into |
66 |
# @argz in variable Disposition is variable; see |
67 |
# below |
68 |
# |
69 |
# Returns: Success: object ref |
70 |
# Failure: error string |
71 |
# |
72 |
############################################################################### |
73 |
sub new |
74 |
{ |
75 |
my $class = shift; |
76 |
my @argz = @_; |
77 |
|
78 |
my $data; # This will be a hashref that eventually gets blessed |
79 |
|
80 |
$class = ref($class) || $class; |
81 |
|
82 |
# |
83 |
# There are three things that @argz could be: |
84 |
# |
85 |
if (ref $argz[0]) |
86 |
{ |
87 |
# 1. A hashref containing all the relevant keys |
88 |
$data = {}; |
89 |
%$data = %{$argz[0]}; |
90 |
} |
91 |
elsif (@argz == 1) |
92 |
{ |
93 |
# 2. Exactly one non-ref element, a file to load |
94 |
|
95 |
# And here is where I cheat in a way that makes even me uncomfortable. |
96 |
# |
97 |
# Loading code from an XPL file, it can actually be of a type other |
98 |
# than how this constructor was called. So what we are going to do is |
99 |
# this: If $class is undef, that can only mean that we were called |
100 |
# with the intent of letting the XPL file dictate the resulting object. |
101 |
# If $class is set, then we'll call load_XPL_file normally, as a |
102 |
# method, to allow for subclasses to tweak things. |
103 |
if (defined $class) |
104 |
{ |
105 |
$data = $class->load_XPL_file($argz[0]); |
106 |
return $data unless ref $data; # load_XPL_path signalled an error |
107 |
} |
108 |
else |
109 |
{ |
110 |
# Spoofing the "class" argument to load_XPL_file makes me feel |
111 |
# even dirtier... |
112 |
$data = load_XPL_file(\$class, $argz[0]); |
113 |
return $data unless ref $data; # load_XPL_path signalled an error |
114 |
$class = "RPC::XML::$class"; |
115 |
} |
116 |
} |
117 |
else |
118 |
{ |
119 |
# 3. If there is more than one arg, it's a sort-of-hash. That is, the |
120 |
# key 'signature' is allowed to repeat. |
121 |
my ($key, $val); |
122 |
$data = {}; |
123 |
$data->{signature} = []; |
124 |
while (@argz) |
125 |
{ |
126 |
($key, $val) = splice(@argz, 0, 2); |
127 |
if ($key eq 'signature') |
128 |
{ |
129 |
# Since there may be more than one signature, we allow it to |
130 |
# repeat. Of course, that's also why we can't just take @argz |
131 |
# directly as a hash. *shrug* |
132 |
push(@{$data->{signature}}, |
133 |
[ ref($val) ? @$val : split(/ /, $val) ]); |
134 |
} |
135 |
elsif (exists $data->{$key}) |
136 |
{ |
137 |
return "${class}::new: Key '$key' may not be repeated"; |
138 |
} |
139 |
else |
140 |
{ |
141 |
$data->{$key} = $val; |
142 |
} |
143 |
} |
144 |
} |
145 |
|
146 |
return "${class}::new: Missing required data" |
147 |
unless (exists $data->{signature} and |
148 |
(ref($data->{signature}) eq 'ARRAY') and |
149 |
scalar(@{$data->{signature}}) and |
150 |
$data->{name} and $data->{code}); |
151 |
bless $data, $class; |
152 |
# This needs to happen post-bless in case of error (for error messages) |
153 |
$data->make_sig_table; |
154 |
} |
155 |
|
156 |
############################################################################### |
157 |
# |
158 |
# Sub Name: make_sig_table |
159 |
# |
160 |
# Description: Create a hash table of the signatures that maps to the |
161 |
# corresponding return type for that particular invocation. |
162 |
# Makes looking up call patterns much easier. |
163 |
# |
164 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
165 |
# $self in ref Object of this class |
166 |
# |
167 |
# Returns: Success: $self |
168 |
# Failure: error message |
169 |
# |
170 |
############################################################################### |
171 |
sub make_sig_table |
172 |
{ |
173 |
my $self = shift; |
174 |
|
175 |
my ($sig, $return, $rest); |
176 |
|
177 |
delete $self->{sig_table}; |
178 |
for $sig (@{$self->{signature}}) |
179 |
{ |
180 |
($return, $rest) = split(/ /, $sig, 2); $rest = '' unless $rest; |
181 |
# If the key $rest already exists, then this is a collision |
182 |
return ref($self) . '::make_sig_table: Cannot have two different ' . |
183 |
"return values for one set of params ($return vs. " . |
184 |
"$self->{sig_table}->{$rest})" |
185 |
if $self->{sig_table}->{$rest}; |
186 |
$self->{sig_table}->{$rest} = $return; |
187 |
} |
188 |
|
189 |
$self; |
190 |
} |
191 |
|
192 |
# |
193 |
# These are basic accessor/setting functions for the various attributes |
194 |
# |
195 |
sub name { $_[0]->{name}; } # "name" cannot be changed at this level |
196 |
sub help { $_[1] and $_[0]->{help} = $_[1]; $_[0]->{help}; } |
197 |
sub version { $_[1] and $_[0]->{version} = $_[1]; $_[0]->{version}; } |
198 |
sub hidden { $_[1] and $_[0]->{hidden} = $_[1]; $_[0]->{hidden}; } |
199 |
sub code |
200 |
{ |
201 |
ref $_[1] eq 'CODE' and $_[0]->{code} = $_[1]; |
202 |
$_[0]->{code}; |
203 |
} |
204 |
sub signature |
205 |
{ |
206 |
if ($_[1] and ref $_[1] eq 'ARRAY') |
207 |
{ |
208 |
my $old = $_[0]->{signature}; |
209 |
$_[0]->{signature} = $_[1]; |
210 |
unless (ref($_[0]->make_sig_table)) |
211 |
{ |
212 |
# If it failed to re-init the table, restore the old list (and old |
213 |
# table). We don't have to check this return, since it had worked |
214 |
$_[0]->{signature} = $old; |
215 |
$_[0]->make_sig_table; |
216 |
} |
217 |
} |
218 |
# Return a copy of the array, not the original |
219 |
[ @{$_[0]->{signature}} ]; |
220 |
} |
221 |
|
222 |
package RPC::XML::Method; |
223 |
|
224 |
use strict; |
225 |
|
226 |
@RPC::XML::Method::ISA = qw(RPC::XML::Procedure); |
227 |
|
228 |
package RPC::XML::Procedure; |
229 |
|
230 |
=head1 NAME |
231 |
|
232 |
RPC::XML::Procedure - Object encapsulation of server-side RPC procedures |
233 |
|
234 |
=head1 SYNOPSIS |
235 |
|
236 |
require RPC::XML::Procedure; |
237 |
|
238 |
... |
239 |
$method_1 = RPC::XML::Procedure->new({ name => 'system.identity', |
240 |
code => sub { ... }, |
241 |
signature => [ 'string' ] }); |
242 |
$method_2 = RPC::XML::Procedure->new('/path/to/status.xpl'); |
243 |
|
244 |
=head1 IMPORTANT NOTE |
245 |
|
246 |
This package is comprised of the code that was formerly B<RPC::XML::Method>. |
247 |
The package was renamed when the decision was made to support procedures and |
248 |
methods as functionally different entities. It is not necessary to include |
249 |
both this module and B<RPC::XML::Method> -- this module provides the latter as |
250 |
an empty subclass. In time, B<RPC::XML::Method> will be removed from the |
251 |
distribution entirely. |
252 |
|
253 |
=head1 DESCRIPTION |
254 |
|
255 |
The B<RPC::XML::Procedure> package is designed primarily for behind-the-scenes |
256 |
use by the B<RPC::XML::Server> class and any subclasses of it. It is |
257 |
documented here in case a project chooses to sub-class it for their purposes |
258 |
(which would require setting the C<method_class> attribute when creating |
259 |
server objects, see L<RPC::XML::Server>). |
260 |
|
261 |
This package grew out of the increasing need to abstract the operations that |
262 |
related to the methods a given server instance was providing. Previously, |
263 |
methods were passed around simply as hash references. It was a small step then |
264 |
to move them into a package and allow for operations directly on the objects |
265 |
themselves. In the spirit of the original hashes, all the key data is kept in |
266 |
clear, intuitive hash keys (rather than obfuscated as the other classes |
267 |
do). Thus it is important to be clear on the interface here before |
268 |
sub-classing this package. |
269 |
|
270 |
=head1 USAGE |
271 |
|
272 |
The following methods are provided by this class: |
273 |
|
274 |
=over 4 |
275 |
|
276 |
=item new(FILE|HASHREF|LIST) |
277 |
|
278 |
Creates a new object of the class, and returns a reference to it. The |
279 |
arguments to the constructor are variable in nature, depending on the type: |
280 |
|
281 |
=over 8 |
282 |
|
283 |
=item FILE |
284 |
|
285 |
If there is exactly on argument that is not a reference, it is assumed to be a |
286 |
filename from which the method is to be loaded. This is presumed to be in the |
287 |
B<XPL> format descibed below (see L</"XPL File Structure">). If the file |
288 |
cannot be opened, or if once opened cannot be parsed, an error is raised. |
289 |
|
290 |
=item HASHREF |
291 |
|
292 |
If there is exactly one argument that is a reference, it is assumed to be a |
293 |
hash with the relevant information on the same keys as the object itself |
294 |
uses. This is primarily to support backwards-compatibility to code written |
295 |
when methods were implemented simply as hash references. |
296 |
|
297 |
=item LIST |
298 |
|
299 |
If there is more than one argument in the list, then the list is assumed to be |
300 |
a sort of "ersatz" hash construct, in that one of the keys (C<signature>) is |
301 |
allowed to occur multiple times. Otherwise, each of the following is allowed, |
302 |
but may only occur once: |
303 |
|
304 |
=over 12 |
305 |
|
306 |
=item name |
307 |
|
308 |
The name of the method, as it will be presented to clients |
309 |
|
310 |
=item code |
311 |
|
312 |
A reference to a subroutine, or an anonymous subroutine, that will receive |
313 |
calls for the method |
314 |
|
315 |
=item signature |
316 |
|
317 |
(May appear more than once) Provides one calling-signature for the method, as |
318 |
either a space-separated string of types or a list-reference |
319 |
|
320 |
=item help |
321 |
|
322 |
The help-text for a method, which is generally used as a part of the |
323 |
introspection interface for a server |
324 |
|
325 |
=item version |
326 |
|
327 |
The version number/string for the method |
328 |
|
329 |
=item hidden |
330 |
|
331 |
A boolean (true or false) value indicating whether the method should be hidden |
332 |
from introspection and similar listings |
333 |
|
334 |
=back |
335 |
|
336 |
Note that all of these correspond to the values that can be changed via the |
337 |
accessor methods detailed later. |
338 |
|
339 |
=back |
340 |
|
341 |
If any error occurs during object creation, an error message is returned in |
342 |
lieu of the object reference. |
343 |
|
344 |
=item clone |
345 |
|
346 |
Create a copy of the calling object, and return the new reference. All |
347 |
elements are copied over cleanly, except for the code reference stored on the |
348 |
C<code> hash key. The clone will point to the same code reference as the |
349 |
original. Elements such as C<signature> are copied, so that changes to the |
350 |
clone will not impact the original. |
351 |
|
352 |
=item name |
353 |
|
354 |
Returns the name by which the server is advertising the method. Unlike the |
355 |
next few accessors, this cannot be changed on an object. In order to |
356 |
streamline the managment of methods within the server classes, this must |
357 |
persist. However, the other elements may be used in the creation of a new |
358 |
object, which may then be added to the server, if the name absolutely must |
359 |
change. |
360 |
|
361 |
=item code([NEW]) |
362 |
|
363 |
Returns or sets the code-reference that will receive calls as marshalled by |
364 |
the server. The existing value is lost, so if it must be preserved, then it |
365 |
should be retrieved prior to the new value being set. |
366 |
|
367 |
=item signature([NEW]) |
368 |
|
369 |
Return a list reference containing the signatures, or set it. Each element of |
370 |
the list is a string of space-separated types (the first of which is the |
371 |
return type the method produces in that calling context). If this is being |
372 |
used to set the signature, then an array reference must be passed that |
373 |
contains one or more strings of this nature. Nested list references are not |
374 |
allowed at this level. If the new signatures would cause a conflict (a case in |
375 |
which the same set of input types are specified for different output types), |
376 |
the old set is silently restored. |
377 |
|
378 |
=item help([NEW]) |
379 |
|
380 |
Returns or sets the help-text for the method. As with B<code>, the previous |
381 |
value is lost. |
382 |
|
383 |
=item hidden([NEW]) |
384 |
|
385 |
Returns or sets the hidden status of the method. Setting it loses the previous |
386 |
value. |
387 |
|
388 |
=item version([NEW]) |
389 |
|
390 |
Returns or sets the version string for the method (overwriting as with the |
391 |
other accessors). |
392 |
|
393 |
=item is_valid |
394 |
|
395 |
Returns a true/false value as to whether the object currently has enough |
396 |
content to be a valid method for a server to publish. This entails having at |
397 |
the very least a name, one or more signatures, and a code-reference to route |
398 |
the calls to. A server created from the classes in this software suite will |
399 |
not accept a method that is not valid. |
400 |
|
401 |
=item add_signature(LIST) |
402 |
|
403 |
Add one or more signatures (which may be a list reference or a string) to the |
404 |
internal tables for this method. Duplicate signatures are ignored. If the new |
405 |
signature would cause a conflict (a case in which the same set of input types |
406 |
are specified for different output types), the old set is restored and an |
407 |
error message is returned. |
408 |
|
409 |
=item delete_signature(LIST) |
410 |
|
411 |
Deletes the signature or signatures (list reference or string) from the |
412 |
internal tables. Quietly ignores any signature that does not exist. If the new |
413 |
signature would cause a conflict (a case in which the same set of input types |
414 |
are specified for different output types), the old set is restored and an |
415 |
error message is returned. |
416 |
|
417 |
=item match_signature(SIGNATURE) |
418 |
|
419 |
Check that the passed-in signature is known to the method, and if so returns |
420 |
the type that the method should be returning as a result of the call. Returns |
421 |
a zero (0) otherwise. This differs from other signature operations in that the |
422 |
passed-in signature (which may be a list-reference or a string) B<I<does not |
423 |
include the return type>>. This method is provided so that servers may check a |
424 |
list of arguments against type when marshalling an incoming call. For example, |
425 |
a signature of C<'int int'> would be tested for by calling |
426 |
C<$M-E<gt>match_signature('int')> and expecting the return value to be C<int>. |
427 |
|
428 |
=item call(SERVER, PARAMLIST) |
429 |
|
430 |
Execute the code that this object encapsulates, using the list of parameters |
431 |
passed in PARAMLIST. The SERVER argument should be an object derived from the |
432 |
B<RPC::XML::Server> class. For some types of procedure objects, this becomes |
433 |
the first argument of the parameter list to simulate a method call as if it |
434 |
were on the server object itself. The return value should be a data object |
435 |
(possible a B<RPC::XML::fault>), but may not always be pre-encoded. This |
436 |
method is generally used in the C<dispatch> and C<call> methods of the server |
437 |
class, where the return value is subsequently wrapped within a |
438 |
B<RPC::XML::response> object. |
439 |
|
440 |
=item reload |
441 |
|
442 |
Instruct the object to reload itself from the file it originally was loaded |
443 |
from, assuming that it was loaded from a file to begin with. Returns an error |
444 |
if the method was not originally loaded from a file, or if an error occurs |
445 |
during the reloading operation. |
446 |
|
447 |
=back |
448 |
|
449 |
=head2 Additional Hash Data |
450 |
|
451 |
In addition to the attributes managed by the accessors documented earlier, the |
452 |
following hash keys are also available for use. These are also not strongly |
453 |
protected, and the same care should be taken before altering any of them: |
454 |
|
455 |
=over 4 |
456 |
|
457 |
=item C<file> |
458 |
|
459 |
When the method was loaded from a file, this key contains the path to the file |
460 |
used. |
461 |
|
462 |
=item C<mtime> |
463 |
|
464 |
When the method was loaded from a file, this key contains the |
465 |
modification-time of the file, as a UNIX-style C<time> value. This is used to |
466 |
check for changes to the file the code was originally read from. |
467 |
|
468 |
=item C<called> |
469 |
|
470 |
When the method is being used by one of the server classes provided in this |
471 |
software suite, this key is incremented each time the server object dispatches |
472 |
a request to the method. This can later be checked to provide some indication |
473 |
of how frequently the method is being invoked. |
474 |
|
475 |
=back |
476 |
|
477 |
=head2 XPL File Structure |
478 |
|
479 |
This section focuses on the way in which methods are expressed in these files, |
480 |
referred to here as "XPL files" due to the C<*.xpl> filename extension |
481 |
(which stands for "XML Procedure Layout"). This mini-dialect, based on XML, |
482 |
is meant to provide a simple means of specifying method definitions separate |
483 |
from the code that comprises the application itself. Thus, methods may |
484 |
theoretically be added, removed, debugged or even changed entirely without |
485 |
requiring that the server application itself be rebuilt (or, possibly, without |
486 |
it even being restarted). |
487 |
|
488 |
=head3 The XPL file structure |
489 |
|
490 |
The B<XPL Procedure Layout> dialect is a very simple application of XML to the |
491 |
problem of expressing the method in such a way that it could be useful to |
492 |
other packages than this one, or useful in other contexts than this one. |
493 |
|
494 |
The lightweight DTD for the layout can be summarized as: |
495 |
|
496 |
<!ELEMENT proceduredef (name, version?, hidden?, signature+, |
497 |
help?, code)> |
498 |
<!ELEMENT methoddef (name, version?, hidden?, signature+, |
499 |
help?, code)> |
500 |
<!ELEMENT name (#PCDATA)> |
501 |
<!ELEMENT version (#PCDATA)> |
502 |
<!ELEMENT hidden EMPTY> |
503 |
<!ELEMENT signature (#PCDATA)> |
504 |
<!ELEMENT help (#PCDATA)> |
505 |
<!ELEMENT code (#PCDATA)> |
506 |
<!ATTLIST code language (#PCDATA)> |
507 |
|
508 |
The containing tag is always one of C<E<lt>methoddefE<gt>> or |
509 |
C<E<lt>proceduredefE<gt>>. The tags that specify name, signatures and the code |
510 |
itself must always be present. Some optional information may also be |
511 |
supplied. The "help" text, or what an introspection API would expect to use to |
512 |
document the method, is also marked as optional. Having some degree of |
513 |
documentation for all the methods a server provides is a good rule of thumb, |
514 |
however. |
515 |
|
516 |
The default methods that this package provides are turned into XPL files by |
517 |
the B<make_method> tool (see L<make_method>). The final forms of these may |
518 |
serve as direct examples of what the file should look like. |
519 |
|
520 |
=head3 Information used only for book-keeping |
521 |
|
522 |
Some of the information in the XPL file is only for book-keeping: the version |
523 |
stamp of a method is never involved in the invocation. The server also keeps |
524 |
track of the last-modified time of the file the method is read from, as well |
525 |
as the full directory path to that file. The C<E<lt>hidden /E<gt>> tag is used |
526 |
to identify those methods that should not be exposed to the outside world |
527 |
through any sort of introspection/documentation API. They are still available |
528 |
and callable, but the client must possess the interface information in order |
529 |
to do so. |
530 |
|
531 |
=head3 The information crucial to the method |
532 |
|
533 |
The name, signatures and code must be present for obvious reasons. The |
534 |
C<E<lt>nameE<gt>> tag tells the server what external name this procedure is |
535 |
known by. The C<E<lt>signatureE<gt>> tag, which may appear more than once, |
536 |
provides the definition of the interface to the function in terms of what |
537 |
types and quantity of arguments it will accept, and for a given set of |
538 |
arguments what the type of the returned value is. Lastly is the |
539 |
C<E<lt>codeE<gt>> tag, without which there is no procedure to remotely call. |
540 |
|
541 |
=head3 Why the <code> tag allows multiple languages |
542 |
|
543 |
Note that the C<E<lt>codeE<gt>> tag is the only one with an attribute, in this |
544 |
case "language". This is designed to allow for one XPL file to provide a given |
545 |
method in multiple languages. Why, one might ask, would there be a need for |
546 |
this? |
547 |
|
548 |
It is the hope behind this package that collections of RPC suites may one day |
549 |
be made available as separate entities from this specific software package. |
550 |
Given this hope, it is not unreasonable to suggest that such a suite of code |
551 |
might be implemented in more than one language (each of Perl, Python, Ruby and |
552 |
Tcl, for example). Languages which all support the means by which to take new |
553 |
code and add it to a running process on demand (usually through an "C<eval>" |
554 |
keyword or something similar). If the file F<A.xpl> is provided with |
555 |
implementations in all four of the above languages, the name, help text, |
556 |
signature and even hidden status would likely be identical. So, why not share |
557 |
the non-language-specific elements in the spirit of re-use? |
558 |
|
559 |
=head3 The "make_method" utility |
560 |
|
561 |
The utility script C<make_method> is provided as a part of this software |
562 |
suite. It allows for the automatic creation of XPL files from either |
563 |
command-line information or from template files. It has a wide variety of |
564 |
features and options, and is out of the scope of this particular manual |
565 |
page. The package F<Makefile.PL> features an example of engineering the |
566 |
automatic generation of XPL files and their delivery as a part of the normal |
567 |
Perl module build process. Using this tool is highly recommended over managing |
568 |
XPL files directly. For the full details, see L<make_method>. |
569 |
|
570 |
=head1 DIAGNOSTICS |
571 |
|
572 |
Unless otherwise noted in the individual documentation sections, all methods |
573 |
return the object reference on success, or a (non-reference) text string |
574 |
containing the error message upon failure. |
575 |
|
576 |
=head1 CAVEATS |
577 |
|
578 |
Moving the method management to a separate class adds a good deal of overhead |
579 |
to the general system. The trade-off in reduced complexity and added |
580 |
maintainability should offset this. |
581 |
|
582 |
=head1 LICENSE |
583 |
|
584 |
This module is licensed under the terms of the Artistic License that covers |
585 |
Perl. See <http://language.perl.com/misc/Artistic.html> for the |
586 |
license. |
587 |
|
588 |
=head1 SEE ALSO |
589 |
|
590 |
L<RPC::XML::Server>, L<make_method> |
591 |
|
592 |
=head1 AUTHOR |
593 |
|
594 |
Randy J. Ray <rjray@blackperl.com> |
595 |
|
596 |
=cut |
597 |
|
598 |
__END__ |
599 |
|
600 |
############################################################################### |
601 |
# |
602 |
# Sub Name: clone |
603 |
# |
604 |
# Description: Create a near-exact copy of the invoking object, save that |
605 |
# the listref in the "signature" key is a copy, not a ref |
606 |
# to the same list. |
607 |
# |
608 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
609 |
# $self in ref Object of this class |
610 |
# |
611 |
# Returns: Success: $new_self |
612 |
# Failure: error message |
613 |
# |
614 |
############################################################################### |
615 |
sub clone |
616 |
{ |
617 |
my $self = shift; |
618 |
|
619 |
my $new_self = {}; |
620 |
for (keys %$self) |
621 |
{ |
622 |
next if $_ eq 'signature'; |
623 |
$new_self->{$_} = $self->{$_}; |
624 |
} |
625 |
$new_self->{signature} = []; |
626 |
@{$new_self->{signature}} = @{$self->{signature}}; |
627 |
|
628 |
bless $new_self, ref($self); |
629 |
} |
630 |
|
631 |
############################################################################### |
632 |
# |
633 |
# Sub Name: is_valid |
634 |
# |
635 |
# Description: Boolean test to tell if the calling object has sufficient |
636 |
# data to be used as a server method for RPC::XML::Server or |
637 |
# Apache::RPC::Server. |
638 |
# |
639 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
640 |
# $self in ref Object to test |
641 |
# |
642 |
# Returns: Success: 1, valid/complete |
643 |
# Failure: 0, invalid/incomplete |
644 |
# |
645 |
############################################################################### |
646 |
sub is_valid |
647 |
{ |
648 |
my $self = shift; |
649 |
|
650 |
return ((ref($self->{code}) eq 'CODE') and $self->{name} and |
651 |
(ref($self->{signature}) && scalar(@{$self->{signature}}))); |
652 |
} |
653 |
|
654 |
############################################################################### |
655 |
# |
656 |
# Sub Name: add_signature |
657 |
# delete_signature |
658 |
# |
659 |
# Description: This pair of functions may be used to add and remove |
660 |
# signatures from a method-object. |
661 |
# |
662 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
663 |
# $self in ref Object of this class |
664 |
# @args in list One or more signatures |
665 |
# |
666 |
# Returns: Success: $self |
667 |
# Failure: error string |
668 |
# |
669 |
############################################################################### |
670 |
sub add_signature |
671 |
{ |
672 |
my $self = shift; |
673 |
my @args = @_; |
674 |
|
675 |
my (%sigs, $one_sig, $tmp, $old); |
676 |
|
677 |
# Preserve the original in case adding the new one causes a problem |
678 |
$old = $self->{signature}; |
679 |
%sigs = map { $_ => 1 } @{$self->{signature}}; |
680 |
for $one_sig (@args) |
681 |
{ |
682 |
$tmp = (ref $one_sig) ? join(' ', @$one_sig) : $one_sig; |
683 |
$sigs{$tmp} = 1; |
684 |
} |
685 |
$self->{signature} = [ keys %sigs ]; |
686 |
unless (ref($tmp = $self->make_sig_table)) |
687 |
{ |
688 |
# Because this failed, we have to restore the old table and return |
689 |
# an error |
690 |
$self->{signature} = $old; |
691 |
$self->make_sig_table; |
692 |
return ref($self) . '::add_signature: Error re-hashing table: ' . |
693 |
$tmp; |
694 |
} |
695 |
|
696 |
$self; |
697 |
} |
698 |
|
699 |
sub delete_signature |
700 |
{ |
701 |
my $self = shift; |
702 |
my @args = @_; |
703 |
|
704 |
my (%sigs, $one_sig, $tmp, $old); |
705 |
|
706 |
# Preserve the original in case adding the new one causes a problem |
707 |
$old = $self->{signature}; |
708 |
%sigs = map { $_ => 1 } @{$self->{signature}}; |
709 |
for $one_sig (@args) |
710 |
{ |
711 |
$tmp = (ref $one_sig) ? join(' ', @$one_sig) : $one_sig; |
712 |
delete $sigs{$tmp}; |
713 |
} |
714 |
$self->{signature} = [ keys %sigs ]; |
715 |
unless (ref($tmp = $self->make_sig_table)) |
716 |
{ |
717 |
# Because this failed, we have to restore the old table and return |
718 |
# an error |
719 |
$self->{signature} = $old; |
720 |
$self->make_sig_table; |
721 |
return ref($self) . '::delete_signature: Error re-hashing table: ' . |
722 |
$tmp; |
723 |
} |
724 |
|
725 |
$self; |
726 |
} |
727 |
|
728 |
############################################################################### |
729 |
# |
730 |
# Sub Name: match_signature |
731 |
# |
732 |
# Description: Determine if the passed-in signature string matches any |
733 |
# of this method's known signatures. |
734 |
# |
735 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
736 |
# $self in ref Object of this class |
737 |
# $sig in scalar Signature to check for |
738 |
# |
739 |
# Returns: Success: return type as a string |
740 |
# Failure: 0 |
741 |
# |
742 |
############################################################################### |
743 |
sub match_signature |
744 |
{ |
745 |
my $self = shift; |
746 |
my $sig = shift; |
747 |
|
748 |
$sig = join(' ', @$sig) if ref $sig; |
749 |
|
750 |
return $self->{sig_table}->{$sig} || 0; |
751 |
} |
752 |
|
753 |
############################################################################### |
754 |
# |
755 |
# Sub Name: reload |
756 |
# |
757 |
# Description: Reload the method's code and ancillary data from the file |
758 |
# |
759 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
760 |
# $self in ref Object of this class |
761 |
# |
762 |
# Returns: Success: $self |
763 |
# Failure: error message |
764 |
# |
765 |
############################################################################### |
766 |
sub reload |
767 |
{ |
768 |
my $self = shift; |
769 |
|
770 |
return ref($self) . '::reload: No file associated with method ' . |
771 |
$self->{name} unless $self->{file}; |
772 |
my $tmp = $self->load_XPL_file($self->{file}); |
773 |
|
774 |
# Re-calculate the signature table, in case that changed as well |
775 |
return (ref $tmp) ? $self->make_sig_table : $tmp; |
776 |
} |
777 |
|
778 |
############################################################################### |
779 |
# |
780 |
# Sub Name: load_XPL_file |
781 |
# |
782 |
# Description: Load a XML-encoded method description (generally denoted |
783 |
# by a *.xpl suffix) and return the relevant information. |
784 |
# |
785 |
# Note that this does not fill in $self if $self is a hash |
786 |
# or object reference. This routine is not a substitute for |
787 |
# calling new() (which is why it isn't part of the public |
788 |
# API). |
789 |
# |
790 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
791 |
# $self in ref Object of this class |
792 |
# $file in scalar File to load |
793 |
# |
794 |
# Returns: Success: hashref of values |
795 |
# Failure: error string |
796 |
# |
797 |
############################################################################### |
798 |
sub load_XPL_file |
799 |
{ |
800 |
my $self = shift; |
801 |
my $file = shift; |
802 |
|
803 |
require XML::Parser; |
804 |
|
805 |
my ($me, $pkg, $data, $signature, $code, $codetext, $accum, $P, %attr); |
806 |
local *F; |
807 |
|
808 |
if (ref($self) eq 'SCALAR') |
809 |
{ |
810 |
$me = __PACKAGE__ . '::load_XPL_file'; |
811 |
} |
812 |
else |
813 |
{ |
814 |
$me = (ref $self) || $self || __PACKAGE__; |
815 |
$me .= '::load_XPL_file'; |
816 |
} |
817 |
$data = {}; |
818 |
# So these don't end up undef, since they're optional elements |
819 |
$data->{hidden} = 0; $data->{version} = ''; $data->{help} = ''; |
820 |
$data->{called} = 0; |
821 |
open(F, "< $file"); |
822 |
return "$me: Error opening $file for reading: $!" if ($?); |
823 |
$P = XML::Parser |
824 |
->new(Handlers => {Char => sub { $accum .= $_[1] }, |
825 |
Start => sub { %attr = splice(@_, 2) }, |
826 |
End => |
827 |
sub { |
828 |
my $elem = $_[1]; |
829 |
|
830 |
$accum =~ s/^[\s\n]+//; |
831 |
$accum =~ s/[\s\n]+$//; |
832 |
if ($elem eq 'signature') |
833 |
{ |
834 |
$data->{signature} ||= []; |
835 |
push(@{$data->{signature}}, $accum); |
836 |
} |
837 |
elsif ($elem eq 'code') |
838 |
{ |
839 |
$data->{$elem} = $accum |
840 |
unless ($attr{language} and |
841 |
$attr{language} ne 'perl'); |
842 |
} |
843 |
elsif (substr($elem, -3) eq 'def') |
844 |
{ |
845 |
# Don't blindly store the container tag... |
846 |
# We may need it to tell the caller what |
847 |
# our type is |
848 |
$$self = ucfirst substr($elem, 0, -3) |
849 |
if (ref($self) eq 'SCALAR'); |
850 |
} |
851 |
else |
852 |
{ |
853 |
$data->{$elem} = $accum; |
854 |
} |
855 |
|
856 |
%attr = (); |
857 |
$accum = ''; |
858 |
}}); |
859 |
return "$me: Error creating XML::Parser object" unless $P; |
860 |
# Trap any errors |
861 |
eval { $P->parse(*F) }; |
862 |
return "$me: Error parsing $file: $@" if $@; |
863 |
|
864 |
# Try to normalize $codetext before passing it to eval |
865 |
my $class = __PACKAGE__; # token won't expand in the s/// below |
866 |
($codetext = $data->{code}) =~ |
867 |
s/sub[\s\n]+([\w:]+)?[\s\n]*\{/sub \{ package $class; /; |
868 |
$code = eval $codetext; |
869 |
return "$me: Error creating anonymous sub: $@" if $@; |
870 |
|
871 |
$data->{code} = $code; |
872 |
# Add the file's mtime for when we check for stat-based reloading |
873 |
$data->{mtime} = (stat $file)[9]; |
874 |
$data->{file} = $file; |
875 |
|
876 |
$data; |
877 |
} |
878 |
|
879 |
############################################################################### |
880 |
# |
881 |
# Sub Name: call |
882 |
# |
883 |
# Description: Encapsulates the invocation of the code block that the |
884 |
# object is abstracting. Manages parameters, signature |
885 |
# checking, etc. |
886 |
# |
887 |
# Arguments: NAME IN/OUT TYPE DESCRIPTION |
888 |
# $self in ref Object of this class |
889 |
# $srv in ref An object derived from the |
890 |
# RPC::XML::Server class |
891 |
# @dafa in list The params for the call itself |
892 |
# |
893 |
# Globals: None. |
894 |
# |
895 |
# Environment: None. |
896 |
# |
897 |
# Returns: Success: value |
898 |
# Failure: dies with RPC::XML::Fault object as message |
899 |
# |
900 |
############################################################################### |
901 |
sub call |
902 |
{ |
903 |
my ($self, $srv, @data) = @_; |
904 |
|
905 |
my (@paramtypes, @params, $signature, $resptype, $response, $name); |
906 |
|
907 |
$name = $self->name; |
908 |
# Create the param list. |
909 |
# The type for the response will be derived from the matching signature |
910 |
@paramtypes = map { $_->type } @data; |
911 |
@params = map { $_->value } @data; |
912 |
$signature = join(' ', @paramtypes); |
913 |
$resptype = $self->match_signature($signature); |
914 |
# Since there must be at least one signature with a return value (even |
915 |
# if the param list is empty), this tells us if the signature matches: |
916 |
return RPC::XML::fault->new(301, |
917 |
"method $name nas no matching " . |
918 |
'signature for the argument list') |
919 |
unless ($resptype); |
920 |
|
921 |
# Set these in case the server object is part of the param list |
922 |
local $srv->{signature} = [ $resptype, @paramtypes ]; |
923 |
local $srv->{method_name} = $name; |
924 |
# For RPC::XML::Method (and derivatives), pass the server object |
925 |
if ($self->isa('RPC::XML::Method')) |
926 |
{ |
927 |
unshift(@params, $srv); |
928 |
} |
929 |
|
930 |
# Now take a deep breath and call the method with the arguments |
931 |
eval { $response = $self->{code}->(@params); }; |
932 |
# Report a Perl-level error/failure if it occurs |
933 |
return RPC::XML::fault->new(302, "Method $name returned error: $@") if $@; |
934 |
|
935 |
$self->{called}++; |
936 |
# Create a suitable return value |
937 |
if ((! ref($response)) && UNIVERSAL::can("RPC::XML::$resptype", 'new')) |
938 |
{ |
939 |
my $class = "RPC::XML::$resptype"; |
940 |
$response = $class->new($response); |
941 |
} |
942 |
|
943 |
$response; |
944 |
} |