local-lib5/lib/perl5/LWP/Protocol/nntp.pm

   1 package LWP::Protocol::nntp;
   2
   3 # Implementation of the Network News Transfer Protocol (RFC 977)
   4
   5 require LWP::Protocol;
   6 @ISA = qw(LWP::Protocol);
   7
   8 require HTTP::Response;
   9 require HTTP::Status;
  10 require Net::NNTP;
  11
  12 use strict;
  13
  14
  15 sub request
  16 {
  17     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  18
  19     $size = 4096 unless $size;
  20
  21     # Check for proxy
  22     if (defined $proxy) {
  23         return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  24                                    'You can not proxy through NNTP');
  25     }
  26
  27     # Check that the scheme is as expected
  28     my $url = $request->uri;
  29     my $scheme = $url->scheme;
  30     unless ($scheme eq 'news' || $scheme eq 'nntp') {
  31         return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  32                                    "LWP::Protocol::nntp::request called for '$scheme'");
  33     }
  34
  35     # check for a valid method
  36     my $method = $request->method;
  37     unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
  38         return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  39                                    'Library does not allow method ' .
  40                                    "$method for '$scheme:' URLs");
  41     }
  42
  43     # extract the identifier and check against posting to an article
  44     my $groupart = $url->_group;
  45     my $is_art = $groupart =~ /@/;
  46
  47     if ($is_art && $method eq 'POST') {
  48         return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  49                                    "Can't post to an article <$groupart>");
  50     }
  51
  52     my $nntp = Net::NNTP->new($url->host,
  53                               #Port    => 18574,
  54                               Timeout => $timeout,
  55                               #Debug   => 1,
  56                              );
  57     die "Can't connect to nntp server" unless $nntp;
  58
  59     # Check the initial welcome message from the NNTP server
  60     if ($nntp->status != 2) {
  61         return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
  62                                    $nntp->message);
  63     }
  64     my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  65
  66     my $mess = $nntp->message;
  67
  68     # Try to extract server name from greeting message.
  69     # Don't know if this works well for a large class of servers, but
  70     # this works for our server.
  71     $mess =~ s/\s+ready\b.*//;
  72     $mess =~ s/^\S+\s+//;
  73     $response->header(Server => $mess);
  74
  75     # First we handle posting of articles
  76     if ($method eq 'POST') {
  77         $nntp->quit; $nntp = undef;
  78         $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
  79         $response->message("POST not implemented yet");
  80         return $response;
  81     }
  82
  83     # The method must be "GET" or "HEAD" by now
  84     if (!$is_art) {
  85         if (!$nntp->group($groupart)) {
  86             $response->code(&HTTP::Status::RC_NOT_FOUND);
  87             $response->message($nntp->message);
  88         }
  89         $nntp->quit; $nntp = undef;
  90         # HEAD: just check if the group exists
  91         if ($method eq 'GET' && $response->is_success) {
  92             $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
  93             $response->message("GET newsgroup not implemented yet");
  94         }
  95         return $response;
  96     }
  97
  98     # Send command to server to retrieve an article (or just the headers)
  99     my $get = $method eq 'HEAD' ? "head" : "article";
 100     my $art = $nntp->$get("<$groupart>");
 101     unless ($art) {
 102         $nntp->quit; $nntp = undef;
 103         $response->code(&HTTP::Status::RC_NOT_FOUND);
 104         $response->message($nntp->message);
 105         return $response;
 106     }
 107
 108     # Parse headers
 109     my($key, $val);
 110     local $_;
 111     while ($_ = shift @$art) {
 112         if (/^\s+$/) {
 113             last;  # end of headers
 114         }
 115         elsif (/^(\S+):\s*(.*)/) {
 116             $response->push_header($key, $val) if $key;
 117             ($key, $val) = ($1, $2);
 118         }
 119         elsif (/^\s+(.*)/) {
 120             next unless $key;
 121             $val .= $1;
 122         }
 123         else {
 124             unshift(@$art, $_);
 125             last;
 126         }
 127     }
 128     $response->push_header($key, $val) if $key;
 129
 130     # Ensure that there is a Content-Type header
 131     $response->header("Content-Type", "text/plain")
 132         unless $response->header("Content-Type");
 133
 134     # Collect the body
 135     $response = $self->collect_once($arg, $response, join("", @$art))
 136       if @$art;
 137
 138     # Say goodbye to the server
 139     $nntp->quit;
 140     $nntp = undef;
 141
 142     $response;
 143 }
 144
 145 1;