Net::NNTP::Proxy - a news server in perl

  use Net::NNTP::Proxy;
  my $server = new Net::NNTP::Proxy || die "Couldn't start the server: $!\n"; 
  $server->push(new Net::NNTP::Client);
  $server->listen(9119);
  my $client = $server->connect;

  active ( PATTERN )
  active.times
  newsgroups ( PATTERN )
  overview.fmt (NOT YET IMPLEMENTED)

$VERSION = '0.54';
package Net::NNTP::Proxy;
our $VERSION = '0.54';

# -*- Perl -*-
###############################################################################
# Written by Tim Skirvin <tskirvin@killfile.org>
# Relies extensively on code from Net::NNTP, which was written and maintained 
# by Graham Barr <gbarr@pobox.com>.  Thanks.
#
# Copyright 2000-2002, Tim Skirvin.  Redistribution terms are below.
###############################################################################

use strict;
use Socket;
use Errno qw(EAGAIN);
use News::Article;

use vars qw($DEBUG $MAXCONN $CONNMESSAGE $PORT $NEWLINE);

### Variables #################################################################
$DEBUG = 1;		# Should debugging be on?  1 = yes, 0 = no.
$MAXCONN = 5;		# Maximum number of connections in the queue.
$CONNMESSAGE = "";	# Message to send when connected.
###############################################################################

$PORT = 119;		# Default news port
$NEWLINE = "\r\n";	# Newline string

sub new {
  my $class = shift; 
  my $object = {};  
  bless $object, $class;
  $object->_init('port', shift);
}

### _init ( KEY, VALUE [...] )
# Do the work for new().  And clone(), if I decide to make one.
sub _init {
  my ($self, %hash) = @_;

  # User-modified variables
  $$self{'NEWSSERVERS'}	  = $hash{'newsservers'} || [];

  # Cached variables
  $$self{'SERVER'}        = $hash{'server'}    || "";
  $$self{'GROUP'}         = $hash{'group'}     || "";
  $$self{'POINTER'}       = $hash{'pointer'}   || 0;
  $$self{'ARTICLES'}      = $hash{'articles'}  || [];

  # Internal variables
  $$self{'SOCKET'}        = $hash{'socket'}    || {};

  $self;
}

sub openport {
  my ($self, $port) = @_;
  my $server = $self->_open_socket($port || 119);
  $$self{'SOCKET'} = $server if $server;;
  return $server ? $self : undef;
}

sub closeport {
  my ($self, @rest) = @_;
  $$self{'SOCKET'} ? close $$self{'SOCKET'}
		   : 0;
}

sub connect {
  my ($self, $fh) = @_;
  my $server = $$self{'SOCKET'} || return undef;
  $fh ||= \*CLIENT;
  accept($fh, $server);
  $fh;
}

sub disconnect {
  my ($self, $fh) = @_;  return undef unless $fh;
  return undef unless defined fileno($fh);
  close $fh;
}

