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