package LWP::Protocol::http::SocketUnix;

use strict;
use warnings;
use vars qw( @ISA $VERSION );
use IO::Socket;
use LWP::Debug ();
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, E<lt>flora@cpan.orgE<gt>

=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