home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl_ste.zip / LWP / Protocol / nntp.pm < prev   
Text File  |  1996-07-08  |  6KB  |  208 lines
  1. #
  2. # $Id: nntp.pm,v 1.5 1996/07/08 13:37:01 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::Socket;
  13. require LWP::Debug;
  14.  
  15. require HTTP::Request;
  16. require HTTP::Response;
  17. use HTTP::Status ();
  18.  
  19. use strict;
  20. use vars qw($NNTP_SERVER $NNTP_PORT);
  21.  
  22. $NNTP_SERVER = $ENV{NNTP_SERVER} || "news";
  23. $NNTP_PORT   = 119;
  24.  
  25.  
  26. sub request
  27. {
  28.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  29.  
  30.     LWP::Debug::trace('()');
  31.  
  32.     $size = 4096 unless $size;
  33.  
  34.     # Check for proxy
  35.     if (defined $proxy) {
  36.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  37.                    'You can not proxy through NNTP');
  38.     }
  39.  
  40.     # Check that the scheme is as expected
  41.     my $url = $request->url;
  42.     my $scheme = $url->scheme;
  43.     unless ($scheme eq 'news') {
  44.     return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  45.                    "LWP::Protocol::nntp::request called for '$scheme'");
  46.     }
  47.  
  48.     # check for a valid method
  49.     my $method = $request->method;
  50.     unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
  51.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  52.                    'Library does not allow method ' .
  53.                    "$method for 'news:' URLs");
  54.     }
  55.  
  56.     # extract the identifier and check against posting to an article
  57.     my $groupart = $url->groupart;
  58.     my $is_art = $groupart =~ /@/;
  59.  
  60.     if ($is_art && $method eq 'POST') {
  61.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  62.                    "Can't post to an article <$groupart>");
  63.     }
  64.  
  65.     # Create a socket and connect to the NNTP server.  We use our own
  66.     # specialization of the LWP::Socket class.  This new class is defined
  67.     # below.
  68.     my $nntp = new LWP::Protocol::nntp::Socket;  # What an ugly name
  69.     $nntp->connect($NNTP_SERVER, $NNTP_PORT);
  70.  
  71.     # Check the initial welcome message from the NNTP server
  72.     if ($nntp->response($timeout) != 2) {
  73.     return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
  74.                    $nntp->message);
  75.     }
  76.     my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
  77.  
  78.     my $mess = $nntp->message;
  79.     LWP::Debug::debug($mess);
  80.  
  81.     # Try to extract server name from greating message.
  82.     # Don't know if this works well for a large class of servers, but
  83.     # this works for our server.
  84.     $mess =~ s/\s+ready\b.*//;
  85.     $mess =~ s/^\S+\s+//;
  86.     $response->header('Server', $mess);
  87.  
  88.     # First we handle posting of articles
  89.     if ($method eq 'POST') {
  90.     $request->header("Newsgroups", $groupart)
  91.         unless $request->header("Newsgroups");
  92.     if ($nntp->cmd("POST") != 3) {
  93.         return HTTP::Response->new(&HTTP::Status::RC_FORBIDDEN,
  94.                        $nntp->message);
  95.     }
  96.     $nntp->write($request->headers_as_string("\015\012") . "\015\012");
  97.     my $content = $request->content;
  98.     $content =~ s/^\./../gm;  # must escape "." at the beginning of lies
  99.     $nntp->write($content);
  100.     $nntp->write("\015\012.\015\012");     # Terminate message
  101.     if ($nntp->response != 2) {
  102.         return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  103.                        $nntp->message);
  104.     }
  105.     $response->code(&HTTP::Status::RC_ACCEPTED);
  106.     $response->message($nntp->message);
  107.     return $response;
  108.     }
  109.  
  110.     # The method must be "GET" or "HEAD" by now
  111.     if (!$is_art) {
  112.     if ($nntp->cmd("GROUP $groupart") != 2) {
  113.         return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  114.                        $nntp->message);
  115.     }
  116.     return HTTP::Response->new(&HTTP::Status::RC_NOT_IMPLEMENTED,
  117.                    "GET newsgroup not implemented yet");
  118.     }
  119.  
  120.     # Send command to server to retrieve an article (or just the headers)
  121.     my $cmd = ($method eq 'HEAD' ? 'HEAD' : 'ARTICLE') . " <$groupart>";
  122.     if ($nntp->cmd($cmd, $timeout) != 2) {
  123.     return HTTP::Response->new(&HTTP::Status::RC_NOT_FOUND,
  124.                    $nntp->message);
  125.     }
  126.     LWP::Debug::debug($nntp->message);
  127.  
  128.     # Must read article data until ".".  Here we just "fake" it using the
  129.     # read_until method.  We should really use the normal read() method
  130.     # so that we are able to handle real big articles much better.
  131.     $nntp->read_until('\015?\012\.\015?\012', \$mess, $size, $timeout);
  132.  
  133.     my($headers, $body) = split(/(?:\015?\012){2}/, $mess, 2);
  134.  
  135.     # Parse headers
  136.     my($key, $val);
  137.     for (split(/\015?\012/, $headers)) {
  138.     if (/^(\S+):\s*(.*)/) {
  139.         $response->push_header($key, $val) if $key;
  140.         ($key, $val) = ($1, $2);
  141.     } elsif (/^\s+(.*)/) {
  142.         next unless $key;
  143.         $val .= $1;
  144.     }
  145.     }
  146.     $response->push_header($key, $val) if $key;
  147.  
  148.     # Ensure that there is a Content-Type header
  149.     $response->header("Content-Type", "text/plain")
  150.     unless $response->header("Content-Type");
  151.  
  152.     # Collect the body
  153.     if (defined $body) {
  154.     $body =~ s/\r//g;
  155.     $body =~ s/^\.\././gm;
  156.     $response = $self->collect_once($arg, $response, $body);
  157.     }
  158.  
  159.     # Say godbye to the server
  160.     $nntp->cmd("QUIT");
  161.     $nntp = undef;
  162.  
  163.     $response;
  164. }
  165.  
  166. # Out special NNTP socket class.  This is just like LWP::Sockets, but
  167. # implement a few new methods.
  168. #
  169. #    $sock->cmd("CMD", $timeout);  # Sends command to server and return the
  170. #                                  # first digit of the response code
  171. #
  172. #    $sock->response($timeout);    # Read response line from server and
  173. #                                  # return first digit of the response code.
  174. #
  175. #    $sock->code                   # Return the full response code (last one)
  176. #    $sock->message                # Return response message.
  177. #
  178.  
  179. package LWP::Protocol::nntp::Socket;
  180. use vars qw(@ISA);
  181. @ISA = qw(LWP::Socket);
  182.  
  183. sub cmd {
  184.     my($self, $cmd, $timeout) = @_;
  185.     $self->write("$cmd\015\012", $timeout);
  186.     $self->response($timeout);
  187. }
  188.  
  189.  
  190. sub response {
  191.     my($self, $timeout) = shift;
  192.     my $resp;
  193.     $self->read_until("\015?\012", \$resp, undef, $timeout);
  194.     $resp =~ s/^(\d{3})\s*//;
  195.     my $code = $1;
  196.     $self->{nntp_message} = $resp;
  197.     $self->{nntp_code} = $code;
  198.     substr($code, 0, 1);
  199. }
  200.  
  201. sub message { shift->{'nntp_message'}; }
  202. sub code    { shift->{'nntp_code'};    }
  203.  
  204.  
  205. package LWP::Protocol::nntp;
  206.  
  207. 1;
  208.