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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 279 - (download) (as text) (annotate)
Fri May 17 21:44:04 2002 UTC (17 years, 1 month ago) by gage
File size: 54635 byte(s)
Experimental xmlrpc WeBWorK webservices

    1 ###############################################################################
    2 #
    3 # This file copyright (c) 2001 by Randy J. Ray <rjray@blackperl.com>,
    4 # all rights reserved
    5 #
    6 # Copying and distribution are permitted under the terms of the Artistic
    7 # License as distributed with Perl versions 5.002 and later. See
    8 # http://language.perl.com/misc/Artistic.html
    9 #
   10 ###############################################################################
   11 #
   12 #   $Id$
   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