sub process {
  my ($self, $fh, $line) = @_;   $line ||= $_;
  $line =~ s/^\s+|\s+$//g;		# Trim leading/trailing whitespace
  my ($command, @rest) = split('\s+', $line);
  my @return;
  if (lc $command eq 'authinfo') {
    @return = "400 Not yet implemented";
    # @return = $self->authinfo(@rest);
  } elsif (lc $command eq 'article') {		# Works
    # @return = $self->article($rest[0]);
    @return = $self->article($rest[0], 1, 1);
  } elsif (lc $command eq 'body') {		# Works - sortof
    @return = $self->article($rest[0], 0, 1);
    # @return = $self->body(@rest);
  } elsif (lc $command eq 'date') {		# Works
    @return = $self->date;
  } elsif (lc $command eq 'group') {		# Works
    @return = $self->group($rest[0]);
  } elsif (lc $command eq 'head') {		# Works - sortof
    @return = $self->article($rest[0], 1, 0);
    # @return = $self->head(@rest);
  } elsif (lc $command eq 'help') {		
    @return = "400 Not yet implemented";
    # @return = $self->help(@rest);
  } elsif (lc $command eq 'ihave') {
    @return = "400 Not yet implemented";
    # @return = $self->ihave(@rest);
  } elsif (lc $command eq 'last') {		# Works
    @return = $self->last();
  } elsif (lc $command eq 'list') {
    @return = $self->list(@rest);
  } elsif (lc $command eq 'listgroup') {	# Works
    @return = $self->listgroup($rest[0]);	
  } elsif (lc $command eq 'mode') {		# Works
    @return = $self->mode(@rest);
  } elsif (lc $command eq 'newgroups') {
    @return = "400 Not yet implemented";
    # @return = $self->newgroups(@rest);
  } elsif (lc $command eq 'newnews') {
    @return = "400 Not yet implemented";
    # @return = $self->newnews(@rest);
  } elsif (lc $command eq 'next') {		# Works
    @return = $self->next();
  } elsif (lc $command eq 'post') {		# Works mostly
    @return = $self->post($fh);
  } elsif (lc $command eq 'slave') {
    @return = "400 Not yet implemented";
    # @return = $self->slave(@rest);
  } elsif (lc $command eq 'stat') {		# Works
    @return = $self->stat($rest[0]);
  } elsif (lc $command eq 'xgtitle') {
    @return = "400 Not yet implemented";
    # @return = $self->xgtitle(@rest);
  } elsif (lc $command eq 'xhdr') {
    # @return = $self->xhdr(@rest);
  } elsif (lc $command eq 'xover') {		# Works, I think
    @return = $self->xover(@rest);
  } elsif (lc $command eq 'xpat') {
    @return = "400 Not yet implemented";
    # @return = $self->xpat(@rest);
  } elsif (lc $command eq 'xpath') {
    @return = "400 Not yet implemented";
    # @return = $self->xpath(@rest);
  } elsif (lc $command eq 'quit') {		# Works
    $self->quit($fh);
    return undef;
  } else {					# Works
    @return = $self->badcommand;
  }
  print $fh join ($NEWLINE, @return, '');
  1;
}

sub newsservers { shift->{'NEWSSERVERS'} }
sub push { CORE::push ( @{shift->{'NEWSSERVERS'}}, @_ ) }
sub pop { unshift @{shift->{'NEWSSERVERS'}} }

sub authinfo { }

sub article { 
  my ($self, $id, $head, $body) = @_;  $id ||= "";
  return undef unless ($head || $body);
  my $article = $self->_article($id);	# Helper function
  if ($article && ref $article) {	# We got the article.
    my $ID = ($id =~ /^\d+$/) ? $id : 0;
    my $messageid = $article->header('message-id');
    my $code;  
    my @return;  
    if ($head) { 
      CORE::push @return, $body ? "220 $ID $messageid article"
	    		        : "221 $ID $messageid head"
    } else {
      CORE::push @return, "222 $ID $messageid body" if $body;
    }

    # We need to reformat the lines from rawheaders, which may include
    # newlines, for later reformatting
    if ($head) {
      my @headers = $article->rawheaders;
      foreach (@headers) { CORE::push @return, split("\n", $_); }
      CORE::push @return, "" if $body;	
    }

    # Fix a bug in Net::NNTP 
    if ($body) { map { s/^\./../o } @{$article->body} }
    CORE::push @return, $article->body if $body;
    CORE::push @return, ".";
    wantarray ? @return : join($NEWLINE, @return);
  } elsif ($article) {	# Error message - return it
    $article;
  } else {
    "420 No such article\n";
  }
}

sub body { shift->article($_[0], 0, 1) }

sub date { 
  my @localtime = gmtime;
  sprintf("111 %04d%02d%02d%02d%02d%02d\n",
        $localtime[5] + 1900, $localtime[4] + 1, $localtime[3] + 1,
        $localtime[2], $localtime[1], $localtime[0]);
}

sub group { 
  my ($self, $group) = @_;  return undef unless $group;
  my ($newsgroup, $server) = $self->_group($group);
  return $self->nosuchgroup($newsgroup) unless ($newsgroup && $server);
  $$self{GROUP} = $newsgroup;  $$self{SERVER} = $server;
  my @list = $self->_listgroup($newsgroup, $server); my $count = scalar @list;
  sprintf('211 %d %d %d %s', $count || 0, $list[0] || 0, 
			$count ? $list[$count - 1] : 0, $group);
}

sub head { shift->article($_[0], 1, 0) }

sub help () { }

sub ihave { }

sub last { 
  my $self = shift;
  if ($$self{POINTER} < 0) {
    "422 No Previous Article";
  } elsif ($$self{POINTER} == 0) {
    $$self{POINTER}--; "422 No Previous Article";
  } else {
    $$self{POINTER}--; $self->stat();
  }
}

