LWP-Protocol-http-SocketUnix/0000711000175000017500000000000010075432241017462 5ustar florianflorian00000000000000LWP-Protocol-http-SocketUnix/lib/0000711000175000017500000000000010061165457020237 5ustar florianflorian00000000000000LWP-Protocol-http-SocketUnix/lib/LWP/0000711000175000017500000000000010061165457020701 5ustar florianflorian00000000000000LWP-Protocol-http-SocketUnix/lib/LWP/Protocol/0000711000175000017500000000000010061165457022502 5ustar florianflorian00000000000000LWP-Protocol-http-SocketUnix/lib/LWP/Protocol/http/0000711000175000017500000000000010075432234023454 5ustar florianflorian00000000000000LWP-Protocol-http-SocketUnix/lib/LWP/Protocol/http/SocketUnix.pm0000600000175000017500000001714410075432233026114 0ustar florianflorian00000000000000package LWP::Protocol::http::SocketUnix; use strict; use warnings; use vars qw( @ISA $VERSION ); use IO::Socket; use LWP::Protocol::http; @ISA = qw( LWP::Protocol::http ); $VERSION = 0.02; sub _new_socket { my ($self, $path, $timeout) = @_; local($^W) = 0; my $sock = $self->socket_class->new( Peer => $path, Type => SOCK_STREAM, Timeout => $timeout ); unless($sock) { $@ =~ s/^.*?: //; die "Can't open socket $path\: $@"; } eval { $sock->blocking(0); }; $sock; } sub request { my($self, $request, undef, $arg, $size, $timeout) = @_; LWP::Debug::trace('()'); $size ||= 4096; # check method my $method = $request->method; unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) { # HTTP token return new HTTP::Response &HTTP::Status::RC_BAD_REQUEST, 'Library does not allow method ' . "$method for 'http:' URLs"; } my $url = $request->url; my $path = $url->host . '/' . $url->path_query; my $fullpath = "/"; # connect to remote site my $socket = $self->_new_socket($path, $timeout); $self->_check_sock($request, $socket); my @h; my $request_headers = $request->headers->clone; $self->_fixup_header($request_headers, $url); $request_headers->scan(sub { my($k, $v) = @_; $v =~ s/\n/ /g; push(@h, $k, $v); }); my $content_ref = $request->content_ref; $content_ref = $$content_ref if ref($$content_ref); my $chunked; my $has_content; if (ref($content_ref) eq 'CODE') { my $clen = $request_headers->header('Content-Length'); $has_content++ if $clen; unless (defined $clen) { push(@h, "Transfer-Encoding" => "chunked"); $has_content++; $chunked++; } } else { # Set (or override) Content-Length header my $clen = $request_headers->header('Content-Length'); if (defined($$content_ref) && length($$content_ref)) { $has_content++; if (!defined($clen) || $clen ne length($$content_ref)) { if (defined $clen) { warn "Content-Length header value was wrong, fixed"; hlist_remove(\@h, 'Content-Length'); } push(@h, 'Content-Length' => length($$content_ref)); } } elsif ($clen) { warn "Content-Length set when there is not content, fixed"; hlist_remove(\@h, 'Content-Length'); } } my $req_buf = $socket->format_request($method, $fullpath, @h); #print "------\n$req_buf\n------\n"; # XXX need to watch out for write timeouts { my $n = $socket->syswrite($req_buf, length($req_buf)); die $! unless defined($n); die "short write" unless $n == length($req_buf); #LWP::Debug::conns($req_buf); } my($code, $mess, @junk); if ($has_content) { my $write_wait = 0; $write_wait = 2 if ($request_headers->header("Expect") || "") =~ /100-continue/; my $eof; my $wbuf; my $woffset = 0; if (ref($content_ref) eq 'CODE') { my $buf = &$content_ref(); $buf = "" unless defined($buf); $buf = sprintf "%x%s%s%s", length($buf), $LWP::Protocol::http::CRLF, $buf, $LWP::Protocol::http::CRLF if $chunked; $wbuf = \$buf; } else { $wbuf = $content_ref; $eof = 1; } my $fbits = ''; vec($fbits, fileno($socket), 1) = 1; while ($woffset < length($$wbuf)) { my $time_before; my $sel_timeout = $timeout; if ($write_wait) { $time_before = time; $sel_timeout = $write_wait if $write_wait < $sel_timeout; } my $rbits = $fbits; my $wbits = $write_wait ? undef : $fbits; my $nfound = select($rbits, $wbits, undef, $sel_timeout); unless (defined $nfound) { die "select failed: $!"; } if ($write_wait) { $write_wait -= time - $time_before; $write_wait = 0 if $write_wait < 0; } if (defined($rbits) && $rbits =~ /[^\0]/) { # readable my $buf = $socket->_rbuf; my $n = $socket->sysread($buf, 1024, length($buf)); unless ($n) { die "EOF"; } $socket->_rbuf($buf); if ($buf =~ /\015?\012\015?\012/) { # a whole response present ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk, ); if ($code eq "100") { $write_wait = 0; undef($code); } else { last; # XXX should perhaps try to abort write in a nice way too } } } if (defined($wbits) && $wbits =~ /[^\0]/) { my $n = $socket->syswrite($$wbuf, length($$wbuf), $woffset); unless ($n) { die "syswrite: $!" unless defined $n; die "syswrite: no bytes written"; } $woffset += $n; if (!$eof && $woffset >= length($$wbuf)) { # need to refill buffer from $content_ref code my $buf = &$content_ref(); $buf = "" unless defined($buf); $eof++ unless length($buf); $buf = sprintf "%x%s%s%s", length($buf), $LWP::Protocol::http::CRLF, $buf, $LWP::Protocol::http::CRLF if $chunked; $wbuf = \$buf; $woffset = 0; } } } } ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk) unless $code; ($code, $mess, @h) = $socket->read_response_headers(laxed => 1, junk_out => \@junk) if $code eq "100"; my $response = HTTP::Response->new($code, $mess); my $peer_http_version = $socket->peer_http_version; $response->protocol("HTTP/$peer_http_version"); while (@h) { my($k, $v) = splice(@h, 0, 2); $response->push_header($k, $v); } $response->push_header("Client-Junk" => \@junk) if @junk; $response->request($request); $self->_get_sock_info($response, $socket); if ($method eq "CONNECT") { $response->{client_socket} = $socket; # so it can be picked up return $response; } if (my @te = $response->remove_header('Transfer-Encoding')) { $response->push_header('Client-Transfer-Encoding', \@te); } $response->push_header('Client-Response-Num', $socket->increment_response_count); my $complete; $response = $self->collect($arg, $response, sub { my $buf = ""; #prevent use of uninitialized value in SSLeay.xs my $n; READ: { $n = $socket->read_entity_body($buf, $size); die "Can't read entity body: $!" unless defined $n; redo READ if $n == -1; } $complete++ if !$n; return \$buf; } ); @h = $socket->get_trailers; while (@h) { my($k, $v) = splice(@h, 0, 2); $response->push_header($k, $v); } $response; } package LWP::Protocol::http::SocketUnix::Socket; use strict; use warnings; use vars qw( @ISA ); @ISA =qw( LWP::Protocol::http::SocketMethods Net::HTTP::Methods IO::Socket::UNIX ); sub configure { my ($self, $cnf) = @_; $self->http_configure($cnf); } sub http_connect { my ($self, $cnf) = @_; $self->SUPER::configure($cnf); } # Just to avoid some errors. We don't really need this. sub peerport { } sub peerhost { } 1; __END__ =head1 NAME LWP::Protocol::http::SocketUnix - Speak HTTP through UNIX sockets =head1 SYNOPSIS use LWP::Protocol::http::SocketUnix; LWP::Protocol::implementor( http => 'LWP::Protocol::http::SocketUnix' ); ... =head1 DESCRIPTION LWP::Protocol::http::UnixSocket enables you to speak HTTP through UNIX sockets. To use it you need to overwrite the implementor class of the LWP 'http' scheme. All 'http' URIs will now be interpreted as local sockets by LWP. The interface of LWP::Protocol::http::SocketUnix is similar to LWP::Protocol::http, which LWP::Protocol::http::SocketUnix inherits from. =head1 SEE ALSO LWP, LWP::Protocol =head1 AUTHOR Florian Ragwitz, Eflora@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright (C) 2004 by Florian Ragwitz This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.4 or, at your option, any later version of Perl 5 you may have available. =cut LWP-Protocol-http-SocketUnix/Makefile.PL0000600000175000017500000000113210075431060021427 0ustar florianflorian00000000000000use 5.008004; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( NAME => 'LWP::Protocol::http::SocketUnix', VERSION_FROM => 'lib/LWP/Protocol/http/SocketUnix.pm', # finds $VERSION PREREQ_PM => {}, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/LWP/Protocol/http/SocketUnix.pm', # retrieve abstract from module AUTHOR => 'Florian Ragwitz ') : ()), ); LWP-Protocol-http-SocketUnix/README0000600000175000017500000000161210075432240020341 0ustar florianflorian00000000000000LWP-Protocol-http-SocketUnix version 0.02 ==================================== LWP::Protocol::http::SocketUnix enables you to speak HTTP through UNIX sockets. To use it you need to overwrite the implementor class of the LWP 'http' scheme. All 'http' URIs will now be interpreted as local sockets by LWP. The interface of LWP::Protocol::http::SocketUnix is similar to LWP::Protocol::http, which LWP::Protocol::http::SocketUnix inherits from. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: LWP COPYRIGHT AND LICENCE Copyright (C) 2004 by Florian Ragwitz This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.4 or, at your option, any later version of Perl 5 you may have available. LWP-Protocol-http-SocketUnix/t/0000711000175000017500000000000010075432221017723 5ustar florianflorian00000000000000LWP-Protocol-http-SocketUnix/t/LWP-Protocol-http-SocketUnix.t0000600000175000017500000000077510075432112025430 0ustar florianflorian00000000000000# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl LWP-Protocol-http-SocketUnix.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test::More tests => 1; BEGIN { use_ok('LWP::Protocol::http::SocketUnix') }; ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. LWP-Protocol-http-SocketUnix/Changes0000600000175000017500000000030710075431002020747 0ustar florianflorian00000000000000Revision history for Perl extension LWP::Protocol::http::SocketUnix. 0.01 Tue Jun 8 00:24:47 2004 - original version; created by h2xs 1.23 with options -AXO -n LWP::Protocol::http::SocketUnix LWP-Protocol-http-SocketUnix/MANIFEST0000600000175000017500000000015110075431022020604 0ustar florianflorian00000000000000Changes Makefile.PL MANIFEST README t/LWP-Protocol-http-SocketUnix.t lib/LWP/Protocol/http/SocketUnix.pm