home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Acorn User 10
/
AU_CD10.iso
/
Updates
/
Perl
/
Perl_Libs
/
site_perl
/
LWP
/
Protocol
/
nntp.pm
< prev
Wrap
Text File
|
1996-07-08
|
6KB
|
208 lines
#
# $Id: nntp.pm,v 1.5 1996/07/08 13:37:01 aas Exp $
# Implementation of the Network News Transfer Protocol (RFC 977)
#
package LWP::Protocol::nntp;
require LWP::Protocol;
@ISA = qw(LWP::Protocol);
require LWP::Socket;
require LWP::Debug;
require HTTP::Request;
require HTTP::Response;
use HTTP::Status ();
use strict;
use vars qw($NNTP_SERVER $NNTP_PORT);
$NNTP_SERVER = $ENV{NNTP_SERVER} || "news";
$NNTP_PORT = 119;
sub request
{
my($self, $request, $proxy, $arg, $size, $timeout) = @_;
LWP::Debug::trace('()');
$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->url;
my $scheme = $url->scheme;
unless ($scheme eq 'news') {
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 'news:' URLs");
}
# extract the identifier and check against posting to an article
my $groupart = $url->groupart;
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>");
}
# Create a socket and connect to the NNTP server. We use our own
# specialization of the LWP::Socket class. This new class is defined
# below.
my $nntp = new LWP::Protocol::nntp::Socket; # What an ugly name
$nntp->connect($NNTP_SERVER, $NNTP_PORT);
# Check the initial welcome message from the NNTP server
if ($nntp->response($timeout) != 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;
LWP::Debug::debug($mess);
# Try to extract server name from greating 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') {
$request->header("Newsgroups", $groupart)
unless $request->header("Newsgroups");
if ($nntp->cmd("POST") != 3) {
return HTTP::Response->new(&HTTP::Status::RC_FORBIDDEN,
$nntp->message);
}
$nntp->write($request->headers_as_string("\015\012") . "\015\012");
my $content = $request->content;
$content =~ s/^\./../gm; # must escape "." at the beginning of lies
$nntp->write($content);
$nntp->write("\015\012.\015\012"); # Terminate message
if ($nntp->response != 2) {
return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
$nntp->message);
}
$response->code(&HTTP::Status::RC_ACCEPTED);
$response->message($nntp->message);
return $response;
}
# The method must be "GET" or "HEAD" by now
if (!$is_art) {
if ($nntp->cmd("GROUP $groupart") != 2) {
return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
$nntp->message);
}
return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
"GET newsgroup not implemented yet");
}
# Send command to server to retrieve an article (or just the headers)
my $cmd = ($method eq 'HEAD' ? 'HEAD' : 'ARTICLE') . " <$groupart>";
if ($nntp->cmd($cmd, $timeout) != 2) {
return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
$nntp->message);
}
LWP::Debug::debug($nntp->message);
# Must read article data until ".". Here we just "fake" it using the
# read_until method. We should really use the normal read() method
# so that we are able to handle real big articles much better.
$nntp->read_until('\015?\012\.\015?\012', \$mess, $size, $timeout);
my($headers, $body) = split(/(?:\015?\012){2}/, $mess, 2);
# Parse headers
my($key, $val);
for (split(/\015?\012/, $headers)) {
if (/^(\S+):\s*(.*)/) {
$response->push_header($key, $val) if $key;
($key, $val) = ($1, $2);
} elsif (/^\s+(.*)/) {
next unless $key;
$val .= $1;
}
}
$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
if (defined $body) {
$body =~ s/\r//g;
$body =~ s/^\.\././gm;
$response = $self->collect_once($arg, $response, $body);
}
# Say godbye to the server
$nntp->cmd("QUIT");
$nntp = undef;
$response;
}
# Out special NNTP socket class. This is just like LWP::Sockets, but
# implement a few new methods.
#
# $sock->cmd("CMD", $timeout); # Sends command to server and return the
# # first digit of the response code
#
# $sock->response($timeout); # Read response line from server and
# # return first digit of the response code.
#
# $sock->code # Return the full response code (last one)
# $sock->message # Return response message.
#
package LWP::Protocol::nntp::Socket;
use vars qw(@ISA);
@ISA = qw(LWP::Socket);
sub cmd {
my($self, $cmd, $timeout) = @_;
$self->write("$cmd\015\012", $timeout);
$self->response($timeout);
}
sub response {
my($self, $timeout) = shift;
my $resp;
$self->read_until("\015?\012", \$resp, undef, $timeout);
$resp =~ s/^(\d{3})\s*//;
my $code = $1;
$self->{nntp_message} = $resp;
$self->{nntp_code} = $code;
substr($code, 0, 1);
}
sub message { shift->{'nntp_message'}; }
sub code { shift->{'nntp_code'}; }
package LWP::Protocol::nntp;
1;