sub list { 
  my ($self, $type, @args) = @_;
  if (lc $type eq 'active' || lc $type eq '') {
    $self->_list_active(@args);
  } elsif (lc $type eq 'active.times' || $type eq 'active_times') {
    $self->_list_active_times(@args);
  } elsif (lc $type eq 'overview.fmt') {	# Tricky
  } elsif (lc $type eq 'newsgroups') {
    $self->_list_newsgroups(@args);
  } else {		# None of the supported lists -> bad command
    $self->badcommand;
  }
}

sub listgroup { 	# Works!
  my ($self, $group) = @_;
  my ($newsgroup, $server) = $self->_group($group);
  return $self->nosuchgroup($group) unless ($newsgroup && $server);
  $$self{GROUP} = $newsgroup;  $$self{SERVER} = $server;
  my @list = $self->_listgroup($group, $server);   my $count = scalar @list;  
  return join("\n", "211 Article list follows", @list, ".");
}

sub mode { 	# Works!  
  my ($self, $mode) = @_;
  return $self->badcommand unless lc $mode eq 'reader';
  return "200 " . ($CONNMESSAGE || "Welcome to $0");
}

sub newgroups { } 

# newnews newsgroups yyyymmdd hhmmss [GMT]

sub newnews { }
# next
sub next { 
  my $self = shift;
  return $self->nogroupselect() unless (defined $$self{GROUP});
  if ($$self{POINTER} >= scalar@{$$self{ARTICLES}} - 1) { 
    "421 No Next Article"; 
  } else { $$self{POINTER}++; $self->stat; }
} 
# post
sub post { 
  my ($self, $fh) = @_; 	return undef unless $fh;
  print $fh "340 Send article to be posted\n";
  my @lines;
  while (defined (my $line = <$fh>)) { 
    $line =~ s/(\r?\n|\n?\r)$//g;	# chomp wasn't working
    last if $line =~ /^\.$/;
    CORE::push @lines, $line; 
  }
  my $article = News::Article->new(\@lines) 
		|| return "441 Posting Failed (Article was Empty)";
  $article->write(\*STDOUT) if $DEBUG;
  $article->set_headers('newsgroups',
        $self->_fix_groups($article->header('newsgroups')) );
  $article->add_message_id;  $article->add_date;
  my $success = 0;  my @problems;
  foreach my $server (@{$self->newsservers}) {
    my $nntp = $server->nntp || next;
    my $name = $server->name;
    next unless $server->postok;
    local $@;
    warn "Posting to $name\n";
    eval { $article->post($nntp) } ;
    if ($@) {
      chomp $@;
      warn "Error in posting to $name: $@\n";
      CORE::push @problems, "$name: $@";
    } else {
      $success++;
    }
  }
  $success ? "240 Article Posted to $success servers" 
	   : "441 Was unable to post to any news servers - " . join(', ', @problems);
}

sub slave () { } 

# stat [MessageID|Number]
sub stat {
  my ($self, $id) = @_;
  return $self->nogroupselect() unless (defined $$self{GROUP});
  my ($number, $messageid) = $self->_stat($id);
     $number ||= 0;

  if ($messageid) { return "223 $number $messageid"; } 
  elsif ($number) { return "423 No Such Article In Group"; } 
  else            { return "430 No Such Article"; }
}

sub xgtitle { }

sub xhdr { }

sub xover { 
  my ($self, $range) = @_;
  return $self->nogroupselect() unless (defined $$self{GROUP});
  
  my $server  = $$self{SERVER} || return undef;
  my $hash    = $server->xover($range) || return undef; 
  my @return = "224 overview data follows";
  foreach (sort { $a <=> $b } keys %{$hash}) { 
    CORE::push @return, join("\t", $_, @{$$hash{$_}}); 
  }
  CORE::push @return, ".";
	
  join("\n", @return);
}

sub xpat { }

sub xpath { }

sub quit { 
  my ($self, $fh) = @_;
  return undef unless defined fileno($fh);
  print $fh "205 Goodbye\n";
  close $fh;
}

# Error messages
sub nosuchgroup { my $group = shift || "";  return "411 No such group $group" }
sub badcommand      { "500 Syntax Error or Unknown Command" }
sub nogroupselect   { "512 No Group Selected" }
sub badarticlenumber { "423 Bad article number"; }

###############################################################################
##### INTERNAL AND HELPER FUNCTIONS ###########################################
###############################################################################

### DESTROY
# When the object goes away, make sure that disconnect() is called.
sub DESTROY { shift->disconnect() }

