home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _01934e8641a72b04a61ff3a85fbd2987 < prev    next >
Text File  |  2000-03-15  |  4KB  |  143 lines
  1. #
  2. # $Id: nntp.pm,v 1.8 1998/11/19 21:45:02 aas 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') {
  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 'news:' 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(undef,
  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 greating 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.  
  84.     # First we handle posting of articles
  85.     if ($method eq 'POST') {
  86.     return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  87.                    "POST not implemented yet");
  88.     }
  89.  
  90.     # The method must be "GET" or "HEAD" by now
  91.     if (!$is_art) {
  92.     if (!$nntp->group($groupart)) {
  93.         return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  94.                        $nntp->message);
  95.     }
  96.     return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  97.                    "GET newsgroup not implemented yet");
  98.     }
  99.  
  100.     # Send command to server to retrieve an article (or just the headers)
  101.     my $get = $method eq 'HEAD' ? "head" : "article";
  102.     my $art = $nntp->$get("<$groupart>");
  103.     unless ($art) {
  104.     return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  105.                    $nntp->message);
  106.     }
  107.     LWP::Debug::debug($nntp->message);
  108.     
  109.     # Parse headers
  110.     my($key, $val);
  111.     while ($_ = shift @$art) {
  112.     if (/^\s+$/) {
  113.         last;  # end of headers
  114.     } elsif (/^(\S+):\s*(.*)/) {
  115.         $response->push_header($key, $val) if $key;
  116.         ($key, $val) = ($1, $2);
  117.     } elsif (/^\s+(.*)/) {
  118.         next unless $key;
  119.         $val .= $1;
  120.     } else {
  121.         unshift(@$art, $_);
  122.         last;
  123.     }
  124.     }
  125.     $response->push_header($key, $val) if $key;
  126.  
  127.     # Ensure that there is a Content-Type header
  128.     $response->header("Content-Type", "text/plain")
  129.     unless $response->header("Content-Type");
  130.  
  131.     # Collect the body
  132.     $response = $self->collect_once($arg, $response, join("", @$art))
  133.       if @$art;
  134.  
  135.     # Say godbye to the server
  136.     $nntp->quit;
  137.     $nntp = undef;
  138.  
  139.     $response;
  140. }
  141.  
  142. 1;
  143.