home *** CD-ROM | disk | FTP | other *** search
/ isnet Internet / Isnet Internet CD.iso / prog / hiz / 09 / 09.exe / adynware.exe / perl / lib / site / LWP / Protocol / nntp.pm < prev   
Encoding:
Perl POD Document  |  1999-12-28  |  4.4 KB  |  171 lines
  1.  
  2.  
  3. package LWP::Protocol::nntp;
  4.  
  5. require LWP::Protocol;
  6. @ISA = qw(LWP::Protocol);
  7.  
  8. require LWP::Socket;
  9. require LWP::Debug;
  10.  
  11. require HTTP::Request;
  12. require HTTP::Response;
  13. use HTTP::Status ();
  14.  
  15. use strict;
  16. use vars qw($NNTP_SERVER $NNTP_PORT);
  17.  
  18. $NNTP_SERVER = $ENV{NNTP_SERVER} || "news";
  19. $NNTP_PORT   = 119;
  20.  
  21.  
  22. sub request
  23. {
  24.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  25.  
  26.     LWP::Debug::trace('()');
  27.  
  28.     $size = 4096 unless $size;
  29.  
  30.     if (defined $proxy) {
  31.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  32.                    'You can not proxy through NNTP');
  33.     }
  34.  
  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.     my $method = $request->method;
  43.     unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
  44.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  45.                    'Library does not allow method ' .
  46.                    "$method for 'news:' URLs");
  47.     }
  48.  
  49.     my $groupart = $url->groupart;
  50.     my $is_art = $groupart =~ /@/;
  51.  
  52.     if ($is_art && $method eq 'POST') {
  53.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  54.                    "Can't post to an article <$groupart>");
  55.     }
  56.  
  57.     my $nntp = new LWP::Protocol::nntp::Socket;  # What an ugly name
  58.     $nntp->connect($NNTP_SERVER, $NNTP_PORT);
  59.  
  60.     if ($nntp->response($timeout) != 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.     LWP::Debug::debug($mess);
  68.  
  69.     $mess =~ s/\s+ready\b.*//;
  70.     $mess =~ s/^\S+\s+//;
  71.     $response->header('Server', $mess);
  72.  
  73.     if ($method eq 'POST') {
  74.     $request->header("Newsgroups", $groupart)
  75.         unless $request->header("Newsgroups");
  76.     if ($nntp->cmd("POST") != 3) {
  77.         return HTTP::Response->new(&HTTP::Status::RC_FORBIDDEN,
  78.                        $nntp->message);
  79.     }
  80.     $nntp->write($request->headers_as_string("\015\012") . "\015\012");
  81.     my $content = $request->content;
  82.     $content =~ s/^\./../gm;  # must escape "." at the beginning of lies
  83.     $nntp->write($content);
  84.     $nntp->write("\015\012.\015\012");     # Terminate message
  85.     if ($nntp->response != 2) {
  86.         return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  87.                        $nntp->message);
  88.     }
  89.     $response->code(&HTTP::Status::RC_ACCEPTED);
  90.     $response->message($nntp->message);
  91.     return $response;
  92.     }
  93.  
  94.     if (!$is_art) {
  95.     if ($nntp->cmd("GROUP $groupart") != 2) {
  96.         return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  97.                        $nntp->message);
  98.     }
  99.     return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  100.                    "GET newsgroup not implemented yet");
  101.     }
  102.  
  103.     my $cmd = ($method eq 'HEAD' ? 'HEAD' : 'ARTICLE') . " <$groupart>";
  104.     if ($nntp->cmd($cmd, $timeout) != 2) {
  105.     return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  106.                    $nntp->message);
  107.     }
  108.     LWP::Debug::debug($nntp->message);
  109.  
  110.     $nntp->read_until('\015?\012\.\015?\012', \$mess, $size, $timeout);
  111.  
  112.     my($headers, $body) = split(/(?:\015?\012){2}/, $mess, 2);
  113.  
  114.     my($key, $val);
  115.     for (split(/\015?\012/, $headers)) {
  116.     if (/^(\S+):\s*(.*)/) {
  117.         $response->push_header($key, $val) if $key;
  118.         ($key, $val) = ($1, $2);
  119.     } elsif (/^\s+(.*)/) {
  120.         next unless $key;
  121.         $val .= $1;
  122.     }
  123.     }
  124.     $response->push_header($key, $val) if $key;
  125.  
  126.     $response->header("Content-Type", "text/plain")
  127.     unless $response->header("Content-Type");
  128.  
  129.     if (defined $body) {
  130.     $body =~ s/\r//g;
  131.     $body =~ s/^\.\././gm;
  132.     $response = $self->collect_once($arg, $response, $body);
  133.     }
  134.  
  135.     $nntp->cmd("QUIT");
  136.     $nntp = undef;
  137.  
  138.     $response;
  139. }
  140.  
  141.  
  142. package LWP::Protocol::nntp::Socket;
  143. use vars qw(@ISA);
  144. @ISA = qw(LWP::Socket);
  145.  
  146. sub cmd {
  147.     my($self, $cmd, $timeout) = @_;
  148.     $self->write("$cmd\015\012", $timeout);
  149.     $self->response($timeout);
  150. }
  151.  
  152.  
  153. sub response {
  154.     my($self, $timeout) = shift;
  155.     my $resp;
  156.     $self->read_until("\015?\012", \$resp, undef, $timeout);
  157.     $resp =~ s/^(\d{3})\s*//;
  158.     my $code = $1;
  159.     $self->{nntp_message} = $resp;
  160.     $self->{nntp_code} = $code;
  161.     substr($code, 0, 1);
  162. }
  163.  
  164. sub message { shift->{'nntp_message'}; }
  165. sub code    { shift->{'nntp_code'};    }
  166.  
  167.  
  168. package LWP::Protocol::nntp;
  169.  
  170. 1;
  171.