### _fix_groups ( LINE )
# Takes a Newsgroups: line, and takes out everything after the '@' in each
# group.  This is important for translating back to the real world's groups.
# Hopefully this won't break PGPMoose and such too badly; I don't think they
# follow Newsgroups:...
sub _fix_groups {
  my ($self, $line) = @_;  
  my @groups = split(',', $line || "");
  map { s/^\s*(\S+)(@\S*)\s*$/$1/ } @groups;
  join(',', @groups);
}

### _group ( GROUP )
# Loads GROUP from the appropriate server
sub _group {
  my ($self, $group) = @_;   return undef unless $group;
  if ($group =~ /^(.*)@(.*)$/) {	# Group we created 
    my $newsgroup  = $1;  my $servername = $2;
    foreach my $server (@{$$self{NEWSSERVERS}}) {
      next unless $server;
      my $newsserver = $server->name;
      return ($newsgroup, $server) if ($servername eq $newsserver);
    }
    return undef;
  } else {				# Group we're proxying
    my $newsgroup = $group;
    # Figure out which server has the first feed of this group.  
    foreach my $server (@{$$self{NEWSSERVERS}}) {
      next unless ($server && $server->connected);
      $server->group($newsgroup) ? return ($newsgroup, $server) : next;
    }
  }
  return undef;
}

### _list_newsgroups ( [PATTERN] )
# Creates the newsgroups list out of the newsgroups values.  
sub _list_newsgroups {
  my ($self, $pattern) = @_;
      $pattern ||= '*';
  my @return = "215 Newsgroups Follow";
  my %fullhash;
  foreach (@{$$self{'NEWSSERVERS'}}) {
    my $server = $_->server;
    my $hash   = $_->newsgroups($pattern);
    foreach (keys %{$hash}) {
      $fullhash{$_} ||= $$hash{$_};
      CORE::push @return, "$_\@$server $$hash{$_}";
    }
  }
  foreach (keys %fullhash) { CORE::push @return, "$_ $fullhash{$_}"; }
  CORE::push @return, ".";
  wantarray ? @return : join($NEWLINE, @return);
}

### _list_active ( [PATTERN] )
# Creates the active list out of the active values.  
sub _list_active {
  my ($self, $pattern) = @_;
      $pattern ||= '*';  
  my @return = "215 Newsgroups Follow .";
  my %fullhash;
  foreach (@{$$self{'NEWSSERVERS'}}) {
    my $name   = $_->name || "";
    my $hash   = $_->active($pattern) || {};
    foreach (sort keys %{$hash}) {
      next unless $_;  
      CORE::push @return, "$_\@$name @{$$hash{$_}}";
      $fullhash{$_} ||= "@{$$hash{$_}}";
    }
  }
  foreach (sort keys %fullhash) { CORE::push @return, "$_ $fullhash{$_}"; }
  CORE::push @return, ".";
  wantarray ? @return : join($NEWLINE, @return);
}

### _list_active_times ( [PATTERN] )
# Creates the active.times list out of the active.times values.  
sub _list_active_times {
  my ($self, $pattern) = @_;
      $pattern ||= '*';
  my @return = "215 Group Creations";
  my %fullhash;
  foreach (@{$$self{'NEWSSERVERS'}}) {
    my $server = $_->name;
    my $hash   = $_->active_times();
    foreach (sort keys %{$hash}) {
      next unless $_;
      CORE::push @return, "$_\@$server @{$$hash{$_}}[0]";
      $fullhash{$_} ||= "@{$$hash{$_}}[0]";
    }
  }
  foreach (sort keys %fullhash) { CORE::push @return, "$_ $fullhash{$_}"; }
  CORE::push @return, ".";
  wantarray ? @return : join($NEWLINE, @return);
}

### _listgroup ( [GROUP] , SERVER ) 
# Returns the listgroup information.  GROUP can be 'undef' if you'd like.
sub _listgroup {
  my ($self, $group, $server) = @_;  return undef unless $server;
  $$self{ARTICLES} = $server->listgroup($group) || []; 
  $$self{POINTER} = 0;
  wantarray ? @{$$self{ARTICLES}} : $$self{ARTICLES};
}

