1 files changed, 145 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/nntp.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/nntp.pm
new file mode 100755
index 00000000000..788477d488a
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/nntp.pm
@@ -0,0 +1,145 @@
+package LWP::Protocol::nntp;
+
+# Implementation of the Network News Transfer Protocol (RFC 977)
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+require HTTP::Response;
+require HTTP::Status;
+require Net::NNTP;
+
+use strict;
+
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    $size = 4096 unless $size;
+
+    # Check for proxy
+    if (defined $proxy) {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'You can not proxy through NNTP');
+    }
+
+    # Check that the scheme is as expected
+    my $url = $request->uri;
+    my $scheme = $url->scheme;
+    unless ($scheme eq 'news' || $scheme eq 'nntp') {
+	return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+				   "LWP::Protocol::nntp::request called for '$scheme'");
+    }
+
+    # check for a valid method
+    my $method = $request->method;
+    unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   'Library does not allow method ' .
+				   "$method for '$scheme:' URLs");
+    }
+
+    # extract the identifier and check against posting to an article
+    my $groupart = $url->_group;
+    my $is_art = $groupart =~ /@/;
+
+    if ($is_art && $method eq 'POST') {
+	return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+				   "Can't post to an article <$groupart>");
+    }
+
+    my $nntp = Net::NNTP->new($url->host,
+			      #Port    => 18574,
+			      Timeout => $timeout,
+			      #Debug   => 1,
+			     );
+    die "Can't connect to nntp server" unless $nntp;
+
+    # Check the initial welcome message from the NNTP server
+    if ($nntp->status != 2) {
+	return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
+				   $nntp->message);
+    }
+    my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+
+    my $mess = $nntp->message;
+
+    # Try to extract server name from greeting message.
+    # Don't know if this works well for a large class of servers, but
+    # this works for our server.
+    $mess =~ s/\s+ready\b.*//;
+    $mess =~ s/^\S+\s+//;
+    $response->header(Server => $mess);
+
+    # First we handle posting of articles
+    if ($method eq 'POST') {
+	$nntp->quit; $nntp = undef;
+	$response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+	$response->message("POST not implemented yet");
+	return $response;
+    }
+
+    # The method must be "GET" or "HEAD" by now
+    if (!$is_art) {
+	if (!$nntp->group($groupart)) {
+	    $response->code(&HTTP::Status::RC_NOT_FOUND);
+	    $response->message($nntp->message);
+	}
+	$nntp->quit; $nntp = undef;
+	# HEAD: just check if the group exists
+	if ($method eq 'GET' && $response->is_success) {
+	    $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+	    $response->message("GET newsgroup not implemented yet");
+	}
+	return $response;
+    }
+
+    # Send command to server to retrieve an article (or just the headers)
+    my $get = $method eq 'HEAD' ? "head" : "article";
+    my $art = $nntp->$get("<$groupart>");
+    unless ($art) {
+	$nntp->quit; $nntp = undef;
+	$response->code(&HTTP::Status::RC_NOT_FOUND);
+	$response->message($nntp->message);
+	return $response;
+    }
+
+    # Parse headers
+    my($key, $val);
+    local $_;
+    while ($_ = shift @$art) {
+	if (/^\s+$/) {
+	    last;  # end of headers
+	}
+	elsif (/^(\S+):\s*(.*)/) {
+	    $response->push_header($key, $val) if $key;
+	    ($key, $val) = ($1, $2);
+	}
+	elsif (/^\s+(.*)/) {
+	    next unless $key;
+	    $val .= $1;
+	}
+	else {
+	    unshift(@$art, $_);
+	    last;
+	}
+    }
+    $response->push_header($key, $val) if $key;
+
+    # Ensure that there is a Content-Type header
+    $response->header("Content-Type", "text/plain")
+	unless $response->header("Content-Type");
+
+    # Collect the body
+    $response = $self->collect_once($arg, $response, join("", @$art))
+      if @$art;
+
+    # Say goodbye to the server
+    $nntp->quit;
+    $nntp = undef;
+
+    $response;
+}
+
+1;