home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _5c4124862d414da3885e58dd658c4738 < prev    next >
Encoding:
Text File  |  2004-06-01  |  29.1 KB  |  897 lines
  1. # ======================================================================
  2. #
  3. # Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
  4. # SOAP::Lite is free software; you can redistribute it
  5. # and/or modify it under the same terms as Perl itself.
  6. #
  7. # $Id: HTTP.pm,v 1.11 2002/04/15 17:35:11 paulk Exp $
  8. #
  9. # ======================================================================
  10.  
  11. package SOAP::Transport::HTTP;
  12.  
  13. use strict;
  14. use vars qw($VERSION);
  15. $VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/);
  16.  
  17. use SOAP::Lite;
  18.  
  19. # ======================================================================
  20.  
  21. package SOAP::Transport::HTTP::Client;
  22.  
  23. use vars qw(@ISA $COMPRESS);
  24. @ISA = qw(SOAP::Client LWP::UserAgent);
  25.  
  26. $COMPRESS = 'deflate';
  27.  
  28. my(%redirect, %mpost, %nocompress);
  29.  
  30. # hack for HTTP conection that returns Keep-Alive 
  31. # miscommunication (?) between LWP::Protocol and LWP::Protocol::http
  32. # dies after timeout, but seems like we could make it work
  33. sub patch { 
  34.   local $^W; 
  35.   { sub LWP::UserAgent::redirect_ok; *LWP::UserAgent::redirect_ok = sub {1} }
  36.   { package LWP::Protocol; 
  37.     my $collect = \&collect; # store original  
  38.     *collect = sub {          
  39.       if (defined $_[2]->header('Connection') && $_[2]->header('Connection') eq 'Keep-Alive') {
  40.         my $data = $_[3]->(); 
  41.         my $next = SOAP::Utils::bytelength($$data) == $_[2]->header('Content-Length') ? sub { \'' } : $_[3];
  42.         my $done = 0; $_[3] = sub { $done++ ? &$next : $data };
  43.       }
  44.       goto &$collect;
  45.     };
  46.   }
  47.   *patch = sub {};
  48. };
  49.  
  50. sub DESTROY { SOAP::Trace::objects('()') }
  51.  
  52. sub new { require LWP::UserAgent; patch;
  53.   my $self = shift;
  54.  
  55.   unless (ref $self) {
  56.     my $class = ref($self) || $self;
  57.     my(@params, @methods);
  58.     while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
  59.     $self = $class->SUPER::new(@params);
  60.     $self->agent(join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::HTTP->VERSION);
  61.     $self->options({});
  62.     while (@methods) { my($method, $params) = splice(@methods,0,2);
  63.       $self->$method(ref $params eq 'ARRAY' ? @$params : $params) 
  64.     }
  65.     SOAP::Trace::objects('()');
  66.   }
  67.   return $self;
  68. }
  69.  
  70. sub send_receive {
  71.   my($self, %parameters) = @_;
  72.   my($envelope, $endpoint, $action, $encoding) = 
  73.     @parameters{qw(envelope endpoint action encoding)};
  74.  
  75.   $endpoint ||= $self->endpoint;
  76.  
  77.   my $method = 'POST';
  78.   my $resp;
  79.  
  80.   $self->options->{is_compress} ||= exists $self->options->{compress_threshold} &&
  81.                                     eval { require Compress::Zlib };
  82.  
  83.   COMPRESS: {
  84.  
  85.     my $compressed = !exists $nocompress{$endpoint} &&
  86.                      $self->options->{is_compress} && 
  87.                      ($self->options->{compress_threshold} || 0) < SOAP::Utils::bytelength $envelope;
  88.     $envelope = Compress::Zlib::compress($envelope) if $compressed;
  89.  
  90.     while (1) { 
  91.  
  92.       # check cache for redirect
  93.       $endpoint = $redirect{$endpoint} if exists $redirect{$endpoint};
  94.       # check cache for M-POST
  95.       $method = 'M-POST' if exists $mpost{$endpoint};
  96.   
  97.       # what's this all about? 
  98.       # unfortunately combination of LWP and Perl 5.6.1 and later has bug
  99.       # in sending multibyte characters. LWP uses length() to calculate
  100.       # content-length header and starting 5.6.1 length() calculates chars
  101.       # instead of bytes. 'use bytes' in THIS file doesn't work, because
  102.       # it's lexically scoped. Unfortunately, content-length we calculate
  103.       # here doesn't work either, because LWP overwrites it with 
  104.       # content-length it calculates (which is wrong) AND uses length()
  105.       # during syswrite/sysread, so we are in a bad shape anyway.
  106.  
  107.       # what to do? we calculate proper content-length (using 
  108.       # bytelength() function from SOAP::Utils) and then drop utf8 mark
  109.       # from string (doing pack with 'C0A*' modifier) if length and 
  110.       # bytelength are not the same
  111.       my $bytelength = SOAP::Utils::bytelength($envelope);
  112.       $envelope = pack('C0A*', $envelope) 
  113.         if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength;
  114.  
  115.       my $req = HTTP::Request->new($method => $endpoint, HTTP::Headers->new, $envelope);
  116.  
  117.       $req->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, $ENV{'HTTP_proxy_pass'})
  118.         if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'}); # by Murray Nesbitt 
  119.   
  120.       if ($method eq 'M-POST') {
  121.         my $prefix = sprintf '%04d', int(rand(1000));
  122.         $req->header(Man => qq!"$SOAP::Constants::NS_ENV"; ns=$prefix!);
  123.         $req->header("$prefix-SOAPAction" => $action) if defined $action;  
  124.       } else {
  125.         $req->header(SOAPAction => $action) if defined $action;
  126.       }
  127.   
  128.       # allow compress if present and let server know we could handle it
  129.       $req->header(Accept => ['text/xml', 'multipart/*']);
  130.  
  131.       $req->header('Accept-Encoding' => [$COMPRESS]) if $self->options->{is_compress};
  132.       $req->content_encoding($COMPRESS) if $compressed;
  133.  
  134.       $req->content_type(join '; ', 'text/xml', 
  135.         !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ? 'charset=' . lc($encoding) : ());
  136.       $req->content_length($bytelength);
  137.   
  138.       SOAP::Trace::transport($req);
  139.       SOAP::Trace::debug($req->as_string);
  140.       
  141.       $self->SUPER::env_proxy if $ENV{'HTTP_proxy'};
  142.   
  143.       $resp = $self->SUPER::request($req);
  144.   
  145.       SOAP::Trace::transport($resp);
  146.       SOAP::Trace::debug($resp->as_string);
  147.   
  148.       # 100 OK, continue to read?
  149.       if (($resp->code == 510 || $resp->code == 501) && $method ne 'M-POST') { 
  150.         $mpost{$endpoint} = 1;
  151.       } elsif ($resp->code == 415 && $compressed) { # 415 Unsupported Media Type
  152.         $nocompress{$endpoint} = 1;
  153.         $envelope = Compress::Zlib::uncompress($envelope);
  154.         redo COMPRESS; # try again without compression
  155.       } else {
  156.         last;
  157.       }
  158.     }
  159.   }
  160.  
  161.   $redirect{$endpoint} = $resp->request->url
  162.     if $resp->previous && $resp->previous->is_redirect;
  163.  
  164.   $self->code($resp->code);
  165.   $self->message($resp->message);
  166.   $self->is_success($resp->is_success);
  167.   $self->status($resp->status_line);
  168.  
  169.   my $content = ($resp->content_encoding || '') =~ /\b$COMPRESS\b/o && $self->options->{is_compress} 
  170.     ? Compress::Zlib::uncompress($resp->content) 
  171.     : ($resp->content_encoding || '') =~ /\S/ 
  172.       ? die "Unexpected Content-Encoding '@{[$resp->content_encoding]}' returned\n"
  173.       : $resp->content;
  174.   $resp->content_type =~ m!^multipart/! 
  175.     ? join("\n", $resp->headers_as_string, $content) 
  176.     : ($resp->content_type eq 'text/xml' ||          # text/xml
  177.        !$resp->is_success ||                         # failed request
  178.        $SOAP::Constants::DO_NOT_CHECK_CONTENT_TYPE) 
  179.       ? $content
  180.       : die "Unexpected Content-Type '@{[join '; ', $resp->content_type]}' returned\n";
  181. }
  182.  
  183. # ======================================================================
  184.  
  185. package SOAP::Transport::HTTP::Server;
  186.  
  187. use vars qw(@ISA $COMPRESS);
  188. @ISA = qw(SOAP::Server);
  189.  
  190. use URI;
  191.  
  192. $COMPRESS = 'deflate';
  193.  
  194. sub DESTROY { SOAP::Trace::objects('()') }
  195.  
  196. sub new { require LWP::UserAgent;
  197.   my $self = shift;
  198.  
  199.   unless (ref $self) {
  200.     my $class = ref($self) || $self;
  201.     $self = $class->SUPER::new(@_);
  202.     $self->on_action(sub {
  203.       (my $action = shift) =~ s/^("?)(.*)\1$/$2/;
  204.       die "SOAPAction shall match 'uri#method' if present (got '$action', expected '@{[join('#', @_)]}'\n"
  205.         if $action && $action ne join('#', @_) 
  206.                    && $action ne join('/', @_)
  207.                    && (substr($_[0], -1, 1) ne '/' || $action ne join('', @_));
  208.     });
  209.     SOAP::Trace::objects('()');
  210.   }
  211.   return $self;
  212. }
  213.  
  214. sub BEGIN {
  215.   no strict 'refs';
  216.   for my $method (qw(request response)) {
  217.     my $field = '_' . $method;
  218.     *$method = sub {
  219.       my $self = shift->new;
  220.       @_ ? ($self->{$field} = shift, return $self) : return $self->{$field};
  221.     }
  222.   }
  223. }
  224.  
  225. sub handle {
  226.   my $self = shift->new;
  227.  
  228.   if ($self->request->method eq 'POST') {
  229.     $self->action($self->request->header('SOAPAction') || undef);
  230.   } elsif ($self->request->method eq 'M-POST') {
  231.     return $self->response(HTTP::Response->new(510, # NOT EXTENDED
  232.            "Expected Mandatory header with $SOAP::Constants::NS_ENV as unique URI")) 
  233.       if $self->request->header('Man') !~ /^"$SOAP::Constants::NS_ENV";\s*ns\s*=\s*(\d+)/;
  234.     $self->action($self->request->header("$1-SOAPAction") || undef);
  235.   } else {
  236.     return $self->response(HTTP::Response->new(405)) # METHOD NOT ALLOWED
  237.   }
  238.  
  239.   my $compressed = ($self->request->content_encoding || '') =~ /\b$COMPRESS\b/;
  240.   $self->options->{is_compress} ||= $compressed && eval { require Compress::Zlib };
  241.  
  242.   # signal error if content-encoding is 'deflate', but we don't want it OR
  243.   # something else, so we don't understand it
  244.   return $self->response(HTTP::Response->new(415)) # UNSUPPORTED MEDIA TYPE
  245.     if $compressed && !$self->options->{is_compress} ||
  246.        !$compressed && ($self->request->content_encoding || '') =~ /\S/;
  247.  
  248.   my $content_type = $self->request->content_type || '';
  249.   # in some environments (PerlEx?) content_type could be empty, so allow it also
  250.   # anyway it'll blow up inside ::Server::handle if something wrong with message
  251.   # TBD: but what to do with MIME encoded messages in THOSE environments?
  252.   return $self->make_fault($SOAP::Constants::FAULT_CLIENT, "Content-Type must be 'text/xml' instead of '$content_type'")
  253.     if $content_type && 
  254.        $content_type ne 'text/xml' && 
  255.        $content_type !~ m!^multipart/!;
  256.  
  257.   my $content = $compressed ? Compress::Zlib::uncompress($self->request->content) : $self->request->content;
  258.   my $response = $self->SUPER::handle(
  259.     $self->request->content_type =~ m!^multipart/! 
  260.       ? join("\n", $self->request->headers_as_string, $content) : $content
  261.   ) or return;
  262.  
  263.   $self->make_response($SOAP::Constants::HTTP_ON_SUCCESS_CODE, $response);
  264. }
  265.  
  266. sub make_fault {
  267.   my $self = shift;
  268.   $self->make_response($SOAP::Constants::HTTP_ON_FAULT_CODE => $self->SUPER::make_fault(@_));
  269.   return;
  270. }
  271.  
  272. sub make_response {
  273.   my $self = shift;
  274.   my($code, $response) = @_;
  275.  
  276.   my $encoding = $1 if $response =~ /^<\?xml(?: version="1.0"| encoding="([^"]+)")+\?>/;
  277.   $response =~ s!(\?>)!$1<?xml-stylesheet type="text/css"?>! if $self->request->content_type eq 'multipart/form-data';
  278.  
  279.   $self->options->{is_compress} ||= 
  280.     exists $self->options->{compress_threshold} && eval { require Compress::Zlib };
  281.  
  282.   my $compressed = $self->options->{is_compress} && 
  283.                    grep(/\b($COMPRESS|\*)\b/, $self->request->header('Accept-Encoding')) &&
  284.                    ($self->options->{compress_threshold} || 0) < SOAP::Utils::bytelength $response;
  285.   $response = Compress::Zlib::compress($response) if $compressed;
  286.  
  287.   $self->response(HTTP::Response->new( 
  288.      $code => undef, 
  289.      HTTP::Headers->new(
  290.        'SOAPServer' => $self->product_tokens,
  291.        $compressed ? ('Content-Encoding' => $COMPRESS) : (),
  292.        'Content-Type' => join('; ', 'text/xml', 
  293.          !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ? 'charset=' . lc($encoding) : ()),
  294.        'Content-Length' => SOAP::Utils::bytelength $response), 
  295.      $response,
  296.   ));
  297. }
  298.  
  299. sub product_tokens { join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::HTTP->VERSION }
  300.  
  301. # ======================================================================
  302.  
  303. package SOAP::Transport::HTTP::CGI;
  304.  
  305. use vars qw(@ISA);
  306. @ISA = qw(SOAP::Transport::HTTP::Server);
  307.  
  308. sub DESTROY { SOAP::Trace::objects('()') }
  309.  
  310. sub new { 
  311.   my $self = shift;
  312.  
  313.   unless (ref $self) {
  314.     my $class = ref($self) || $self;
  315.     $self = $class->SUPER::new(@_);
  316.     SOAP::Trace::objects('()');
  317.   }
  318.   return $self;
  319. }
  320.  
  321. sub handle {
  322.   my $self = shift->new;
  323.  
  324.   my $length = $ENV{'CONTENT_LENGTH'} || 0;
  325.  
  326.   if (!$length) {     
  327.     $self->response(HTTP::Response->new(411)) # LENGTH REQUIRED
  328.   } elsif (defined $SOAP::Constants::MAX_CONTENT_SIZE && $length > $SOAP::Constants::MAX_CONTENT_SIZE) {
  329.     $self->response(HTTP::Response->new(413)) # REQUEST ENTITY TOO LARGE
  330.   } else {
  331.     my $content; binmode(STDIN); read(STDIN,$content,$length);
  332.     $self->request(HTTP::Request->new( 
  333.       $ENV{'REQUEST_METHOD'} || '' => $ENV{'SCRIPT_NAME'},
  334.       HTTP::Headers->new(map {(/^HTTP_(.+)/i ? $1 : $_) => $ENV{$_}} keys %ENV),
  335.       $content,
  336.     ));
  337.     $self->SUPER::handle;
  338.   }
  339.  
  340.   # imitate nph- cgi for IIS (pointed by Murray Nesbitt)
  341.   my $status = defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/
  342.     ? $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' : 'Status:';
  343.   my $code = $self->response->code;
  344.   binmode(STDOUT); print STDOUT 
  345.     "$status $code ", HTTP::Status::status_message($code), 
  346.     "\015\012", $self->response->headers_as_string, 
  347.     "\015\012", $self->response->content;
  348. }
  349.  
  350. # ======================================================================
  351.  
  352. package SOAP::Transport::HTTP::Daemon;
  353.  
  354. use Carp ();
  355. use vars qw($AUTOLOAD @ISA);
  356. @ISA = qw(SOAP::Transport::HTTP::Server);
  357.  
  358. sub DESTROY { SOAP::Trace::objects('()') }
  359.  
  360. sub new { require HTTP::Daemon; 
  361.   my $self = shift;
  362.  
  363.   unless (ref $self) {
  364.     my $class = ref($self) || $self;
  365.  
  366.     my(@params, @methods);
  367.     while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) }
  368.     $self = $class->SUPER::new;
  369.     $self->{_daemon} = HTTP::Daemon->new(@params) or Carp::croak "Can't create daemon: $!";
  370.     $self->myuri(URI->new($self->url)->canonical->as_string);
  371.     while (@methods) { my($method, $params) = splice(@methods,0,2);
  372.       $self->$method(ref $params eq 'ARRAY' ? @$params : $params) 
  373.     }
  374.     SOAP::Trace::objects('()');
  375.   }
  376.   return $self;
  377. }
  378.  
  379. sub AUTOLOAD {
  380.   my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2);
  381.   return if $method eq 'DESTROY';
  382.  
  383.   no strict 'refs';
  384.   *$AUTOLOAD = sub { shift->{_daemon}->$method(@_) };
  385.   goto &$AUTOLOAD;
  386. }
  387.  
  388. sub handle {
  389.   my $self = shift->new;
  390.   while (my $c = $self->accept) {
  391.     while (my $r = $c->get_request) {
  392.       $self->request($r);
  393.       $self->SUPER::handle;
  394.       $c->send_response($self->response)
  395.     }
  396.     # replaced ->close, thanks to Sean Meisner <Sean.Meisner@VerizonWireless.com>
  397.     # shutdown() doesn't work on AIX. close() is used in this case. Thanks to Jos Clijmans <jos.clijmans@recyfin.be>
  398.     UNIVERSAL::isa($c, 'shutdown') ? $c->shutdown(2) : $c->close(); 
  399.     undef $c;
  400.   }
  401. }
  402.  
  403. # ======================================================================
  404.  
  405. package SOAP::Transport::HTTP::Apache;
  406.  
  407. use vars qw(@ISA);
  408. @ISA = qw(SOAP::Transport::HTTP::Server);
  409.  
  410. sub DESTROY { SOAP::Trace::objects('()') }
  411.  
  412. sub new { require Apache; require Apache::Constants;
  413.   my $self = shift;
  414.  
  415.   unless (ref $self) {
  416.     my $class = ref($self) || $self;
  417.     $self = $class->SUPER::new(@_);
  418.     SOAP::Trace::objects('()');
  419.   }
  420.   return $self;
  421. }
  422.  
  423. sub handler { 
  424.   my $self = shift->new; 
  425.   my $r = shift || Apache->request; 
  426.  
  427.   $self->request(HTTP::Request->new( 
  428.     $r->method => $r->uri,
  429.     HTTP::Headers->new($r->headers_in),
  430.     do { my $buf; $r->read($buf, $r->header_in('Content-length')); $buf; } 
  431.   ));
  432.   $self->SUPER::handle;
  433.  
  434.   # we will specify status manually for Apache, because
  435.   # if we do it as it has to be done, returning SERVER_ERROR,
  436.   # Apache will modify our content_type to 'text/html; ....'
  437.   # which is not what we want.
  438.   # will emulate normal response, but with custom status code 
  439.   # which could also be 500.
  440.   $r->status($self->response->code);
  441.   $self->response->headers->scan(sub { $r->header_out(@_) });
  442.   $r->send_http_header(join '; ', $self->response->content_type);
  443.   $r->print($self->response->content);
  444.   &Apache::Constants::OK;
  445. }
  446.  
  447. sub configure {
  448.   my $self = shift->new;
  449.   my $config = shift->dir_config;
  450.   foreach (%$config) {
  451.     $config->{$_} =~ /=>/
  452.       ? $self->$_({split /\s*(?:=>|,)\s*/, $config->{$_}})
  453.       : ref $self->$_() ? () # hm, nothing can be done here
  454.                         : $self->$_(split /\s+|\s*,\s*/, $config->{$_})
  455.       if $self->can($_);
  456.   }
  457.   $self;
  458. }
  459.  
  460. { sub handle; *handle = \&handler } # just create alias
  461.  
  462. # ======================================================================
  463. #
  464. # Copyright (C) 2001 Single Source oy (marko.asplund@kronodoc.fi)
  465. # a FastCGI transport class for SOAP::Lite.
  466. #
  467. # ======================================================================
  468.  
  469. package SOAP::Transport::HTTP::FCGI;
  470.  
  471. use vars qw(@ISA);
  472. @ISA = qw(SOAP::Transport::HTTP::CGI);
  473.  
  474. sub DESTROY { SOAP::Trace::objects('()') }
  475.  
  476. sub new { require FCGI; Exporter::require_version('FCGI' => 0.47); # requires thread-safe interface
  477.   my $self = shift;
  478.  
  479.   if (!ref($self)) {
  480.     my $class = ref($self) || $self;
  481.     $self = $class->SUPER::new(@_);
  482.     $self->{_fcgirq} = FCGI::Request(\*STDIN, \*STDOUT, \*STDERR);
  483.     SOAP::Trace::objects('()');
  484.   }
  485.   return $self;
  486. }
  487.  
  488. sub handle {
  489.   my $self = shift->new;
  490.  
  491.   my ($r1, $r2);
  492.   my $fcgirq = $self->{_fcgirq};
  493.  
  494.   while (($r1 = $fcgirq->Accept()) >= 0) {
  495.     $r2 = $self->SUPER::handle;
  496.   }
  497.  
  498.   return undef;
  499. }
  500.  
  501. # ======================================================================
  502.  
  503. 1;
  504.  
  505. __END__
  506.  
  507. =head1 NAME
  508.  
  509. SOAP::Transport::HTTP - Server/Client side HTTP support for SOAP::Lite
  510.  
  511. =head1 SYNOPSIS
  512.  
  513. =over 4
  514.  
  515. =item Client
  516.  
  517.   use SOAP::Lite 
  518.     uri => 'http://my.own.site.com/My/Examples',
  519.     proxy => 'http://localhost/', 
  520.   # proxy => 'http://localhost/cgi-bin/soap.cgi', # local CGI server
  521.   # proxy => 'http://localhost/',                 # local daemon server
  522.   # proxy => 'http://localhost/soap',             # local mod_perl server
  523.   # proxy => 'https://localhost/soap',            # local mod_perl SECURE server
  524.   # proxy => 'http://login:password@localhost/cgi-bin/soap.cgi', # local CGI server with authentication
  525.   ;
  526.  
  527.   print getStateName(1);
  528.  
  529. =item CGI server
  530.  
  531.   use SOAP::Transport::HTTP;
  532.  
  533.   SOAP::Transport::HTTP::CGI
  534.     # specify path to My/Examples.pm here
  535.     -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') 
  536.     -> handle
  537.   ;
  538.  
  539. =item Daemon server
  540.  
  541.   use SOAP::Transport::HTTP;
  542.  
  543.   # change LocalPort to 81 if you want to test it with soapmark.pl
  544.  
  545.   my $daemon = SOAP::Transport::HTTP::Daemon
  546.     -> new (LocalAddr => 'localhost', LocalPort => 80)
  547.     # specify list of objects-by-reference here 
  548.     -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat))
  549.     # specify path to My/Examples.pm here
  550.     -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') 
  551.   ;
  552.   print "Contact to SOAP server at ", $daemon->url, "\n";
  553.   $daemon->handle;
  554.  
  555. =item Apache mod_perl server
  556.  
  557. See F<examples/server/Apache.pm> and L</"EXAMPLES"> section for more information.
  558.  
  559. =item mod_soap server (.htaccess, directory-based access)
  560.  
  561.   SetHandler perl-script
  562.   PerlHandler Apache::SOAP
  563.   PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method"
  564.   PerlSetVar options "compress_threshold => 10000"
  565.  
  566. See L<Apache::SOAP> for more information.
  567.  
  568. =back
  569.  
  570. =head1 DESCRIPTION
  571.  
  572. This class encapsulates all HTTP related logic for a SOAP server,
  573. independent of what web server it's attached to. 
  574. If you want to use this class you should follow simple guideline
  575. mentioned above. 
  576.  
  577. Following methods are available:
  578.  
  579. =over 4
  580.  
  581. =item on_action()
  582.  
  583. on_action method lets you specify SOAPAction understanding. It accepts
  584. reference to subroutine that takes three parameters: 
  585.  
  586.   SOAPAction, method_uri and method_name. 
  587.  
  588. C<SOAPAction> is taken from HTTP header and method_uri and method_name are 
  589. extracted from request's body. Default behavior is match C<SOAPAction> if 
  590. present and ignore it otherwise. You can specify you own, for example 
  591. die if C<SOAPAction> doesn't match with following code:
  592.  
  593.   $server->on_action(sub {
  594.     (my $action = shift) =~ s/^("?)(.+)\1$/$2/;
  595.     die "SOAPAction shall match 'uri#method'\n" if $action ne join '#', @_;
  596.   });
  597.  
  598. =item dispatch_to()
  599.  
  600. dispatch_to lets you specify where you want to dispatch your services 
  601. to. More precisely, you can specify C<PATH>, C<MODULE>, C<method> or 
  602. combination C<MODULE::method>. Example:
  603.  
  604.   dispatch_to( 
  605.     'PATH/',          # dynamic: load anything from there, any module, any method
  606.     'MODULE',         # static: any method from this module 
  607.     'MODULE::method', # static: specified method from this module
  608.     'method',         # static: specified method from main:: 
  609.   );
  610.  
  611. If you specify C<PATH/> name of module/classes will be taken from uri as 
  612. path component and converted to Perl module name with substitution 
  613. '::' for '/'. Example:
  614.  
  615.   urn:My/Examples              => My::Examples
  616.   urn://localhost/My/Examples  => My::Examples
  617.   http://localhost/My/Examples => My::Examples
  618.  
  619. For consistency first '/' in the path will be ignored.
  620.  
  621. According to this scheme to deploy new class you should put this
  622. class in one of the specified directories and enjoy its services.
  623. Easy, eh? 
  624.  
  625. =item handle()
  626.  
  627. handle method will handle your request. You should provide parameters
  628. with request() method, call handle() and get it back with response() .
  629.  
  630. =item request()
  631.  
  632. request method gives you access to HTTP::Request object which you
  633. can provide for Server component to handle request.
  634.  
  635. =item response()
  636.  
  637. response method gives you access to HTTP::Response object which 
  638. you can access to get results from Server component after request was
  639. handled.
  640.  
  641. =back
  642.  
  643. =head2 PROXY SETTINGS
  644.  
  645. You can use any proxy setting you use with LWP::UserAgent modules:
  646.  
  647.  SOAP::Lite->proxy('http://endpoint.server/', 
  648.                    proxy => ['http' => 'http://my.proxy.server']);
  649.  
  650. or
  651.  
  652.  $soap->transport->proxy('http' => 'http://my.proxy.server');
  653.  
  654. should specify proxy server for you. And if you use C<HTTP_proxy_user> 
  655. and C<HTTP_proxy_pass> for proxy authorization SOAP::Lite should know 
  656. how to handle it properly. 
  657.  
  658. =head2 COOKIE-BASED AUTHENTICATION
  659.  
  660.   use HTTP::Cookies;
  661.  
  662.   my $cookies = HTTP::Cookies->new(ignore_discard => 1);
  663.     # you may also add 'file' if you want to keep them between sessions
  664.  
  665.   my $soap = SOAP::Lite->proxy('http://localhost/');
  666.   $soap->transport->cookie_jar($cookies);
  667.  
  668. Cookies will be taken from response and provided for request. You may
  669. always add another cookie (or extract what you need after response)
  670. with HTTP::Cookies interface.
  671.  
  672. You may also do it in one line:
  673.  
  674.   $soap->proxy('http://localhost/', 
  675.                cookie_jar => HTTP::Cookies->new(ignore_discard => 1));
  676.  
  677. =head2 SSL CERTIFICATE AUTHENTICATION
  678.  
  679. To get certificate authentication working you need to specify three
  680. environment variables: C<HTTPS_CERT_FILE>, C<HTTPS_KEY_FILE>, and 
  681. (optionally) C<HTTPS_CERT_PASS>:
  682.  
  683.   $ENV{HTTPS_CERT_FILE} = 'client-cert.pem';
  684.   $ENV{HTTPS_KEY_FILE}  = 'client-key.pem';
  685.  
  686. Crypt::SSLeay (which is used for https support) will take care about 
  687. everything else. Other options (like CA peer verification) can be specified
  688. in a similar way. See Crypt::SSLeay documentation for more details.
  689.  
  690. Those who would like to use encrypted keys may check 
  691. http://groups.yahoo.com/group/soaplite/message/729 for details. 
  692.  
  693. =head2 COMPRESSION
  694.  
  695. SOAP::Lite provides you with the option for enabling compression on the 
  696. wire (for HTTP transport only). Both server and client should support 
  697. this capability, but this should be absolutely transparent to your 
  698. application. The Server will respond with an encoded message only if 
  699. the client can accept it (indicated by client sending an Accept-Encoding 
  700. header with 'deflate' or '*' values) and client has fallback logic, 
  701. so if server doesn't understand specified encoding 
  702. (Content-Encoding: deflate) and returns proper error code 
  703. (415 NOT ACCEPTABLE) client will repeat the same request without encoding
  704. and will store this server in a per-session cache, so all other requests 
  705. will go there without encoding.
  706.  
  707. Having options on client and server side that let you specify threshold
  708. for compression you can safely enable this feature on both client and 
  709. server side.
  710.  
  711. =over 4
  712.  
  713. =item Client
  714.  
  715.   print SOAP::Lite
  716.     -> uri('http://localhost/My/Parameters')
  717.     -> proxy('http://localhost/', options => {compress_threshold => 10000})
  718.     -> echo(1 x 10000)
  719.     -> result
  720.   ;
  721.  
  722. =item Server
  723.  
  724.   my $server = SOAP::Transport::HTTP::CGI
  725.     -> dispatch_to('My::Parameters')
  726.     -> options({compress_threshold => 10000})
  727.     -> handle;
  728.  
  729. =back
  730.  
  731. Compression will be enabled on the client side 
  732. B<if> the threshold is specified 
  733. B<and> the size of current message is bigger than the threshold 
  734. B<and> the module Compress::Zlib is available. 
  735.  
  736. The Client will send the header 'Accept-Encoding' with value 'deflate'
  737. B<if> the threshold is specified 
  738. B<and> the module Compress::Zlib is available.
  739.  
  740. Server will accept the compressed message if the module Compress::Zlib 
  741. is available, and will respond with the compressed message 
  742. B<only if> the threshold is specified 
  743. B<and> the size of the current message is bigger than the threshold 
  744. B<and> the module Compress::Zlib is available 
  745. B<and> the header 'Accept-Encoding' is presented in the request.
  746.  
  747. =head1 EXAMPLES
  748.  
  749. Consider following examples of SOAP servers:
  750.  
  751. =over 4
  752.  
  753. =item CGI:
  754.  
  755.   use SOAP::Transport::HTTP;
  756.  
  757.   SOAP::Transport::HTTP::CGI
  758.     -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') 
  759.     -> handle
  760.   ;
  761.  
  762. =item daemon:
  763.  
  764.   use SOAP::Transport::HTTP;
  765.  
  766.   my $daemon = SOAP::Transport::HTTP::Daemon
  767.     -> new (LocalAddr => 'localhost', LocalPort => 80)
  768.     -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') 
  769.   ;
  770.   print "Contact to SOAP server at ", $daemon->url, "\n";
  771.   $daemon->handle;
  772.  
  773. =item mod_perl:
  774.  
  775. httpd.conf:
  776.  
  777.   <Location /soap>
  778.     SetHandler perl-script
  779.     PerlHandler SOAP::Apache
  780.   </Location>
  781.  
  782. Apache.pm:
  783.  
  784.   package SOAP::Apache;
  785.  
  786.   use SOAP::Transport::HTTP;
  787.  
  788.   my $server = SOAP::Transport::HTTP::Apache
  789.     -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method'); 
  790.  
  791.   sub handler { $server->handler(@_) }
  792.  
  793.   1;
  794.  
  795. =item Apache::Registry:
  796.  
  797. httpd.conf:
  798.  
  799.   Alias /mod_perl/ "/Apache/mod_perl/"
  800.   <Location /mod_perl>
  801.     SetHandler perl-script
  802.     PerlHandler Apache::Registry
  803.     PerlSendHeader On
  804.     Options +ExecCGI
  805.   </Location>
  806.  
  807. soap.mod_cgi (put it in /Apache/mod_perl/ directory mentioned above)
  808.  
  809.   use SOAP::Transport::HTTP;
  810.  
  811.   SOAP::Transport::HTTP::CGI
  812.     -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') 
  813.     -> handle
  814.   ;
  815.  
  816. =back
  817.  
  818. WARNING: dynamic deployment with Apache::Registry will fail, because 
  819. module will be loaded dynamically only for the first time. After that 
  820. it is already in the memory, that will bypass dynamic deployment and 
  821. produces error about denied access. Specify both PATH/ and MODULE name 
  822. in dispatch_to() and module will be loaded dynamically and then will work 
  823. as under static deployment. See examples/server/soap.mod_cgi for example.
  824.  
  825. =head1 TROUBLESHOOTING
  826.  
  827. =over 4
  828.  
  829. =item Dynamic libraries are not found
  830.  
  831. If you see in webserver's log file something like this: 
  832.  
  833. Can't load '/usr/local/lib/perl5/site_perl/.../XML/Parser/Expat/Expat.so' 
  834. for module XML::Parser::Expat: dynamic linker: /usr/local/bin/perl:
  835.  libexpat.so.0 is NEEDED, but object does not exist at
  836. /usr/local/lib/perl5/.../DynaLoader.pm line 200.
  837.  
  838. and you are using Apache web server, try to put into your httpd.conf
  839.  
  840.  <IfModule mod_env.c>
  841.      PassEnv LD_LIBRARY_PATH
  842.  </IfModule>
  843.  
  844. =item Apache is crashing with segfaults (it may looks like "500 unexpected EOF before status line seen" on client side)
  845.  
  846. If using SOAP::Lite (or XML::Parser::Expat) in combination with mod_perl
  847. causes random segmentation faults in httpd processes try to configure
  848. Apache with:
  849.  
  850.  RULE_EXPAT=no
  851.  
  852. -- OR (for Apache 1.3.20 and later) --
  853.  
  854.  ./configure --disable-rule=EXPAT
  855.  
  856. See http://archive.covalent.net/modperl/2000/04/0185.xml for more 
  857. details and lot of thanks to Robert Barta <rho@bigpond.net.au> for
  858. explaining this weird behavior.
  859.  
  860. If it doesn't help, you may also try -Uusemymalloc
  861. (or something like that) to get perl to use the system's own malloc.
  862. Thanks to Tim Bunce <Tim.Bunce@pobox.com>.
  863.  
  864. =item CGI scripts are not running under Microsoft Internet Information Server (IIS)
  865.  
  866. CGI scripts may not work under IIS unless scripts are .pl, not .cgi.
  867.  
  868. =back
  869.  
  870. =head1 DEPENDENCIES
  871.  
  872.  Crypt::SSLeay             for HTTPS/SSL
  873.  SOAP::Lite, URI           for SOAP::Transport::HTTP::Server
  874.  LWP::UserAgent, URI       for SOAP::Transport::HTTP::Client
  875.  HTTP::Daemon              for SOAP::Transport::HTTP::Daemon
  876.  Apache, Apache::Constants for SOAP::Transport::HTTP::Apache
  877.  
  878. =head1 SEE ALSO
  879.  
  880.  See ::CGI, ::Daemon and ::Apache for implementation details.
  881.  See examples/server/soap.cgi as SOAP::Transport::HTTP::CGI example.
  882.  See examples/server/soap.daemon as SOAP::Transport::HTTP::Daemon example.
  883.  See examples/My/Apache.pm as SOAP::Transport::HTTP::Apache example.
  884.  
  885. =head1 COPYRIGHT
  886.  
  887. Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
  888.  
  889. This library is free software; you can redistribute it and/or modify
  890. it under the same terms as Perl itself.
  891.  
  892. =head1 AUTHOR
  893.  
  894. Paul Kulchenko (paulclinger@yahoo.com)
  895.  
  896. =cut
  897.