Tadashi Okoshi
slash****@users*****
2005年 10月 25日 (火) 04:20:51 JST
Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/FTP.pm Tue Oct 25 04:20:51 2005 @@ -1,110 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: FTP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::FTP; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use Net::FTP; -use IO::File; -use URI; - -# ====================================================================== - -package SOAP::Transport::FTP::Client; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Client); - -sub new { - my $self = shift; - my $class = ref($self) || $self; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = bless {@params} => $class; - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - } - return $self; -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action) = - @parameters{qw(envelope endpoint action)}; - - $endpoint ||= $self->endpoint; # ftp://login:passw****@ftp*****/dir/file - - my $uri = URI->new($endpoint); - my($server, $auth) = reverse split /@/, $uri->authority; - my $dir = substr($uri->path, 1, rindex($uri->path, '/')); - my $file = substr($uri->path, rindex($uri->path, '/')+1); - - eval { - my $ftp = Net::FTP->new($server, %$self) or die "Can't connect to $server: $@\n"; - $ftp->login(split /:/, $auth) or die "Couldn't login\n"; - $dir and ($ftp->cwd($dir) or - $ftp->mkdir($dir, 'recurse') and $ftp->cwd($dir) or die "Couldn't change directory to '$dir'\n"); - - my $FH = IO::File->new_tmpfile; print $FH $envelope; $FH->flush; $FH->seek(0,0); - $ftp->put($FH => $file) or die "Couldn't put file '$file'\n"; - $ftp->quit; - }; - - (my $code = $@) =~ s/\n$//; - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::FTP - Client side FTP support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Lite - uri => 'http://my.own.site.com/My/Examples', - proxy => 'ftp://login:passw****@ftp*****/relative/path/to/file.xml', # ftp server - # proxy => 'ftp://login:passw****@ftp*****//absolute/path/to/file.xml', # ftp server - ; - - print getStateName(1); - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/HTTP.pm Tue Oct 25 04:20:51 2005 @@ -1,888 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: HTTP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::HTTP; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use SOAP::Lite; - -# ====================================================================== - -package SOAP::Transport::HTTP::Client; - -use vars qw(@ISA $COMPRESS); - ＠ ISA = qw(SOAP::Client LWP::UserAgent); - -$COMPRESS = 'deflate'; - -my(%redirect, %mpost, %nocompress); - -# hack for HTTP conection that returns Keep-Alive -# miscommunication (?) between LWP::Protocol and LWP::Protocol::http -# dies after timeout, but seems like we could make it work -sub patch { - local $^W; - { sub LWP::UserAgent::redirect_ok; *LWP::UserAgent::redirect_ok = sub {1} } - { package LWP::Protocol; - my $collect = \&collect; # store original - *collect = sub { - if (defined $_[2]->header('Connection') && $_[2]->header('Connection') eq 'Keep-Alive') { - my $data = $_[3]->(); - my $next = SOAP::Utils::bytelength($$data) == $_[2]->header('Content-Length') ? sub { \'' } : $_[3]; - my $done = 0; $_[3] = sub { $done++ ? &$next : $data }; - } - goto &$collect; - }; - } - *patch = sub {}; -}; - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require LWP::UserAgent; patch; - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new(@params); - $self->agent(join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::HTTP->VERSION); - $self->options({}); - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action, $encoding) = - @parameters{qw(envelope endpoint action encoding)}; - - $endpoint ||= $self->endpoint; - - my $method = 'POST'; - my $resp; - - $self->options->{is_compress} ||= exists $self->options->{compress_threshold} && - eval { require Compress::Zlib }; - - COMPRESS: { - - my $compressed = !exists $nocompress{$endpoint} && - $self->options->{is_compress} && - ($self->options->{compress_threshold} || 0) < SOAP::Utils::bytelength $envelope; - $envelope = Compress::Zlib::compress($envelope) if $compressed; - - while (1) { - - # check cache for redirect - $endpoint = $redirect{$endpoint} if exists $redirect{$endpoint}; - # check cache for M-POST - $method = 'M-POST' if exists $mpost{$endpoint}; - - # what's this all about? - # unfortunately combination of LWP and Perl 5.6.1 and later has bug - # in sending multibyte characters. LWP uses length() to calculate - # content-length header and starting 5.6.1 length() calculates chars - # instead of bytes. 'use bytes' in THIS file doesn't work, because - # it's lexically scoped. Unfortunately, content-length we calculate - # here doesn't work either, because LWP overwrites it with - # content-length it calculates (which is wrong) AND uses length() - # during syswrite/sysread, so we are in a bad shape anyway. - - # what to do? we calculate proper content-length (using - # bytelength() function from SOAP::Utils) and then drop utf8 mark - # from string (doing pack with 'C0A*' modifier) if length and - # bytelength are not the same - my $bytelength = SOAP::Utils::bytelength($envelope); - $envelope = pack('C0A*', $envelope) - if !$SOAP::Constants::DO_NOT_USE_LWP_LENGTH_HACK && length($envelope) != $bytelength; - - my $req = HTTP::Request->new($method => $endpoint, HTTP::Headers->new, $envelope); - - $req->proxy_authorization_basic($ENV{'HTTP_proxy_user'}, $ENV{'HTTP_proxy_pass'}) - if ($ENV{'HTTP_proxy_user'} && $ENV{'HTTP_proxy_pass'}); # by Murray Nesbitt - - if ($method eq 'M-POST') { - my $prefix = sprintf '%04d', int(rand(1000)); - $req->header(Man => qq!"$SOAP::Constants::NS_ENV"; ns=$prefix!); - $req->header("$prefix-SOAPAction" => $action) if defined $action; - } else { - $req->header(SOAPAction => $action) if defined $action; - } - - # allow compress if present and let server know we could handle it - $req->header(Accept => ['text/xml', 'multipart/*']); - - $req->header('Accept-Encoding' => [$COMPRESS]) if $self->options->{is_compress}; - $req->content_encoding($COMPRESS) if $compressed; - - $req->content_type(join '; ', 'text/xml', - !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ? 'charset=' . lc($encoding) : ()); - $req->content_length($bytelength); - - SOAP::Trace::transport($req); - SOAP::Trace::debug($req->as_string); - - $self->SUPER::env_proxy if $ENV{'HTTP_proxy'}; - - $resp = $self->SUPER::request($req); - - SOAP::Trace::transport($resp); - SOAP::Trace::debug($resp->as_string); - - # 100 OK, continue to read? - if (($resp->code == 510 || $resp->code == 501) && $method ne 'M-POST') { - $mpost{$endpoint} = 1; - } elsif ($resp->code == 415 && $compressed) { # 415 Unsupported Media Type - $nocompress{$endpoint} = 1; - $envelope = Compress::Zlib::uncompress($envelope); - redo COMPRESS; # try again without compression - } else { - last; - } - } - } - - $redirect{$endpoint} = $resp->request->url - if $resp->previous && $resp->previous->is_redirect; - - $self->code($resp->code); - $self->message($resp->message); - $self->is_success($resp->is_success); - $self->status($resp->status_line); - - my $content = ($resp->content_encoding || '') =~ /\b$COMPRESS\b/o && $self->options->{is_compress} - ? Compress::Zlib::uncompress($resp->content) - : ($resp->content_encoding || '') =~ /\S/ - ? die "Unexpected Content-Encoding '@{[$resp->content_encoding]}' returned\n" - : $resp->content; - $resp->content_type =~ m!^multipart/! - ? join("\n", $resp->headers_as_string, $content) - : ($resp->content_type eq 'text/xml' || # text/xml - !$resp->is_success || # failed request - $SOAP::Constants::DO_NOT_CHECK_CONTENT_TYPE) - ? $content - : die "Unexpected Content-Type '@{[join '; ', $resp->content_type]}' returned\n"; -} - -# ====================================================================== - -package SOAP::Transport::HTTP::Server; - -use vars qw(@ISA $COMPRESS); - ＠ ISA = qw(SOAP::Server); - -use URI; - -$COMPRESS = 'deflate'; - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require LWP::UserAgent; - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - $self->on_action(sub { - (my $action = shift) =~ s/^("?)(.*)\1$/$2/; - die "SOAPAction shall match 'uri#method' if present (got '$action', expected '@{[join('#', @_)]}'\n" - if $action && $action ne join('#', @_) - && $action ne join('/', @_) - && (substr($_[0], -1, 1) ne '/' || $action ne join('', @_)); - }); - SOAP::Trace::objects('()'); - } - return $self; -} - -sub BEGIN { - no strict 'refs'; - for my $method (qw(request response)) { - my $field = '_' . $method; - *$method = sub { - my $self = shift->new; - @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; - } - } -} - -sub handle { - my $self = shift->new; - - if ($self->request->method eq 'POST') { - $self->action($self->request->header('SOAPAction')); - } elsif ($self->request->method eq 'M-POST') { - return $self->response(HTTP::Response->new(510, # NOT EXTENDED - "Expected Mandatory header with $SOAP::Constants::NS_ENV as unique URI")) - if $self->request->header('Man') !~ /^"$SOAP::Constants::NS_ENV";\s*ns\s*=\s*(\d+)/; - $self->action($self->request->header("$1-SOAPAction")); - } else { - return $self->response(HTTP::Response->new(405)) # METHOD NOT ALLOWED - } - - my $compressed = ($self->request->content_encoding || '') =~ /\b$COMPRESS\b/; - $self->options->{is_compress} ||= $compressed && eval { require Compress::Zlib }; - - # signal error if content-encoding is 'deflate', but we don't want it OR - # something else, so we don't understand it - return $self->response(HTTP::Response->new(415)) # UNSUPPORTED MEDIA TYPE - if $compressed && !$self->options->{is_compress} || - !$compressed && ($self->request->content_encoding || '') =~ /\S/; - - my $content_type = $self->request->content_type || ''; - # in some environments (PerlEx?) content_type could be empty, so allow it also - # anyway it'll blow up inside ::Server::handle if something wrong with message - # TBD: but what to do with MIME encoded messages in THOSE environments? - return $self->make_fault($SOAP::Constants::FAULT_CLIENT, "Content-Type must be 'text/xml' instead of '$content_type'") - if $content_type && - $content_type ne 'text/xml' && - $content_type !~ m!^multipart/!; - - my $content = $compressed ? Compress::Zlib::uncompress($self->request->content) : $self->request->content; - my $response = $self->SUPER::handle( - $self->request->content_type =~ m!^multipart/! - ? join("\n", $self->request->headers_as_string, $content) : $content - ) or return; - - $self->make_response($SOAP::Constants::HTTP_ON_SUCCESS_CODE, $response); -} - -sub make_fault { - my $self = shift; - $self->make_response($SOAP::Constants::HTTP_ON_FAULT_CODE => $self->SUPER::make_fault(@_)); - return; -} - -sub make_response { - my $self = shift; - my($code, $response) = @_; - - my $encoding = $1 if $response =~ /^<\?xml(?: version="1.0"| encoding="([^"]+)")+\?>/; - $response =~ s!(\?>)!$1<?xml-stylesheet type="text/css"?>! if $self->request->content_type eq 'multipart/form-data'; - - $self->options->{is_compress} ||= - exists $self->options->{compress_threshold} && eval { require Compress::Zlib }; - - my $compressed = $self->options->{is_compress} && - grep(/\b($COMPRESS|\*)\b/, $self->request->header('Accept-Encoding')) && - ($self->options->{compress_threshold} || 0) < SOAP::Utils::bytelength $response; - $response = Compress::Zlib::compress($response) if $compressed; - - $self->response(HTTP::Response->new( - $code => undef, - HTTP::Headers->new( - 'SOAPServer' => $self->product_tokens, - $compressed ? ('Content-Encoding' => $COMPRESS) : (), - 'Content-Type' => join('; ', 'text/xml', - !$SOAP::Constants::DO_NOT_USE_CHARSET && $encoding ? 'charset=' . lc($encoding) : ()), - 'Content-Length' => SOAP::Utils::bytelength $response), - $response, - )); -} - -sub product_tokens { join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::HTTP->VERSION } - -# ====================================================================== - -package SOAP::Transport::HTTP::CGI; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Transport::HTTP::Server); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - SOAP::Trace::objects('()'); - } - return $self; -} - -sub handle { - my $self = shift->new; - - my $content; binmode(STDIN); read(STDIN,$content,$ENV{'CONTENT_LENGTH'} || 0); - $self->request(HTTP::Request->new( - $ENV{'REQUEST_METHOD'} || '' => $ENV{'SCRIPT_NAME'}, - HTTP::Headers->new(map {(/^HTTP_(.+)/i ? $1 : $_) => $ENV{$_}} keys %ENV), - $content, - )); - $self->SUPER::handle; - - # imitate nph- cgi for IIS (pointed by Murray Nesbitt) - my $status = defined($ENV{'SERVER_SOFTWARE'}) && $ENV{'SERVER_SOFTWARE'}=~/IIS/ - ? $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' : 'Status:'; - my $code = $self->response->code; - binmode(STDOUT); print STDOUT - "$status $code ", HTTP::Status::status_message($code), - "\015\012", $self->response->headers_as_string, - "\015\012", $self->response->content; -} - -# ====================================================================== - -package SOAP::Transport::HTTP::Daemon; - -use Carp (); -use vars qw($AUTOLOAD @ISA); - ＠ ISA = qw(SOAP::Transport::HTTP::Server); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require HTTP::Daemon; - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new; - $self->{_daemon} = HTTP::Daemon->new(@params) or Carp::croak "Can't create daemon: $!"; - $self->myuri(URI->new($self->url)->canonical->as_string); - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { shift->{_daemon}->$method(@_) }; - goto &$AUTOLOAD; -} - -sub handle { - my $self = shift->new; - while (my $c = $self->accept) { - while (my $r = $c->get_request) { - $self->request($r); - $self->SUPER::handle; - $c->send_response($self->response) - } - $c->shutdown(2); # replaced ->close, thanks to Sean Meisner <Sean.****@Veriz*****> - undef $c; - } -} - -# ====================================================================== - -package SOAP::Transport::HTTP::Apache; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Transport::HTTP::Server); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require Apache; require Apache::Constants; - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - SOAP::Trace::objects('()'); - } - return $self; -} - -sub handler { - my $self = shift->new; - my $r = shift || Apache->request; - - $self->request(HTTP::Request->new( - $r->method => $r->uri, - HTTP::Headers->new($r->headers_in), - do { my $buf; $r->read($buf, $r->header_in('Content-length')); $buf; } - )); - $self->SUPER::handle; - - # we will specify status manually for Apache, because - # if we do it as it has to be done, returning SERVER_ERROR, - # Apache will modify our content_type to 'text/html; ....' - # which is not what we want. - # will emulate normal response, but with custom status code - # which could also be 500. - $r->status($self->response->code); - $self->response->headers->scan(sub { $r->header_out(@_) }); - $r->send_http_header(join '; ', $self->response->content_type); - $r->print($self->response->content); - &Apache::Constants::OK; -} - -sub configure { - my $self = shift->new; - my $config = shift->dir_config; - foreach (%$config) { - $config->{$_} =~ /=>/ - ? $self->$_({split /\s*(?:=>|,)\s*/, $config->{$_}}) - : ref $self->$_() ? () # hm, nothing can be done here - : $self->$_(split /\s+|\s*,\s*/, $config->{$_}) - if $self->can($_); - } - $self; -} - -{ sub handle; *handle = \&handler } # just create alias - -# ====================================================================== -# -# Copyright (C) 2001 Single Source oy (marko****@krono*****) -# a FastCGI transport class for SOAP::Lite. -# -# $Id: HTTP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::HTTP::FCGI; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Transport::HTTP::CGI); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { require FCGI; Exporter::require_version('FCGI' => 0.47); # requires thread-safe interface - my $self = shift; - - if (!ref($self)) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - $self->{_fcgirq} = FCGI::Request(\*STDIN, \*STDOUT, \*STDERR); - SOAP::Trace::objects('()'); - } - return $self; -} - -sub handle { - my $self = shift->new; - - my ($r1, $r2); - my $fcgirq = $self->{_fcgirq}; - - while (($r1 = $fcgirq->Accept()) >= 0) { - $r2 = $self->SUPER::handle; - } - - return undef; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::HTTP - Server/Client side HTTP support for SOAP::Lite - -=head1 SYNOPSIS - -=over 4 - -=item Client - - use SOAP::Lite - uri => 'http://my.own.site.com/My/Examples', - proxy => 'http://localhost/', - # proxy => 'http://localhost/cgi-bin/soap.cgi', # local CGI server - # proxy => 'http://localhost/', # local daemon server - # proxy => 'http://localhost/soap', # local mod_perl server - # proxy => 'https://localhost/soap', # local mod_perl SECURE server - # proxy => 'http://login:password@localhost/cgi-bin/soap.cgi', # local CGI server with authentication - ; - - print getStateName(1); - -=item CGI server - - use SOAP::Transport::HTTP; - - SOAP::Transport::HTTP::CGI - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - -> handle - ; - -=item Daemon server - - use SOAP::Transport::HTTP; - - # change LocalPort to 81 if you want to test it with soapmark.pl - - my $daemon = SOAP::Transport::HTTP::Daemon - -> new (LocalAddr => 'localhost', LocalPort => 80) - # specify list of objects-by-reference here - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - print "Contact to SOAP server at ", $daemon->url, "\n"; - $daemon->handle; - -=item Apache mod_perl server - -See F<examples/server/Apache.pm> and L</"EXAMPLES"> section for more information. - -=item mod_soap server (.htaccess, directory-based access) - - SetHandler perl-script - PerlHandler Apache::SOAP - PerlSetVar dispatch_to "/Your/Path/To/Deployed/Modules, Module::Name, Module::method" - PerlSetVar options "compress_threshold => 10000" - -See L<Apache::SOAP> for more information. - -=back - -=head1 DESCRIPTION - -This class encapsulates all HTTP related logic for a SOAP server, -independent of what web server it's attached to. -If you want to use this class you should follow simple guideline -mentioned above. - -Following methods are available: - -=over 4 - -=item on_action() - -on_action method lets you specify SOAPAction understanding. It accepts -reference to subroutine that takes three parameters: - - SOAPAction, method_uri and method_name. - -C<SOAPAction> is taken from HTTP header and method_uri and method_name are -extracted from request's body. Default behavior is match C<SOAPAction> if -present and ignore it otherwise. You can specify you own, for example -die if C<SOAPAction> doesn't match with following code: - - $server->on_action(sub { - (my $action = shift) =~ s/^("?)(.+)\1$/$2/; - die "SOAPAction shall match 'uri#method'\n" if $action ne join '#', @_; - }); - -=item dispatch_to() - -dispatch_to lets you specify where you want to dispatch your services -to. More precisely, you can specify C<PATH>, C<MODULE>, C<method> or -combination C<MODULE::method>. Example: - - dispatch_to( - 'PATH/', # dynamic: load anything from there, any module, any method - 'MODULE', # static: any method from this module - 'MODULE::method', # static: specified method from this module - 'method', # static: specified method from main:: - ); - -If you specify C<PATH/> name of module/classes will be taken from uri as -path component and converted to Perl module name with substitution -'::' for '/'. Example: - - urn:My/Examples => My::Examples - urn://localhost/My/Examples => My::Examples - http://localhost/My/Examples => My::Examples - -For consistency first '/' in the path will be ignored. - -According to this scheme to deploy new class you should put this -class in one of the specified directories and enjoy its services. -Easy, eh? - -=item handle() - -handle method will handle your request. You should provide parameters -with request() method, call handle() and get it back with response() . - -=item request() - -request method gives you access to HTTP::Request object which you -can provide for Server component to handle request. - -=item response() - -response method gives you access to HTTP::Response object which -you can access to get results from Server component after request was -handled. - -=back - -=head2 PROXY SETTINGS - -You can use any proxy setting you use with LWP::UserAgent modules: - - SOAP::Lite->proxy('http://endpoint.server/', - proxy => ['http' => 'http://my.proxy.server']); - -or - - $soap->transport->proxy('http' => 'http://my.proxy.server'); - -should specify proxy server for you. And if you use C<HTTP_proxy_user> -and C<HTTP_proxy_pass> for proxy authorization SOAP::Lite should know -how to handle it properly. - -=head2 COOKIE-BASED AUTHENTICATION - - use HTTP::Cookies; - - my $cookies = HTTP::Cookies->new(ignore_discard => 1); - # you may also add 'file' if you want to keep them between sessions - - my $soap = SOAP::Lite->proxy('http://localhost/'); - $soap->transport->cookie_jar($cookies); - -Cookies will be taken from response and provided for request. You may -always add another cookie (or extract what you need after response) -with HTTP::Cookies interface. - -You may also do it in one line: - - $soap->proxy('http://localhost/', - cookie_jar => HTTP::Cookies->new(ignore_discard => 1)); - -=head2 SSL CERTIFICATE AUTHENTICATION - -To get certificate authentication working you need to specify three -environment variables: C<HTTPS_CERT_FILE>, C<HTTPS_KEY_FILE>, and -(optionally) C<HTTPS_CERT_PASS>: - - $ENV{HTTPS_CERT_FILE} = 'client-cert.pem'; - $ENV{HTTPS_KEY_FILE} = 'client-key.pem'; - -Crypt::SSLeay (which is used for https support) will take care about -everything else. Other options (like CA peer verification) can be specified -in a similar way. See Crypt::SSLeay documentation for more details. - -Those who would like to use encrypted keys may check -http://groups.yahoo.com/group/soaplite/message/729 for details. - -=head2 COMPRESSION - -SOAP::Lite provides you with the option for enabling compression on the -wire (for HTTP transport only). Both server and client should support -this capability, but this should be absolutely transparent to your -application. The Server will respond with an encoded message only if -the client can accept it (indicated by client sending an Accept-Encoding -header with 'deflate' or '*' values) and client has fallback logic, -so if server doesn't understand specified encoding -(Content-Encoding: deflate) and returns proper error code -(415 NOT ACCEPTABLE) client will repeat the same request without encoding -and will store this server in a per-session cache, so all other requests -will go there without encoding. - -Having options on client and server side that let you specify threshold -for compression you can safely enable this feature on both client and -server side. - -=over 4 - -=item Client - - print SOAP::Lite - -> uri('http://localhost/My/Parameters') - -> proxy('http://localhost/', options => {compress_threshold => 10000}) - -> echo(1 x 10000) - -> result - ; - -=item Server - - my $server = SOAP::Transport::HTTP::CGI - -> dispatch_to('My::Parameters') - -> options({compress_threshold => 10000}) - -> handle; - -=back - -Compression will be enabled on the client side -B<if> the threshold is specified -B<and> the size of current message is bigger than the threshold -B<and> the module Compress::Zlib is available. - -The Client will send the header 'Accept-Encoding' with value 'deflate' -B<if> the threshold is specified -B<and> the module Compress::Zlib is available. - -Server will accept the compressed message if the module Compress::Zlib -is available, and will respond with the compressed message -B<only if> the threshold is specified -B<and> the size of the current message is bigger than the threshold -B<and> the module Compress::Zlib is available -B<and> the header 'Accept-Encoding' is presented in the request. - -=head1 EXAMPLES - -Consider following examples of SOAP servers: - -=over 4 - -=item CGI: - - use SOAP::Transport::HTTP; - - SOAP::Transport::HTTP::CGI - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - -> handle - ; - -=item daemon: - - use SOAP::Transport::HTTP; - - my $daemon = SOAP::Transport::HTTP::Daemon - -> new (LocalAddr => 'localhost', LocalPort => 80) - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - print "Contact to SOAP server at ", $daemon->url, "\n"; - $daemon->handle; - -=item mod_perl: - -httpd.conf: - - <Location /soap> - SetHandler perl-script - PerlHandler SOAP::Apache - </Location> - -Apache.pm: - - package SOAP::Apache; - - use SOAP::Transport::HTTP; - - my $server = SOAP::Transport::HTTP::Apache - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method'); - - sub handler { $server->handler(@_) } - - 1; - -=item Apache::Registry: - -httpd.conf: - - Alias /mod_perl/ "/Apache/mod_perl/" - <Location /mod_perl> - SetHandler perl-script - PerlHandler Apache::Registry - PerlSendHeader On - Options +ExecCGI - </Location> - -soap.mod_cgi (put it in /Apache/mod_perl/ directory mentioned above) - - use SOAP::Transport::HTTP; - - SOAP::Transport::HTTP::CGI - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - -> handle - ; - -=back - -WARNING: dynamic deployment with Apache::Registry will fail, because -module will be loaded dynamically only for the first time. After that -it is already in the memory, that will bypass dynamic deployment and -produces error about denied access. Specify both PATH/ and MODULE name -in dispatch_to() and module will be loaded dynamically and then will work -as under static deployment. See examples/server/soap.mod_cgi for example. - -=head1 TROUBLESHOOTING - -=over 4 - -=item Dynamic libraries are not found - -If you see in webserver's log file something like this: - -Can't load '/usr/local/lib/perl5/site_perl/.../XML/Parser/Expat/Expat.so' -for module XML::Parser::Expat: dynamic linker: /usr/local/bin/perl: - libexpat.so.0 is NEEDED, but object does not exist at -/usr/local/lib/perl5/.../DynaLoader.pm line 200. - -and you are using Apache web server, try to put into your httpd.conf - - <IfModule mod_env.c> - PassEnv LD_LIBRARY_PATH - </IfModule> - -=item Apache is crashing with segfaults (it may looks like "500 unexpected EOF before status line seen" on client side) - -If using SOAP::Lite (or XML::Parser::Expat) in combination with mod_perl -causes random segmentation faults in httpd processes try to configure -Apache with: - - RULE_EXPAT=no - --- OR (for Apache 1.3.20 and later) -- - - ./configure --disable-rule=EXPAT - -See http://archive.covalent.net/modperl/2000/04/0185.xml for more -details and lot of thanks to Robert Barta <rho****@bigpo*****> for -explaining this weird behavior. - -If it doesn't help, you may also try -Uusemymalloc -(or something like that) to get perl to use the system's own malloc. -Thanks to Tim Bunce <Tim.B****@pobox*****>. - -=item CGI scripts are not running under Microsoft Internet Information Server (IIS) - -CGI scripts may not work under IIS unless scripts are .pl, not .cgi. - -=back - -=head1 DEPENDENCIES - - Crypt::SSLeay for HTTPS/SSL - SOAP::Lite, URI for SOAP::Transport::HTTP::Server - LWP::UserAgent, URI for SOAP::Transport::HTTP::Client - HTTP::Daemon for SOAP::Transport::HTTP::Daemon - Apache, Apache::Constants for SOAP::Transport::HTTP::Apache - -=head1 SEE ALSO - - See ::CGI, ::Daemon and ::Apache for implementation details. - See examples/server/soap.cgi as SOAP::Transport::HTTP::CGI example. - See examples/server/soap.daemon as SOAP::Transport::HTTP::Daemon example. - See examples/My/Apache.pm as SOAP::Transport::HTTP::Apache example. - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/IO.pm Tue Oct 25 04:20:51 2005 @@ -1,129 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: IO.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::IO; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use IO::File; -use SOAP::Lite; - -# ====================================================================== - -package SOAP::Transport::IO::Server; - -use strict; -use Carp (); -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Server); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - $self = $class->SUPER::new(@_); - } - return $self; -} - -sub BEGIN { - no strict 'refs'; - my %modes = (in => '<', out => '>'); - for my $method (keys %modes) { - my $field = '_' . $method; - *$method = sub { - my $self = shift->new; - return $self->{$field} unless @_; - - my $file = shift; - if (defined $file && !ref $file && !defined fileno($file)) { - my $name = $file; - open($file = new IO::File, $modes{$method} . $name) or Carp::croak "$name: $!"; - } - $self->{$field} = $file; - return $self; - } - } -} - -sub handle { - my $self = shift->new; - - $self->in(*STDIN)->out(*STDOUT) unless defined $self->in; - my $in = $self->in; - my $out = $self->out; - - my $result = $self->SUPER::handle(join '', <$in>); - no strict 'refs'; print {$out} $result if defined $out; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::IO - Server side IO support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Transport::IO; - - SOAP::Transport::IO::Server - - # you may specify as parameters for new(): - # -> new( in => 'in_file_name' [, out => 'out_file_name'] ) - # -> new( in => IN_HANDLE [, out => OUT_HANDLE] ) - # -> new( in => *IN_HANDLE [, out => *OUT_HANDLE] ) - # -> new( in => \*IN_HANDLE [, out => \*OUT_HANDLE] ) - - # -- OR -- - # any combinations - # -> new( in => *STDIN, out => 'out_file_name' ) - # -> new( in => 'in_file_name', => \*OUT_HANDLE ) - - # -- OR -- - # use in() and/or out() methods - # -> in( *STDIN ) -> out( *STDOUT ) - - # -- OR -- - # use default (when nothing specified): - # in => *STDIN, out => *STDOUT - - # don't forget, if you want to accept parameters from command line - # \*HANDLER will be understood literally, so this syntax won't work - # and server will complain - - -> new(@ARGV) - - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - -> handle - ; - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/JABBER.pm Tue Oct 25 04:20:51 2005 @@ -1,294 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: JABBER.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::JABBER; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use Net::Jabber 1.0021 qw(Client); -use URI::Escape; -use URI; -use SOAP::Lite; - -my $NAMESPACE = "http://namespaces.soaplite.com/transport/jabber"; - -{ local $^W; - # fix problem with printData in 1.0021 - *Net::Jabber::printData = sub {'nothing'} if Net::Jabber->VERSION == 1.0021; - - # fix problem with Unicode encoding in EscapeXML. Jabber ALWAYS convert latin to utf8 - *Net::Jabber::EscapeXML = *Net::Jabber::EscapeXML = # that's Jabber 1.0021 - *XML::Stream::EscapeXML = *XML::Stream::EscapeXML = # that's Jabber 1.0022 - \&SOAP::Utils::encode_data; - - # There is also an error in XML::Stream::UnescapeXML 1.12, but - # we can't do anything there, except hack it also :( -} - -# ====================================================================== - -package URI::jabber; # ok, lets do 'jabber://' scheme -require URI::_server; require URI::_userpass; - ＠ URI::jabber::ISA=qw(URI::_server URI::_userpass); - - # jabber://soaplite_client:soapl****@jabbe*****:5222/soaplite_serve****@jabbe*****/Home - # ^^^^^^ ^^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^ ^^^^ ^^^^^^^^^^^^^^^^^^^^^^^^^^ ^^^^ - -# ====================================================================== - -package SOAP::Transport::JABBER::Query; - -sub new { - my $proto = shift; - bless {} => ref($proto) || $proto; -} - -sub SetPayload { - shift; Net::Jabber::SetXMLData("single",shift->{QUERY},"payload",shift,{}); -} - -sub GetPayload { - shift; Net::Jabber::GetXMLData("value",shift->{QUERY},"payload",""); -} - -# ====================================================================== - -package SOAP::Transport::JABBER::Client; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Client Net::Jabber::Client); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new(@params); - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub endpoint { - my $self = shift; - - return $self->SUPER::endpoint unless @_; - - my $endpoint = shift; - - # nothing to do if new endpoint is the same as current one - return $self if $self->SUPER::endpoint && $self->SUPER::endpoint eq $endpoint; - - my $uri = URI->new($endpoint); - my($undef, $to, $resource) = split m!/!, $uri->path, 3; - $self->Connect( - hostname => $uri->host, - port => $uri->port, - ) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!"; - - my @result = $self->AuthSend( - username => $uri->user, - password => $uri->password, - resource => 'soapliteClient', - ); - $result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result"; - - $self->AddDelegate( - namespace => $NAMESPACE, - parent => 'Net::Jabber::Query', - parenttype => 'query', - delegate => 'SOAP::Transport::JABBER::Query', - ); - - # Get roster and announce presence - $self->RosterGet(); - $self->PresenceSend(); - - $self->SUPER::endpoint($endpoint); -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $encoding) = - @parameters{qw(envelope endpoint encoding)}; - - $self->endpoint($endpoint ||= $self->endpoint); - - my($undef, $to, $resource) = split m!/!, URI->new($endpoint)->path, 3; - - # Create a Jabber info/query message - my $iq = new Net::Jabber::IQ(); - $iq->SetIQ( - type => 'set', - to => join '/', $to => $resource || 'soapliteServer', - ); - my $query = $iq->NewQuery($NAMESPACE); - $query->SetPayload($envelope); - - SOAP::Trace::debug($envelope); - - my $iq_rcvd = $self->SendAndReceiveWithID($iq); - my($query_rcvd) = $iq_rcvd->GetQuery($NAMESPACE) if $iq_rcvd; # expect only one - my $msg = $query_rcvd->GetPayload() if $query_rcvd; - - SOAP::Trace::debug($msg); - - my $code = $self->GetErrorCode(); - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return $msg; -} - -# ====================================================================== - -package SOAP::Transport::JABBER::Server; - -use Carp (); -use vars qw(@ISA $AUTOLOAD); - ＠ ISA = qw(SOAP::Server); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my $uri = URI->new(shift); - $self = $class->SUPER::new(@_); - - $self->{_jabberserver} = Net::Jabber::Client->new; - $self->{_jabberserver}->Connect( - hostname => $uri->host, - port => $uri->port, - ) or Carp::croak "Can't connect to @{[$uri->host_port]}: $!"; - - my($undef, $resource) = split m!/!, $uri->path, 2; - my @result = $self->AuthSend( - username => $uri->user, - password => $uri->password, - resource => $resource || 'soapliteServer', - ); - $result[0] eq "ok" or Carp::croak "Can't authenticate to @{[$uri->host_port]}: @result"; - - $self->{_jabberserver}->SetCallBacks( - iq => sub { - shift; - my $iq = new Net::Jabber::IQ(@_); - - my($query) = $iq->GetQuery($NAMESPACE); # expect only one - my $request = $query->GetPayload(); - - SOAP::Trace::debug($request); - - # Set up response - my $reply = $iq->Reply; - my $x = $reply->NewQuery($NAMESPACE); - - my $response = $self->SUPER::handle($request); - $x->SetPayload($response); - - # Send response - $self->{_jabberserver}->Send($reply); - } - ); - - $self->AddDelegate( - namespace => $NAMESPACE, - parent => 'Net::Jabber::Query', - parenttype => 'query', - delegate => 'SOAP::Transport::JABBER::Query', - ); - - $self->RosterGet(); - $self->PresenceSend(); - } - return $self; -} - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { shift->{_jabberserver}->$method(@_) }; - goto &$AUTOLOAD; -} - -sub handle { - shift->Process(); -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::JABBER - Server/Client side JABBER support for SOAP::Lite - -=head1 SYNOPSIS - -=over 4 - -=item Client - - use SOAP::Lite - uri => 'http://my.own.site.com/My/Examples', - proxy => 'jabber://username:passw****@jabbe*****:5222/soaplite_serve****@jabbe*****/', - # proto username passwd server port destination resource (optional) - ; - - print getStateName(1); - -=item Server - - use SOAP::Transport::JABBER; - - my $server = SOAP::Transport::JABBER::Server - -> new('jabber://username:passw****@jabbe*****:5222') - # specify list of objects-by-reference here - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - - print "Contact to SOAP server\n"; - do { $server->handle } while sleep 10; - -=back - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/LOCAL.pm Tue Oct 25 04:20:51 2005 @@ -1,78 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: LOCAL.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::LOCAL; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -# ====================================================================== - -package SOAP::Transport::LOCAL::Client; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Client SOAP::Server); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new(@params); - $self->is_success(1); # it's difficult to fail in this module - $self->dispatch_to(@INC); - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - } - return $self; -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action) = - @parameters{qw(envelope endpoint action)}; - - SOAP::Trace::debug($envelope); - my $response = $self->SUPER::handle($envelope); - SOAP::Trace::debug($response); - - $response; -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::LOCAL - Client side no-transport support for SOAP::Lite - -=head1 SYNOPSIS - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MAILTO.pm Tue Oct 25 04:20:51 2005 @@ -1,122 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: MAILTO.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::MAILTO; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use MIME::Lite; -use URI; - -# ====================================================================== - -package SOAP::Transport::MAILTO::Client; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Client); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = bless {@params} => $class; - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action) = - @parameters{qw(envelope endpoint action)}; - - $endpoint ||= $self->endpoint; - my $uri = URI->new($endpoint); - %parameters = (%$self, map {URI::Escape::uri_unescape($_)} map {split/=/,$_,2} split /[&;]/, $uri->query || ''); - - my $msg = MIME::Lite->new( - To => $uri->to, - Type => 'text/xml', - Encoding => $parameters{Encoding} || 'base64', - Data => $envelope, - $parameters{From} ? (From => $parameters{From}) : (), - $parameters{'Reply-To'} ? ('Reply-To' => $parameters{'Reply-To'}) : (), - $parameters{Subject} ? (Subject => $parameters{Subject}) : (), - ); - $msg->replace('X-Mailer' => join '/', 'SOAP::Lite', 'Perl', SOAP::Transport::MAILTO->VERSION); - $msg->add(SOAPAction => $action); - - SOAP::Trace::transport($msg); - SOAP::Trace::debug($msg->as_string); - - MIME::Lite->send(map {exists $parameters{$_} ? ($_ => $parameters{$_}) : ()} 'smtp', 'sendmail'); - eval { local $SIG{__DIE__}; $MIME::Lite::AUTO_CC = 0; $msg->send }; - (my $code = $@) =~ s/ at .*\n//; - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return; -} - -# ====================================================================== - -1; - -=head1 NAME - -SOAP::Transport::MAILTO - Client side SMTP/sendmail support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Lite; - - SOAP::Lite - -> uri('http://soaplite.com/My/Examples') - -> proxy('mailto:destination.email ＠ address', smtp => 'smtp.server', From => 'your.email', Subject => 'SOAP message') - - # or - # -> proxy('mailto:destination.email ＠ address?From=your.email&Subject=SOAP%20message', smtp => 'smtp.server') - - # or if you want to send with sendmail - # -> proxy('mailto:destination.email ＠ address?From=your.email&Subject=SOAP%20message') - - # or if your sendmail is in undiscoverable place - # -> proxy('mailto:destination.email ＠ address?From=your.email&Subject=SOAP%20message', sendmail => 'command to run your sendmail') - - -> getStateName(12) - ; - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/MQ.pm Tue Oct 25 04:20:51 2005 @@ -1,286 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: MQ.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::MQ; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use MQClient::MQSeries; -use MQSeries::QueueManager; -use MQSeries::Queue; -use MQSeries::Message; - -use URI; -use URI::Escape; -use SOAP::Lite; - -# ====================================================================== - -package URI::mq; # ok, lets do 'mq://' scheme -require URI::_server; require URI::_userpass; - ＠ URI::mq::ISA=qw(URI::_server URI::_userpass); - - # mq://user@host:port?Channel=A;QueueManager=B;RequestQueue=C;ReplyQueue=D - # ^^ ^^^^ ^^^^ ^^^^ ^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^^^^^ ^^^^^^^^^^^^ - -# ====================================================================== - -package SOAP::Transport::MQ::Client; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Client); - -use MQSeries qw(:constants); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = bless {@params} => $class; - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - SOAP::Trace::objects('()'); - } - return $self; -} - -sub BEGIN { - no strict 'refs'; - for my $method (qw(requestqueue replyqueue)) { - my $field = '_' . $method; - *$method = sub { - my $self = shift->new; - @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; - } - } -} - -sub endpoint { - my $self = shift; - - return $self->SUPER::endpoint unless @_; - - my $endpoint = shift; - - # nothing to do if new endpoint is the same as the current one - return $self if $self->SUPER::endpoint eq $endpoint; - - my $uri = URI->new($endpoint); - my %parameters = (%$self, map {URI::Escape::uri_unescape($_)} map {split/=/,$_,2} split /[&;]/, $uri->query || ''); - - $ENV{MQSERVER} = sprintf "%s/TCP/%s(%s)", $parameters{Channel}, $uri->host, $uri->port - if $uri->host; - - my $qmgr = MQSeries::QueueManager->new(QueueManager => $parameters{QueueManager}) || - die "Unable to connect to queue manager $parameters{QueueManager}\n"; - - $self->requestqueue(MQSeries::Queue->new ( - QueueManager => $qmgr, - Queue => $parameters{RequestQueue}, - Mode => 'output', - ) || die "Unable to open $parameters{RequestQueue}\n"); - - $self->replyqueue(MQSeries::Queue->new ( - QueueManager => $qmgr, - Queue => $parameters{ReplyQueue}, - Mode => 'input', - ) || die "Unable to open $parameters{ReplyQueue}\n"); - - $self->SUPER::endpoint($endpoint); -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint) = - @parameters{qw(envelope endpoint)}; - - $self->endpoint($endpoint ||= $self->endpoint); - - %parameters = (%$self, %parameters); - my $expiry = $parameters{Expiry} || 60000; - - SOAP::Trace::debug($envelope); - - my $request = MQSeries::Message->new ( - MsgDesc => {Format => MQFMT_STRING, Expiry => $expiry}, - Data => $envelope, - ); - - $self->requestqueue->Put(Message => $request) || - die "Unable to put message to queue\n"; - - my $reply = MQSeries::Message->new ( - MsgDesc => {CorrelId => $request->MsgDesc('MsgId')}, - ); - - my $result = $self->replyqueue->Get ( - Message => $reply, - Wait => $expiry, - ); - - my $msg = $reply->Data if $result > 0; - - SOAP::Trace::debug($msg); - - my $code = $result > 0 ? undef : - $result < 0 ? 'Timeout' : 'Error occured while waiting for response'; - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return $msg; -} - -# ====================================================================== - -package SOAP::Transport::MQ::Server; - -use Carp (); -use vars qw(@ISA $AUTOLOAD); - ＠ ISA = qw(SOAP::Server); - -use MQSeries qw(:constants); - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my $uri = URI->new(shift); - $self = $class->SUPER::new(@_); - - my %parameters = (%$self, map {URI::Escape::uri_unescape($_)} map {split/=/,$_,2} split /[&;]/, $uri->query || ''); - - $ENV{MQSERVER} = sprintf "%s/TCP/%s(%s)", $parameters{Channel}, $uri->host, $uri->port - if $uri->host; - - my $qmgr = MQSeries::QueueManager->new(QueueManager => $parameters{QueueManager}) || - Carp::croak "Unable to connect to queue manager $parameters{QueueManager}"; - - $self->requestqueue(MQSeries::Queue->new ( - QueueManager => $qmgr, - Queue => $parameters{RequestQueue}, - Mode => 'input', - ) || Carp::croak "Unable to open $parameters{RequestQueue}"); - - $self->replyqueue(MQSeries::Queue->new ( - QueueManager => $qmgr, - Queue => $parameters{ReplyQueue}, - Mode => 'output', - ) || Carp::croak "Unable to open $parameters{ReplyQueue}"); - } - return $self; -} - -sub BEGIN { - no strict 'refs'; - for my $method (qw(requestqueue replyqueue)) { - my $field = '_' . $method; - *$method = sub { - my $self = shift->new; - @_ ? ($self->{$field} = shift, return $self) : return $self->{$field}; - } - } -} - -sub handle { - my $self = shift->new; - - my $msg = 0; - while (1) { - my $request = MQSeries::Message->new; - - # nonblock waiting - $self->requestqueue->Get ( - Message => $request, - ) || die "Error occured while waiting for requests\n"; - - return $msg if $self->requestqueue->Reason == MQRC_NO_MSG_AVAILABLE; - - my $reply = MQSeries::Message->new ( - MsgDesc => { - CorrelId => $request->MsgDesc('MsgId'), - Expiry => $request->MsgDesc('Expiry'), - }, - Data => $self->SUPER::handle($request->Data), - ); - - $self->replyqueue->Put ( - Message => $reply, - ) || die "Unable to put reply message\n"; - - $msg++; - } -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::MQ - Server/Client side MQ support for SOAP::Lite - -=head1 SYNOPSIS - -=over 4 - -=item Client - - use SOAP::Lite - uri => 'http://my.own.site.com/My/Examples', - proxy => 'mq://server:port?Channel=CHAN1;QueueManager=QM_SOAP;RequestQueue=SOAPREQ1;ReplyQueue=SOAPRESP1', - ; - - print getStateName(1); - -=item Server - - use SOAP::Transport::MQ; - - my $server = SOAP::Transport::MQ::Server - ->new('mq://server:port?Channel=CHAN1;QueueManager=QM_SOAP;RequestQueue=SOAPREQ1;ReplyQueue=SOAPRESP1') - # specify list of objects-by-reference here - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - - print "Contact to SOAP server\n"; - do { $server->handle } while sleep 1; - -=back - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/POP3.pm Tue Oct 25 04:20:51 2005 @@ -1,120 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: POP3.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::POP3; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use Net::POP3; -use URI; -use SOAP::Lite; - -# ====================================================================== - -package SOAP::Transport::POP3::Server; - -use Carp (); -use vars qw(@ISA $AUTOLOAD); - ＠ ISA = qw(SOAP::Server); - -sub DESTROY { my $self = shift; $self->quit if $self->{_pop3server} } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my $address = shift; - Carp::carp "URLs without 'pop://' scheme are deprecated. Still continue" - if $address =~ s!^(pop://)?!pop://!i && !$1; - my $server = URI->new($address); - $self = $class->SUPER::new(@_); - $self->{_pop3server} = Net::POP3->new($server->host_port) or Carp::croak "Can't connect to '@{[$server->host_port]}': $!"; - my $method = !$server->auth || $server->auth eq '*' ? 'login' : - $server->auth eq '+APOP' ? 'apop' : - Carp::croak "Unsupported authentication scheme '@{[$server->auth]}'"; - $self->{_pop3server}->$method(split /:/, $server->user) or Carp::croak "Can't authenticate to '@{[$server->host_port]}' with '$method' method" - if defined $server->user; - } - return $self; -} - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { shift->{_pop3server}->$method(@_) }; - goto &$AUTOLOAD; -} - -sub handle { - my $self = shift->new; - my $messages = $self->list or return; - foreach my $msgid (keys %$messages) { - $self->SUPER::handle(join '', @{$self->get($msgid)}); - } continue { - $self->delete($msgid); - } - return scalar keys %$messages; -} - -sub make_fault { return } - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::POP3 - Server side POP3 support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Transport::POP3; - - my $server = SOAP::Transport::POP3::Server - -> new('pop://pop.mail.server') - # if you want to have all in one place - # -> new('pop://user:passw****@pop*****') - # or, if you have server that supports MD5 protected passwords - # -> new('pop://user:password;AUTH=****@pop*****') - # specify list of objects-by-reference here - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - # specify path to My/Examples.pm here - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - # you don't need to use next line if you specified your password in new() - $server->login('user' => 'password') or die "Can't authenticate to POP3 server\n"; - - # handle will return number of processed mails - # you can organize loop if you want - do { $server->handle } while sleep 10; - - # you may also call $server->quit explicitly to purge deleted messages - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut Index: affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm diff -u affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm:1.1.1.1 affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm:removed --- affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm:1.1.1.1 Tue Oct 25 04:14:40 2005 +++ affelio_farm/admin/skelton/affelio/extlib/SOAP/Transport/TCP.pm Tue Oct 25 04:20:51 2005 @@ -1,247 +0,0 @@ -# ====================================================================== -# -# Copyright (C) 2000-2001 Paul Kulchenko (paulc****@yahoo*****) -# SOAP::Lite is free software; you can redistribute it -# and/or modify it under the same terms as Perl itself. -# -# $Id: TCP.pm,v 1.1.1.1 2005/10/24 19:14:40 slash5234 Exp $ -# -# ====================================================================== - -package SOAP::Transport::TCP; - -use strict; -use vars qw($VERSION); -$VERSION = eval sprintf("%d.%s", q$Name: $ =~ /-(\d+)_([\d_]+)/); - -use URI; -use IO::Socket; -use IO::Select; -use IO::SessionData; -use SOAP::Lite; - -# ====================================================================== - -package URI::tcp; # ok, lets do 'tcp://' scheme -require URI::_server; - ＠ URI::tcp::ISA=qw(URI::_server); - -# ====================================================================== - -package SOAP::Transport::TCP::Client; - -use vars qw(@ISA); - ＠ ISA = qw(SOAP::Client); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = bless {@params} => $class; - while (@methods) { my($method, $params) = splice(@methods,0,2); - $self->$method(ref $params eq 'ARRAY' ? @$params : $params) - } - # use SSL if there is any parameter with SSL_* in the name - $self->SSL(1) if !$self->SSL && grep /^SSL_/, keys %$self; - SOAP::Trace::objects('()'); - } - return $self; -} - -sub SSL { - my $self = shift->new; - @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL}; -} - -sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' } - -sub syswrite { - my($self, $sock, $data) = @_; - - my $timeout = $sock->timeout; - - my $select = IO::Select->new($sock); - - my $len = length $data; - while (length $data > 0) { - return unless $select->can_write($timeout); - local $SIG{PIPE} = 'IGNORE'; - my $wc = syswrite($sock, $data); - if (defined $wc) { - substr($data, 0, $wc) = ''; - } elsif (!IO::SessionData::WOULDBLOCK($!)) { - return; - } - } - return $len; -} - -sub sysread { - my($self, $sock) = @_; - - my $timeout = $sock->timeout; - my $select = IO::Select->new($sock); - - my $result = ''; - my $data; - while (1) { - return unless $select->can_read($timeout); - my $rc = sysread($sock, $data, 4096); - if ($rc) { - $result .= $data; - } elsif (defined $rc) { - return $result; - } elsif (!IO::SessionData::WOULDBLOCK($!)) { - return; - } - } -} - -sub send_receive { - my($self, %parameters) = @_; - my($envelope, $endpoint, $action) = - @parameters{qw(envelope endpoint action)}; - - $endpoint ||= $self->endpoint; - warn "URLs with 'tcp:' scheme are deprecated. Use 'tcp://'. Still continue\n" - if $endpoint =~ s!^tcp:(//)?!tcp://!i && !$1; - my $uri = URI->new($endpoint); - - local($^W, $@, $!); - my $sock = $self->io_socket_class->new ( - PeerAddr => $uri->host, PeerPort => $uri->port, Proto => $uri->scheme, %$self - ); - - SOAP::Trace::debug($envelope); - - my $result; - if ($sock) { - $sock->blocking(0); - $self->syswrite($sock, $envelope) and - $sock->shutdown(1) and # stop writing - $result = $self->sysread($sock); - } - - SOAP::Trace::debug($result); - - my $code = $@ || $!; - - $self->code($code); - $self->message($code); - $self->is_success(!defined $code || $code eq ''); - $self->status($code); - - return $result; -} - -# ====================================================================== - -package SOAP::Transport::TCP::Server; - -use IO::SessionSet; - -use Carp (); -use vars qw($AUTOLOAD @ISA); - ＠ ISA = qw(SOAP::Server); - -sub DESTROY { SOAP::Trace::objects('()') } - -sub new { - my $self = shift; - - unless (ref $self) { - my $class = ref($self) || $self; - - my(@params, @methods); - while (@_) { $class->can($_[0]) ? push(@methods, shift() => shift) : push(@params, shift) } - $self = $class->SUPER::new(@methods); - - # use SSL if there is any parameter with SSL_* in the name - $self->SSL(1) if !$self->SSL && grep /^SSL_/, @params; - - my $socket = $self->io_socket_class; - eval "require $socket" or Carp::croak $@ unless UNIVERSAL::can($socket => 'new'); - $self->{_socket} = $socket->new(Proto => 'tcp', @params) - or Carp::croak "Can't open socket: $!"; - - SOAP::Trace::objects('()'); - } - return $self; -} - -sub SSL { - my $self = shift->new; - @_ ? ($self->{_SSL} = shift, return $self) : return $self->{_SSL}; -} - -sub io_socket_class { shift->SSL ? 'IO::Socket::SSL' : 'IO::Socket::INET' } - -sub AUTOLOAD { - my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::') + 2); - return if $method eq 'DESTROY'; - - no strict 'refs'; - *$AUTOLOAD = sub { shift->{_socket}->$method(@_) }; - goto &$AUTOLOAD; -} - -sub handle { - my $self = shift->new; - my $sock = $self->{_socket}; - my $session_set = IO::SessionSet->new($sock); - my %data; - while (1) { - my @ready = $session_set->wait($sock->timeout); - for my $session (@ready) { - my $data; - if (my $rc = $session->read($data, 4096)) { - $data{$session} .= $data if $rc > 0; - } else { - $session->write($self->SUPER::handle(delete $data{$session})); - $session->close; - } - } - } -} - -# ====================================================================== - -1; - -__END__ - -=head1 NAME - -SOAP::Transport::TCP - Server/Client side TCP support for SOAP::Lite - -=head1 SYNOPSIS - - use SOAP::Transport::TCP; - - my $daemon = SOAP::Transport::TCP::Server - -> new (LocalAddr => 'localhost', LocalPort => 82, Listen => 5, Reuse => 1) - -> objects_by_reference(qw(My::PersistentIterator My::SessionIterator My::Chat)) - -> dispatch_to('/Your/Path/To/Deployed/Modules', 'Module::Name', 'Module::method') - ; - print "Contact to SOAP server at ", join(':', $daemon->sockhost, $daemon->sockport), "\n"; - $daemon->handle; - -=head1 DESCRIPTION - -=head1 COPYRIGHT - -Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved. - -This library is free software; you can redistribute it and/or modify -it under the same terms as Perl itself. - -=head1 AUTHOR - -Paul Kulchenko (paulc****@yahoo*****) - -=cut
