# -*- perl -*-
# $Id: http.pm,v 1.13 2003/03/11 16:49:35 langhein Exp $
# derived from: http10.pm,v 1.1 2001/10/26 17:27:19 gisle Exp $

package LWP::Parallel::Protocol::http;

use strict;

require LWP::Debug;
require HTTP::Response;
require HTTP::Status;
require Net::HTTP;
require IO::Socket;
require IO::Select;
use Carp ();

use vars qw(@ISA @EXTRA_SOCK_OPTS);

require LWP::Parallel::Protocol;
require LWP::Protocol::http10; # until i figure out gisle's http1.1 stuff!
@ISA = qw(LWP::Parallel::Protocol LWP::Protocol::http10);

my $CRLF         = "\015\012";     # how lines should be terminated;
				   # "\r\n" is not correct on all systems, for
				   # instance MacPerl defines it to "\012\015"

# The following 4 methods are more or less a simple breakdown of the
# original $http->request method:
=item ($socket, $fullpath) = $prot->handle_connect ($req, $proxy, $timeout);

This method connects with the server on the machine and port specified
in the $req object. If a $proxy is given, it will translate the
request into an appropriate proxy-request and return the new URL in
the $fullpath argument.

$socket is either an IO::Socket object (in parallel mode), or a
LWP::Socket object (when used via Std. non-parallel modules, such as
LWP::UserAgent) 

=cut

