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