home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _260ba1e8323949da899ec901030efbc3 < prev    next >
Encoding:
Text File  |  2000-03-15  |  8.9 KB  |  243 lines
  1. package SOAP::Transport::HTTP::Server;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5. $VERSION = '0.23';
  6.  
  7. use SOAP::Defs;
  8. use SOAP::Parser;
  9. use SOAP::EnvelopeMaker;
  10. use Carp;
  11. use Cwd;
  12.  
  13. sub new {
  14.     my ($class) = @_;
  15.     bless {}, $class;
  16. }
  17.  
  18. sub handle_request {
  19.     my ($self, $http_method, 
  20.                $request_class,
  21.                $request_header_reader, 
  22.                $request_content_reader, 
  23.                $response_header_writer,
  24.                $response_content_writer,
  25.                $optional_dispatcher) = @_;
  26.  
  27.     my $request_content_type   = $request_header_reader->('Content-Type', 1);
  28.     my $request_content_length = $request_header_reader->('Content-Length', 1);
  29.     my $soap_method_name       = $request_header_reader->('SOAPMethodName', 0);
  30.     my $debug_request          = $request_header_reader->('DebugRequest', 0);
  31.  
  32.     my $request_content;
  33.     $request_content_reader->($request_content, $request_content_length);
  34.  
  35.     $response_header_writer->('Content-type', 'text/xml');
  36.  
  37.     if ($debug_request) {
  38.     my $cwd = cwd();
  39.     $response_content_writer->("<cwd>$cwd</cwd>");
  40.     $response_content_writer->("<HttpMethod>$http_method</HttpMethod>");
  41.     $response_content_writer->("<SoapMethodName>$soap_method_name</SoapMethodName>");
  42.     $response_content_writer->("<RequestContentLength>$request_content_length</RequestContentLength>");
  43.     $response_content_writer->("<ContentType>$request_content_type</ContentType>");
  44.     $response_content_writer->("<EchoedRequest>$request_content</EchoedRequest>");
  45.     return;
  46.     }
  47.     unless ('text/xml' eq $request_content_type) { 
  48.     return $self->_output_soap_fault(undef, $soap_status_invalid_request,
  49.                      'Bad Request', $soap_runcode_no, 
  50.                      'Content-Type must be text/xml.',
  51.                      $response_header_writer, $response_content_writer);
  52.     }
  53.     unless ($soap_method_name) {
  54.     return $self->_output_soap_fault(undef, $soap_status_invalid_request,
  55.                      'Bad Request', $soap_runcode_no, 
  56.                      'SOAPMethodName is required.',
  57.                      $response_header_writer, $response_content_writer);
  58.     }
  59.  
  60.     unless ($soap_method_name =~ /(^\S+)#(\S+$)/) {
  61.         return $self->_output_soap_fault(undef, $soap_status_invalid_request,
  62.                      'Bad Request', $soap_runcode_no, 
  63.                      'Unrecognized SOAPMethodName header',
  64.                      $response_header_writer, $response_content_writer);
  65.     }
  66.     my ($method_uri, $method_name) = ($1, $2);
  67.         
  68.     #
  69.     # TBD: deal with content-length and cr/lf issues...
  70.     # TBD: add M-POST support
  71.     #
  72.  
  73.     #
  74.     # Unmarshal the request object
  75.     #
  76.     # TBD: eventually I want to experiment with XML::Parser::ExpatNB to see
  77.     #      if I can avoid buffering the entire request in a string.
  78.     #      For now, I want to ship *something* that works correctly though.
  79.     #      As another option, I wonder if there's a way I can call parsefile
  80.     #      passing in a filehandle - if mod_perl would give me a file handle
  81.     #      then there'd be no double-buffering at all!
  82.     #
  83.     my $headers;
  84.     my $body;
  85.     eval {
  86.         my $soap_parser = SOAP::Parser->new();
  87.         $soap_parser->parsestring($request_content);
  88.         $headers = $soap_parser->get_headers();
  89.         $body    = $soap_parser->get_body();
  90.     };
  91.     if ($@) {
  92.         return $self->_output_soap_fault(undef, $soap_status_application_faulted,
  93.                      'Application Faulted', $soap_runcode_no,
  94.                      "Failed while unmarshaling the request: $@",
  95.                      $response_header_writer, $response_content_writer);
  96.     }
  97.  
  98.     my $response_content = '';
  99.     if ($optional_dispatcher) {
  100.         #
  101.         # call the custom dispatch routine
  102.         #
  103.         eval {
  104.             my $em = SOAP::EnvelopeMaker->new(sub { $response_content .= shift });
  105.             $optional_dispatcher->($request_class, $headers, $body, $em);
  106.         };
  107.         if ($@) {
  108.             return $self->_output_soap_fault(undef, $soap_status_application_faulted,
  109.                                              'Application Faulted', $soap_runcode_maybe,
  110.                                              "An exception fired while processing the request: $@",
  111.                                              $response_header_writer, $response_content_writer);
  112.         }
  113.     }
  114.     else {
  115.         #
  116.         # Load the requested class
  117.         #
  118.         eval "require $request_class";
  119.         if ($@) {
  120.             return $self->_output_soap_fault(undef, $soap_status_application_faulted,
  121.                                              'Application Faulted', $soap_runcode_no,
  122.                                              "Failed to load Perl module $request_class: $@",
  123.                                              $response_header_writer, $response_content_writer);
  124.         }
  125.         #
  126.         # dispatch the request and marshal the response
  127.         #
  128.         eval {
  129.             my $server_object = $request_class->new();
  130.             my $em = SOAP::EnvelopeMaker->new(sub { $response_content .= shift });
  131.             $server_object->handle_request($headers, $body, $em);
  132.         };
  133.         if ($@) {
  134.             return $self->_output_soap_fault(undef, $soap_status_application_faulted,
  135.                                              'Application Faulted', $soap_runcode_maybe,
  136.                                              "An exception fired while processing the request: $@",
  137.                                              $response_header_writer, $response_content_writer);
  138.         }
  139.     }
  140.     #
  141.     # send the response
  142.     #
  143.     my $response_content_length = length($response_content);
  144.  
  145.     $response_header_writer->("Content-Length: $response_content_length");
  146.     $response_content_writer->($response_content);
  147. }
  148.  
  149. sub _output_soap_fault {
  150.     my ($self, $faultcode_uri, $faultcode, $faultstring, $runcode, $result_desc,
  151.         $response_header_writer, $response_content_writer) = @_;
  152.  
  153.     my $faultcode_attr = $faultcode_uri ? qq[ xmlns="$faultcode_uri"] : '';
  154.  
  155.     my $response_content = qq[<Envelope xmlns="$soap_namespace"><Body><Fault><faultcode$faultcode_attr>$faultcode</faultcode><faultstring>$faultstring</faultstring><runcode>$runcode</runcode><detail>$result_desc</detail></Fault></Body></Envelope>];
  156.  
  157.     my $response_content_length = length $response_content;
  158.  
  159.     $response_header_writer->("Content-Length: $response_content_length");
  160.     $response_content_writer->($response_content);
  161. }
  162.  
  163. 1;
  164.  
  165. __END__
  166.  
  167. =head1 NAME
  168.  
  169. SOAP::Transport::HTTP::Server - Server side HTTP support for SOAP/Perl
  170.  
  171. =head1 SYNOPSIS
  172.  
  173.     use SOAP::Transport::HTTP::Server;
  174.  
  175. =head1 DESCRIPTION
  176.  
  177. This class provides all the HTTP related smarts for a SOAP server,
  178. independent of what web browser it's attached to. It exposes
  179. a single function (that you'll never call, unless you're adapting
  180. SOAP/Perl to a new web server environment) that provides a set
  181. of function pointers for doing various things, like getting
  182. information about the request and sending response headers
  183. and content.
  184.  
  185. What *is* important to know about this class is what it expects
  186. of you if you want to handle SOAP requests. You must implement
  187. your class such that it can be created via new() with no
  188. arguments, and you must implement a single function:
  189.  
  190. =head2 handle_request(HeaderArray, Body, EnvelopeMaker)
  191.  
  192. The first two arguments are the input, an array of header objects
  193. (which may be empty if no headers were sent), a single Body object,
  194. and a third object to allow you to send a response.
  195.  
  196. See EnvelopeMaker to learn how to send a response (this is the
  197. same class used by a client to send the request, so if you know
  198. how to do that, you're cooking with gas).
  199.  
  200. HeaderArray and Body are today simply hash references, but in the
  201. future, they may be blessed object references.
  202.  
  203. If you want to customize this call-dispatching mechanism, you
  204. may pass a code reference for the OptionalDispatcher argument.
  205.  
  206. The OptionalDispatcher argument allows you to override the default
  207. dispatching behavior with your own code. This should reference a
  208. subroutine with the following signature:
  209.  
  210. =head2 custom_dispatcher(RequestedClass, HeaderArray, Body, EnvelopeMaker)
  211.  
  212. sub my_dispatcher {
  213.     my ($requested_class, $headers, $body, $em) = @_;
  214.  
  215.     # here's a simple example that converts the request
  216.     # into a method call (it doesn't deal with headers though)
  217.     my $method_name = $body->{soap_typename};
  218.     require $requested_class . '.pm';
  219.     my $retval = $requested_class->$method_name(%$body);
  220.     $em->set_body($body->{soap_typeuri}, $method_name . 'Response',
  221.           0, {return => $retval});
  222. }
  223.  
  224. The above example handles each request by invoking a class-level method
  225. on the requested class.
  226.  
  227. =head1 DEPENDENCIES
  228.  
  229. SOAP::Defs
  230. SOAP::Parser
  231. SOAP::EnvelopeMaker
  232.  
  233. =head1 AUTHOR
  234.  
  235. Keith Brown
  236.  
  237. =head1 SEE ALSO
  238.  
  239. SOAP::Transport::HTTP::EnvelopeMaker
  240. SOAP::Transport::HTTP::Apache
  241.  
  242. =cut
  243.