Add the original source packages to maemo, source lenny

[dh-make-perl] / dev / i386 / libwww-perl / libwww-perl-5.813 / lib / LWP / Protocol / nntp.pm

diff --git a/dev/i386/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/nntp.pm b/dev/i386/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/nntp.pm
new file mode 100644 (file)
index 0000000..7bf5286
--- /dev/null
+++ b/dev/i386/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/nntp.pm
@@ -0,0 +1,150 @@
+package LWP::Protocol::nntp;
+
+# Implementation of the Network News Transfer Protocol (RFC 977)
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+require LWP::Debug;
+require HTTP::Response;
+require HTTP::Status;
+require Net::NNTP;
+
+use strict;
+
+
+sub request
+{
+    my($self, $request, $proxy, $arg, $size, $timeout) = @_;
+
+    LWP::Debug::trace('()');
+
+    $size = 4096 unless $size;
+
+    # Check for proxy
+    if (defined $proxy) {
+       return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+                                  'You can not proxy through NNTP');
+    }
+
+    # Check that the scheme is as expected
+    my $url = $request->url;
+    my $scheme = $url->scheme;
+    unless ($scheme eq 'news' || $scheme eq 'nntp') {
+       return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
+                                  "LWP::Protocol::nntp::request called for '$scheme'");
+    }
+
+    # check for a valid method
+    my $method = $request->method;
+    unless ($method eq 'GET' || $method eq 'HEAD' || $method eq 'POST') {
+       return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+                                  'Library does not allow method ' .
+                                  "$method for '$scheme:' URLs");
+    }
+
+    # extract the identifier and check against posting to an article
+    my $groupart = $url->_group;
+    my $is_art = $groupart =~ /@/;
+
+    if ($is_art && $method eq 'POST') {
+       return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+                                  "Can't post to an article <$groupart>");
+    }
+
+    my $nntp = Net::NNTP->new($url->host,
+                             #Port    => 18574,
+                             Timeout => $timeout,
+                             #Debug   => 1,
+                            );
+    die "Can't connect to nntp server" unless $nntp;
+
+    # Check the initial welcome message from the NNTP server
+    if ($nntp->status != 2) {
+       return HTTP::Response->new(&HTTP::Status::RC_SERVICE_UNAVAILABLE,
+                                  $nntp->message);
+    }
+    my $response = HTTP::Response->new(&HTTP::Status::RC_OK, "OK");
+
+    my $mess = $nntp->message;
+    LWP::Debug::debug($mess);
+
+    # Try to extract server name from greeting message.
+    # Don't know if this works well for a large class of servers, but
+    # this works for our server.
+    $mess =~ s/\s+ready\b.*//;
+    $mess =~ s/^\S+\s+//;
+    $response->header(Server => $mess);
+
+    # First we handle posting of articles
+    if ($method eq 'POST') {
+       $nntp->quit; $nntp = undef;
+       $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+       $response->message("POST not implemented yet");
+       return $response;
+    }
+
+    # The method must be "GET" or "HEAD" by now
+    if (!$is_art) {
+       if (!$nntp->group($groupart)) {
+           $response->code(&HTTP::Status::RC_NOT_FOUND);
+           $response->message($nntp->message);
+       }
+       $nntp->quit; $nntp = undef;
+       # HEAD: just check if the group exists
+       if ($method eq 'GET' && $response->is_success) {
+           $response->code(&HTTP::Status::RC_NOT_IMPLEMENTED);
+           $response->message("GET newsgroup not implemented yet");
+       }
+       return $response;
+    }
+
+    # Send command to server to retrieve an article (or just the headers)
+    my $get = $method eq 'HEAD' ? "head" : "article";
+    my $art = $nntp->$get("<$groupart>");
+    unless ($art) {
+       $nntp->quit; $nntp = undef;
+       $response->code(&HTTP::Status::RC_NOT_FOUND);
+       $response->message($nntp->message);
+       return $response;
+    }
+    LWP::Debug::debug($nntp->message);
+
+    # Parse headers
+    my($key, $val);
+    local $_;
+    while ($_ = shift @$art) {
+       if (/^\s+$/) {
+           last;  # end of headers
+       }
+       elsif (/^(\S+):\s*(.*)/) {
+           $response->push_header($key, $val) if $key;
+           ($key, $val) = ($1, $2);
+       }
+       elsif (/^\s+(.*)/) {
+           next unless $key;
+           $val .= $1;
+       }
+       else {
+           unshift(@$art, $_);
+           last;
+       }
+    }
+    $response->push_header($key, $val) if $key;
+
+    # Ensure that there is a Content-Type header
+    $response->header("Content-Type", "text/plain")
+       unless $response->header("Content-Type");
+
+    # Collect the body
+    $response = $self->collect_once($arg, $response, join("", @$art))
+      if @$art;
+
+    # Say goodbye to the server
+    $nntp->quit;
+    $nntp = undef;
+
+    $response;
+}
+
+1;