### _stat ( [ID] )
# Get the stat information on C<ID>, and set $POINTER if necessary.
sub _stat {
  my ($self, $id) = @_;

  # Get the various important values for later use
  my $pointer = $$self{POINTER};  my @articles = @{$$self{ARTICLES}};
  my $server  = $$self{SERVER};   my $group = $$self{GROUP};
  my @servers = @{$$self{NEWSSERVERS}};
   
  if (!(defined $id)) {		# No ID given at all -> last result
    return (-1, undef) unless ($pointer >= 0);
    if (defined $pointer && scalar @articles && defined $server) {
      # my $nntp = $server->nntp || return (undef, undef);
      my $messageid   = $server->nntpstat($articles[$pointer]);
      return ($articles[$pointer], $messageid) if $messageid;
    } elsif (scalar @articles && defined $server) {
      return (1, undef)
    } else {
      return (undef, undef);
    }
  } elsif ($id =~ /^\d+$/) {	# Numeric ID -> in a group
    # If we're not in a group, then just stop now.
    return (undef, undef) unless ( scalar @articles && defined $server );
    # There's two choices here - do it locally, or do it by the 'net.  The
    # latter is more computationally efficient but requires network accesses.  
    for (my $i = 0; $i < scalar @articles; $i++) {
      if ($articles[$i] eq $id) {
        my $messageid = $server->nntpstat($articles[$i]) || next;
        $$self{POINTER} = $i if $messageid;
        return ($id, $messageid) if $messageid;
      }
    }
    $$self{POINTER} = undef;
    return ($id, undef);
  } else {			# It's a full message ID
    foreach ($server, @servers) {
      next unless $_;  
      my $messageid   = $_->nntpstat($id);
      return (0, $messageid) if $messageid;
    }
    return (undef, undef);
  }
}

### _article ( ID [, NID] )
# Downloads the given ID from all of the object's news servers.  
sub _article {
  my ($self, $id, $nid) = @_;  $id ||= "";

  # If the given ID is numeric or not given, then try to find and 
  # load the appropriate message-ID.  If that doesn't work, then it 
  # was a bad number.
  if (!$id || $id =~ /^\d+$/) { 	# Non-existant or numeric 
    my ($number, $mid) = $self->_stat($id);  
    return "" if ($id && $mid && ($id eq $mid));	# TESTING
    $self->_group($$self{GROUP});
    return $self->_article( $mid, $id ) || $self->badarticlenumber;
  } 

  warn "Looking for article $id\n" if $DEBUG;
  
  # Search through all of the news servers in order for the full 
  # message-ID.  
  foreach my $server (@{$$self{NEWSSERVERS}}) {
    my $article = News::Article->new($server->article($id));
    return $article if $article;
  }
  # If all else fails, go with the numeric ID (if possible)
  my $server  = $$self{SERVER} || return undef;
  my $article = News::Article->new($server->article($nid));
  $article ? $article : undef;
}

### _open_socket ( PORT [, MAXCONN] )
# Build a socket.  Code taken from Programming Perl, 3rd Edition.
sub _open_socket {
  my ($self, $port, $maxconn) = @_;
  return undef unless $port;
  
  # make the socket
  socket(SERVER, PF_INET, SOCK_STREAM, getprotobyname('tcp'));  
  
  # so we can restart our server quickly
  setsockopt(SERVER, SOL_SOCKET, SO_REUSEADDR, 1);
  
  # build up my socket address
  unless (bind (SERVER, sockaddr_in($port, INADDR_ANY) ) ) {
    warn "Couldn't bind to port $port: $!\n"; 
    return undef;
  }
  
  # establish a queue for incoming connections 
  unless (listen(SERVER, $maxconn || $MAXCONN || SOMAXCONN) ) {
    warn "Couldn't listen on port $port: $!\n";
    return undef;
  }
  warn "Listening on port $port\n" if $DEBUG;
  
  \*SERVER;
}

1;

# Version History
# v0.5a - Thu Nov  9 18:03:58 CST 2000
#   Commenting in progress.  This thing still needs some serious work to
#   make it pretty, though.  
# v0.51a - Tue Apr 24 15:56:49 CDT 2001
#   Worked around a bug from Net::NNTP where '^..' is turned into '^.'.  
# v0.52a - Mon Jan 28 11:30:32 CST 2002
#   Replaced push() with CORE::push().  Started sorting the active and
#   active_times() outputs.  Changed to variable EOL string.  Fixed some 
#   bugs in _list_active and the line with returning arrays.
# v0.53a - Wed Jan 30 09:32:27 CST 2002
#   Fixed article() to have uniform newlines.
# v0.54		Thu Apr 22 11:44:01 CDT 2004 
### No real changes, just internal layout changes.