"Fossies" - the Fresh Open Source Software Archive

Member "libwww-perl-6.43/lib/LWP/Protocol/nntp.pm" (26 Nov 2019, 4196 Bytes) of package /linux/www/libwww-perl-6.43.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "nntp.pm" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 6.42_vs_6.43.

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