sub handle_connect {
    my ($self, $request, $proxy, $timeout, $nonblock) = @_;

    # check method
    my $method = $request->method;
    unless ($method =~ /^[A-Za-z0-9_!\#\$%&\'*+\-.^\`|~]+$/) {  # HTTP token
	return (undef, new HTTP::Response &HTTP::Status::RC_BAD_REQUEST,
				  'Library does not allow method ' .
				  "$method for 'http:' URLs");
    }

    my $url = $request->url;
    my($host, $port, $fullpath) = $self->get_address ($proxy, $url, $method);

   # connect to remote site
    my $socket = $self->_connect ($host, $port, $timeout, $nonblock);

#  LWP::Debug::debug("Socket is $socket");

# get LINGER get it!
#    my $data = $socket->sockopt(13);  #define SO_LINGER = 13
#    my @a_data = unpack ("ii",$data);
#    $a_data[0] = 1; $a_data[1] = 0;
#    $data = pack ("ii",@a_data);
#
#    $socket->sockopt(13, $data);  #define SO_LINGER = 13    
#    my $newdata = $socket->sockopt(13);  #define SO_LINGER = 13    
#    @a_data = unpack ("ii",$newdata);
#
#    print "Socket $socket: SO_LINGER (", $a_data[0],", ",$a_data[1],")\n";
# got Linger got it!


    ($socket, $fullpath);
}

sub get_address {
    my ($self, $proxy, $url,$method) = @_;
    my($host, $port, $fullpath);

    # Check if we're proxy'ing
    if (defined $proxy) {
	# $proxy is an URL to an HTTP server which will proxy this request
	$host = $proxy->host;
	$port = $proxy->port;
	$fullpath = $method && ($method eq "CONNECT") ?
                    ($url->host . ":" . $url->port) :
                     $url->as_string;
    }
    else {
	$host = $url->host;
	$port = $url->port;
	$fullpath = $url->path_query;
	$fullpath = "/" unless length $fullpath;
    }
    ($host, $port, $fullpath);
}

sub _connect { # renamed to make clear that this is private sub
    my ($self, $host, $port, $timeout, $nonblock) = @_;
    my ($socket); 
    unless ($nonblock) { 
      # perform good ol' blocking behavior
      # 
      # this method inherited from LWP::Protocol::http
      $socket = $self->_new_socket($host, $port, $timeout);
      # currently empty function in LWP::Protocol::http
      # $self->_check_sock($request, $socket);
    } else { 
      # new non-blocking behavior
      #
      # thanks to http://www.en-directo.net/mail/kirill.html
      use Socket();
      use POSIX();
      $socket = 
        IO::Socket::INET->new(Proto => 'tcp', # Timeout => $timeout,
	                      $self->_extra_sock_opts ($host, $port));

      die "Can't create socket for $host:$port ($@)" unless $socket;
      unless ( defined $socket->blocking (0) )
      {
	# IO::Handle::blocking doesn't (yet?) work on Win32 (ActiveState port)
	# The following happens to work though.
	# See also: perlport manpage, POE::Kernel, POE::Wheel::SocketFactory,
	#   Winsock2.h
	if ( $^O eq 'MSWin32' )
	{
	  my $set_it = "1";
	  my $ioctl_val = 0x80000000 | (4 << 16) | (ord('f') << 8) | 126;
  	  $ioctl_val = ioctl ($socket, $ioctl_val, $set_it);
#	warn 'Win32 ioctl returned ' . (defined $ioctl_val ? $ioctl_val : '[undef]') . "\n";
#	warn "Win32 ioctlsocket failed\n" unless $ioctl_val;
	}
      }
      my $rhost = Socket::inet_aton ($host);
      die "Bad hostname $host" unless defined $rhost;
      unless ( $socket->connect ($port, $rhost) )
      {
	my $err = $! + 0;
	# More trouble with ActiveState: EINPROGRESS and EWOULDBLOCK
	# are missing from POSIX.pm. See Microsoft's Winsock2.h
	my ($einprogress, $ewouldblock) = $^O eq 'MSWin32' ?
		(10036, 10035) : (POSIX::EINPROGRESS(), POSIX::EWOULDBLOCK());
	die "Can't connect to $host:$port ($@)"
		if $err and $err != $einprogress and $err != $ewouldblock;
      } 
    }
    LWP::Debug::debug("Socket is $socket");
    $socket;
}

sub write_request {
  my ($self, $request, $socket, $fullpath, $arg, $timeout, $proxy) = @_;

  my $method = $request->method;
  my $url    = $request->url;

 LWP::Debug::trace ("write_request (".
		    (defined $request ? $request : '[undef]').
		    ", ". (defined $socket ? $socket : '[undef]').
		    ", ". (defined $fullpath ? $fullpath : '[undef]').
		    ", ". (defined $arg ? $arg : '[undef]').
		    ", ". (defined $timeout ? $timeout : '[undef]'). 
		    ", ". (defined $proxy ? $proxy : '[undef]'). ")");

  my $sel = IO::Select->new($socket) if $timeout;

  my $request_line = "$method $fullpath HTTP/1.0$CRLF";
  
  my $h = $request->headers->clone;
  my $cont_ref = $request->content_ref;
  $cont_ref = $$cont_ref if ref($$cont_ref);
  my $ctype = ref($cont_ref);

  # If we're sending content we *have* to specify a content length
  # otherwise the server won't know a messagebody is coming.
  if ($ctype eq 'CODE') {
    die 'No Content-Length header for request with dynamic content'
      unless defined($h->header('Content-Length')) ||
	$h->content_type =~ /^multipart\//;
    # For HTTP/1.1 we could have used chunked transfer encoding...
  } 
  else {
    $h->header('Content-Length' => length $$cont_ref)
      if defined($$cont_ref) && length($$cont_ref);
  }  
    
  $self->_fixup_header($h, $url, $proxy);

  my $buf = $request_line . $h->as_string($CRLF) . $CRLF;
  my $n;  # used for return value from syswrite/sysread
  my $length;
  my $offset;

  # die's will be caught if user specified "use_eval".

  # syswrite $buf
  $length = length($buf);
  $offset = 0;
  while ( $offset < $length ) {
	die "write timeout" if $timeout && !$sel->can_write($timeout);
	$n = $socket->syswrite($buf, $length-$offset, $offset );
	die $! unless defined($n);
	$offset += $n;
  }
 
  LWP::Debug::conns($buf);
  
  if ($ctype eq 'CODE') {
    while ( ($buf = &$cont_ref()), defined($buf) && length($buf)) {
      # syswrite $buf
      $length = length($buf);
      $offset = 0;
      while ( $offset < $length ) {
	die "write timeout" if $timeout && !$sel->can_write($timeout);
	$n = $socket->syswrite($buf, $length-$offset, $offset );
	die $! unless defined($n);
	$offset += $n;
      }
      LWP::Debug::conns($buf);
    }
  } 
  elsif (defined($$cont_ref) && length($$cont_ref)) {
    # syswrite $$cont_ref
    $length = length($$cont_ref);
    $offset = 0;
    while ( $offset < $length ) {
      die "write timeout" if $timeout && !$sel->can_write($timeout);
      $n = $socket->syswrite($$cont_ref, $length-$offset, $offset );
      die $! unless defined($n);
      $offset += $n;
    }
    LWP::Debug::conns($buf);
  }
  
  # For an HTTP request, the 'command' socket is the same as the
  # 'listen' socket, so we just return the socket here.
  # (In the ftp module, we usually have one socket being the command
  # socket, and another one being the read socket, so that's why we
  # have this overhead here)
  return $socket;
}

# whereas 'handle_connect' (with its submethods 'get_address' and
# 'connect') and 'write_request' mainly just encapsulate different
# parts of the old http->request method, 'read_chunk' has an added
# level of complexity. This is because we have to be content with
# whatever data is available, and somehow 'save' our current state
# between multiple calls.

# To faciliate things later, when we need redirects and
# authentication, we insist that we _always_ have a response object
# available, which is generated outside and initialized with bogus
# data (code = 0). Also, we can then save ourselves the trouble of
# using a call-by-variable for $response in order to return a freshly
# generated $response-object.

# We have to provide IO::Socket-objects with a pushback mechanism,
# which comes pretty handy in case we can't use all the information read
# so far. Instead of changing the IO::Socket code, we just have our own
# little pushback buffer, $pushback, indexed by $socket object here.

my %pushback;

sub read_chunk {
  my ($self, $response, $socket, $request, $arg, $size, 
      $timeout, $entry) = @_;

 LWP::Debug::trace ("read_chunk (".
		    (defined $response ? $response : '[undef]').
		    ", ". (defined $socket ? $socket : '[undef]').
		    ", ". (defined $request ? $request : '[undef]').
		    ", ". (defined $arg ? $arg : '[undef]').
		    ", ". (defined $size ? $size : '[undef]').
		    ", ". (defined $timeout ? $timeout : '[undef]').
		    ", ". (defined $entry ? $entry : '[undef]'). ")");

  # hack! Can we just generate a new Select object here? Or do we
  # have to take the one we created in &write_request?!?
  my $sel = IO::Select->new($socket) if $timeout;

  LWP::Debug::debug('reading response ('. 
    (defined($pushback{$socket})?length($pushback{$socket}):0) .' buffered)');

  my $buf = "";
  # read one chunk at a time from $socket
  
  if ( $timeout && !$sel->can_read($timeout) ) {
      $response->message("Read Timeout");
      $response->code(&HTTP::Status::RC_REQUEST_TIMEOUT);
      $response->request($request);
      return 0; # EOF
  };
  my $n = $socket->sysread($buf, $size, length($buf));
  unless (defined ($n)) {
      $response->message("Sysread Error: $!"); 
      $response->code(&HTTP::Status::RC_SERVICE_UNAVAILABLE);
      $response->request($request);
      return 0; # EOF
  };
  # need our own EOF detection here
  unless ( $n ) {
      unless ($response  and  $response->code) {
	  $response->message("Unexpected EOF while reading response");
	  $response->code(&HTTP::Status::RC_BAD_GATEWAY);
	  $response->request($request);
	  return 0; # EOF
      }
  }

  # prepend contents of unprocessed buffer content from last read
  $buf = $pushback{$socket} . $buf if $pushback{$socket};
  LWP::Debug::conns("Buffer contents between dashes -->\n==========\n$buf==========");
  
  # determine Protocol type and create response object
  unless ($response  and  $response->code) {
    if ($buf =~ s/^(HTTP\/\d+\.\d+)[ \t]+(\d+)[ \t]*([^\012]*)\012//) { #1.39
      # HTTP/1.0 response or better
      my($ver,$code,$msg) = ($1, $2, $3);
      $msg =~ s/\015$//;
      LWP::Debug::debug("Identified HTTP Protocol: $ver $code $msg");
      $response->code($code);
      $response->message($msg);
      $response->protocol($ver);
      # store $request info in $response object
      $response->request($request);
    } 
    elsif ((length($buf) >= 5 and $buf !~ /^HTTP\//) or
	     $buf =~ /\012/ ) {
      # HTTP/0.9 or worse
      LWP::Debug::debug("HTTP/0.9 assume OK");
      $response->code(&HTTP::Status::RC_OK);
      $response->message("OK");
      $response->protocol('HTTP/0.9');
      # store $request info in $response object
      $response->request($request);
    } 
    else {
      # need more data
      LWP::Debug::debug("need more data to know which protocol");
    }
  }
  
  # if we have a protocol, read headers if neccessary
  if ( $response && !&headers($response) ) {
    # ensure that we have read all headers.  The headers will be
    # terminated by two blank lines
    unless ($buf =~ /^\015?\012/ || $buf =~ /\015?\012\015?\012/) {
      # must read more if we can...
      LWP::Debug::debug("need more data for headers");
    } else {
      # now we start parsing the headers.  The strategy is to
      # remove one line at a time from the beginning of the header
      # buffer ($buf).
      my($key, $val);

      while ($buf =~ s/([^\012]*)\012//) {
	my $line = $1;

	# if we need to restore as content when illegal headers
	# are found.
	my $save = "$line\012"; 
	
	$line =~ s/\015$//;
	last unless length $line;
	
	if ($line =~ /^([a-zA-Z0-9_\-.]+)\s*:\s*(.*)/) {
	  $response->push_header($key, $val) if $key;
	  ($key, $val) = ($1, $2);
	} elsif ($line =~ /^\s+(.*)/ && $key) {
	  $val .= " $1"; 
	} else {
	    $response->push_header("Client-Bad-Header-Line" =>
			           $line);
	}
      }
      $response->push_header($key, $val) if $key;

      # check to see if we have any header at all
      unless (&headers($response)) {
	# we need at least one header to go on
        LWP::Debug::debug("no headers found, inserting Client-Date");
	$response->header ("Client-Date" => 
			   HTTP::Date::time2str(time));
      }
    } # of if then else
  } # of if $response
  
  # if we have both a response AND the headers, start parsing the rest
  if ( $response && &headers($response) && length($buf)) {
    $self->_get_sock_info($response, $socket); 
    # the CONNECT method does not need to read content
    if ($request->method eq "CONNECT") { # from LWP 5.48's Protocol/http.pm
	$response->{client_socket} = $socket;  # so it can be picked up
    }  
    else {
      # all other methods want to read content, I guess...
      # Note that we can't use $self->collect, since we don't want to give
      # up control (by letting Protocol::collect use a $collector callback)
      if (my @te = $response->remove_header('Transfer-Encoding')) {
        $response->push_header('Client-Transfer-Encoding', \@te);
      }
      my $retval = $self->receive($arg, $response, \$buf, $entry);
      # update pushback buffer (receive handles _all_ of current buffer)
      $pushback{$socket} = '';
      # return length of response read (or value of $retval, if any, which
      # could be one of C_LASTCON, C_ENDCON, or C_ENDALL)
      return (defined $retval? $retval : length($buf));
    }
  }
  
  $pushback{$socket} = $buf;
  return $n;
}

# This function indicates if we have already parsed the headers.  In
# case of HTTP/0.9 we (obviously?!) don't have any (which means that
# we already 'parsed' them, so return 'true' no matter what)

sub headers {
    my ($response) = @_;

    return 1  if $response->protocol eq 'HTTP/0.9';

    ($response->headers_as_string ? 1 : 0);
}

sub close_connection {
  my ($self, $response, $listen_socket, $request, $cmd_socket) = @_;
#  print "Closing socket $listen_socket\n";
#  $listen_socket->close;
#  $cmd_socket->close;
}

# the old (single request) frontend, defunct.
sub request {
    die "LWP::Parallel::Protocol::http does not support single requests\n";
}


#-----------------------------------------------------------
# copied from LWP::Protocol::http (v1.63 in LWP5.64)
#-----------------------------------------------------------
package LWP::Parallel::Protocol::http::SocketMethods;

sub sysread {
    my $self = shift;
    if (my $timeout = ${*$self}{io_socket_timeout}) {
	die "read timeout" unless $self->can_read($timeout);
    }
    else {
	# since we have made the socket non-blocking we
	# use select to wait for some data to arrive
	$self->can_read(undef) || die "Assert";
    }
    sysread($self, $_[0], $_[1], $_[2] || 0);
}

sub can_read {
    my($self, $timeout) = @_;
    my $fbits = '';
    vec($fbits, fileno($self), 1) = 1;
    my $nfound = select($fbits, undef, undef, $timeout);
    die "select failed: $!" unless defined $nfound;
    return $nfound > 0;
}

sub ping {
    my $self = shift;
    !$self->can_read(0);
}

sub increment_response_count {
    my $self = shift;
    return ++${*$self}{'myhttp_response_count'};
}

#-----------------------------------------------------------
package LWP::Parallel::Protocol::http::Socket;
use vars qw(@ISA);
@ISA = qw(LWP::Parallel::Protocol::http::SocketMethods Net::HTTP);

#-----------------------------------------------------------
# ^^^ copied from LWP::Protocol::http (v1.63 in LWP5.64)
#-----------------------------------------------------------


1;