File Content: nntp.pm package LWP::Protocol::nntp; # Implementation of the Network News Transfer Protocol (RFC 977) use base qw(LWP::Protocol); our $VERSION = '6.34'; 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; $response->code(HTTP::Status::RC_NOT_FOUND); $response->message($nntp->message); $nntp = undef; 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; Submit