#-*-perl-*-
# File: nntp.pl - utility functions to talk to an NNTP server
# 
# KOPYKNOT (K) 1991 Free Knoware Foundation, Ink.
# $Header: /afs/sipb.mit.edu/project/sipbsrc/src/wafe-0.95/apps/news/RCS/nntp.pl,v 1.2 1993/07/19 02:33:10 ckclark Exp $
# 
# This file is part of Randall's NNTP grep-n'-fetch-it utilites.
# 
# NNTP grep-n'-fetch-it is free software.  You can redistribute it and
# modify it under the terms of the GNU General Public License as
# published by the Free Software Foundation or not.  That's what makes
# this a Kopyknot.  You can use this code for any purpose whatsoever.
# If you can make a dime off it, great.  I'm not out to stop you.  If
# you want to claim you wrote it, great.  It ain't up to me to blow your
# cover.  Go for it.
# 
# NNTP grep-n'-fetch-it is distributed in the hope that it will make
# Randall a famous net.personality.  It includes ABSOLUTELY NO WARRANTY.
# In fact, you should know that this code will probably fail in lots
# of different ways on lots of different machines.  If you want to fix
# the problems, great.  If you want to tell me what you changed, great.
# If you want me to fix something for you, go screw yourself.  I'm busy.
# 
# This Kopyknot was inspired by the GNU Copyleft.  I think that Richard
# Stallman is a mensch.  If I weren't so obsessed by the almighty buck,
# I'd try to get a job working for him.  If you want more information on
# the GNU General Public License, get GNU Emacs, or write to the Free
# Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
# 
# I hope you don't feel insulted by my parody, Richard.

#
# extended, made more robust, substantial speedup:
# Gustaf Neumann
#
# NOTE: the modified version is NOT backward compatible with
# the original one!!!

package nntp;

require('chat2.pl');

# file in which to find the name of the nntp server
$servfile = "/mit/sipb/etc/server";

# end of line pattern for responses
$cr = '\r?\n';

# error strings
$noservermsg =
    "No NNTP server specified.  Check NNTPSERVER environment variable\n";
$badservermsg = "No connection to NNTP server %s: %s\n";

%groups = ();			# start with an empty list
%newsrc = ();			# newsrc entries
%subscribed = ();		# entry will be true if subscribed
@ngorder = ();			# to remember order of entries in newsrc

#***********************************************************************
# $hndl = &nntp'connect($server);
#
#   attempt a connection to the nntp server.  the argument $server is
#   optional and will be looked up in the environment or the nntpserver
#   file if not supplied.  $server may be specified as a host name or
#   the internet address of the host.
#
#   a chat-handle will be returned if successful.  otherwise, a fatal
#   error occurs.
#***********************************************************************
sub connect
{
    local($server) = $_[0];
    local($conn);

    $server || ($server = $main'nntpServer || $ENV{"NNTPSERVER"}) ||
	(open(servfile) ? chop($server = <servfile>) : "");

    die $noservermsg unless $server;
     ($conn = &chat'open_port($server, 119)) ||
	die sprintf($badservermsg, $server, $!);

    local($msg) = &chat'expect($conn, 100,
		 "^20[01] .*$cr", '$&',
		 "^5.. .*$cr", 'die "NNTP-server error: " . $&',
		 "TIMEOUT", 'die "NNTP-server connection timeout: $server\n"');
#    print "msg= <$msg>\n";
    ($conn,$server);
}

#***********************************************************************
# $perl_pattern = &nntp'grouppat($generic_pattern)
#
#   try to be smart about whether the user is smart.  changes input
#   patterns of the form 'comp.all' to 'comp\..*'
#***********************************************************************
sub grouppat
{
    local($pat) = $_[0];

    if (($pat =~ /^[a-zA-Z0-9.]+$/) && !($pat =~ /\.\./))
    {
	# not a complex pattern
	$pat =~ s/\./\\./g;
	$pat =~ s/^/^/;		# caret on the front
	$pat =~ s/$/$/;		# dollar on the end
    }
    $pat =~ s/(\.all)+$/.*/;
    $pat =~ s/^(all\.)+/.*/;
    $pat =~ s/\ball\b/.*/g;
    $pat;
}

#***********************************************************************
# &nntp'getgroups
#
#   @groups is the list of groups known by the nntp server.
#   %groups is an associative array of the max articles numbers
#   used for quick lookup.  These variables are private to the
#   nntp package.
#***********************************************************************
sub getgroups
{
    local($conn) = $_[0];
    local($done,$buffer,$totalBuffer);
    local($ng);
    
#    print "getgroups\n";

    unless (%groups)
    {
	&chat'print($conn, "list\r\n");
	    &chat'expect($conn, 100,
			 "^215 .*$cr", ';',
			 "^5.. .*$cr", '$done = 1, warn "$&"');
	
	# get a list of all the groups, one line at a time
	$*=1;
	while (! $done)	{
	    $buffer = &chat'expect($conn, 100,
			 '^[\000-\377]+$', '$&',
	                 TIMEOUT, '$done = 1');
	    $buffer =~ tr/\r//d;
	    $done = $done || ($buffer =~ /^\.\n/);
	    $totalBuffer .= $buffer;
        }
        $*=0;
        chop($totalBuffer);
        chop($totalBuffer);
#       @groups = split("\n",$totalBuffer);
#	chop(@groups); chop(@groups);
	
	# build associative array for quick lookups
	foreach (split("\n",$totalBuffer))
	{
            split;
	    $groups{$_[0]} = ($_[1]+0)." ".($_[2]+0)." $_[3]" 
		if $_[0] !~ /:/;
# print "<$_[0]> = <$groups{$_[0]}>\n";

#            ($ng = $_) =~ s/ .*//;
#            $groups{$ng} = $_;
#print "<$ng> <$groups{$ng}>\n";
	}
    }
}

#***********************************************************************
# @matching_groups = &nntp'list($conn, $group_pattern)
#
#   return a list of the groups which match the group pattern.
#***********************************************************************
sub list
{
    local($conn) = $_[0];
    local($pat) = $_[1] ? &grouppat($_[1]) : '.*';
    local(@grouplist);

    # get an array of all the groups known at the server
    &getgroups($conn) unless %groups;

# print join("\n",@groups),"\n";
    @grouplist = keys %groups;	# copy list of groups
    
    # use eval to avoid repeated pattern evaluations
    eval("grep(s/ .*// && /$pat/, \@grouplist);");
}

sub setgroup
{
    local($conn) = $_[0];
    local($ng) = $_[1];
    local($artcls);

#    &getgroups($conn) unless @groups;

#    defined($groups{$ng}) || return ();
#  print "goup $ng\n";
    &chat'print($conn, "group $ng\r\n");
    ($artcls = &chat'expect($conn, 100,
			    "^211 .*$cr", '$&',
			    "^[45].. .*$cr", '()')) || return ();
    (split(/ /, $artcls))[1..3];
}

# return the article contents in a (potentially large) string.
# 
# $msg = &msgtext($conn, $num-or-id, "article" | "body" | "head")
#
sub msgtext
{
    local($conn,$num,$cmd) = @_;
    local($fail);
    local(@msg,$string,$buffer);

    &chat'print($conn, "$cmd $num\r\n");
    $msgok = &chat'expect($conn, 100,
			  "^220 .*$cr", '1',
			  "^221 .*$cr", '1',
			  "^222 .*$cr", '1',
			  "^4.. .*$cr", '0')  || return;

    # gather the lines of the text into an array.  stop when you see
    # a dot on a line by itself.

    $*=1;
#   ($string = &chat'expect($conn, 100, '\n\.\r?\n', '$`', 'TIMEOUT','$fail=1,""')) =~ tr/\r//d;
    ($string = &chat'expect($conn, 100, '^\.\r?\n', '$`', 'TIMEOUT','$fail=1,""')) =~ tr/\r//d;
#    while (! $done)
#    {
#	$buffer = &chat'expect($conn, 10,
##				 '^.*\n', '$&',
#				 '\n\.\r?\n', '$`',
##				 '^[\000-\377]+$', '$&.\n',
#				 "TIMEOUT", '$done = 2');
#
#        $buffer =~ tr/\r//d;
#        $done = $done || ($buffer =~ /^\.\n/) || 1;
#    print "done=$done, buffer=<$buffer>\n";
#	push(@msg, $buffer);
#    }
#    ($string = join("", @msg)) =~ s/^\.\././g;
#    chop($string);
#    chop($string);
    $*=0;
    ($fail,$string);
}

sub article
{
    local($fail,$text) = &msgtext($_[0], $_[1], "article");
    $text;
}

sub body
{
    local($fail,$text) = &msgtext($_[0], $_[1], "body");
    $text;
}

sub articles
{
    local($conn) = shift;
    local(*msgs) = shift;
    local($n) = 0;

    @msgs = ();
    foreach (@_)
    {
	local($fail,$text) = &msgtext($_[0], $_[1], "article");
	$msgs[$n++] = $text;
    }
}

sub bodies
{
    local($conn) = shift;
    local(*msgs) = shift;
    local($n) = 0;

    @msgs = ();
    foreach (@_)
    {
	$msgs[$n++] = &msgtext($conn, $_, "body");
    }
}

sub field
{
    local($conn) = $_[0];
    local($flname) = $_[1];
    local($num) = $_[2];	# may be a message id
    local($ret) = "";
    local($done) = 0;

    @flds = ();

    &chat'print($conn, "xhdr $flname $num\r\n");
    &chat'expect($conn, 100,
		 "^221 .*$cr", '1',
		 "^4.. .*$cr", '0',
		 "TIMEOUT", '0') || return($ret);

    while (! $done)
    {
	&chat'expect($conn, 100,
		     "^\\.$cr", '$done = 1',
		     "^..*$cr", 'chop($&); chop($&); $ret = $&',
		     "TIMEOUT", '$done = 1');
    }
    $ret =~ s/^[^ ]* //;		# get rid of article number or message id
    $ret;
}

sub fields
{
    local($conn) = $_[0];
    local(*flds) = $_[1];
    local($flname) = $_[2];
    local($first) = $_[3];
    local($last) = $_[4];
    local($done) = 0;

    @flds = ();

    &chat'print($conn, "xhdr $flname $first-$last\r\n");
    &chat'expect($conn, 100,
		 "^221 .*$cr", '1',
		 "^4.. .*$cr", '0',
		 "TIMEOUT", '0') || return;

    while (! $done)
    {
	&chat'expect($conn, 100,
		     "^([0-9]+) .*$cr", '$flds[$1 - $first] = $&',
		     "^\\.$cr", '$done = 1',
		     "TIMEOUT", '$done = 1');
    }
    chop(@flds); chop(@flds);
}

sub grepfield
{
    local($conn) = $_[0];
    local($flname) = $_[1];
    local($expr) = $_[2];
    local($first) = $_[3];
    local($last) = $_[4];
    local(@flds);
    local(@rtn) = ();

    &fields($conn, *flds, $flname, $first, $last);

    foreach (eval("grep($expr, \@flds)"))
    {
	$_ =~ /^([0-9]+) /;
	push(@rtn, $_) if $1 >= $first;
    }
    @rtn;
}

sub idgrepfield
{
    local($conn) = $_[0];
    local($flname) = $_[1];
    local($expr) = $_[2];
    local($first) = $_[3];
    local($last) = $_[4];
    local(@flds, @ids);
    local(@rtn) = ();

    &fields($conn, *flds, $flname, $first, $last);
    &fields($conn, *ids, "message-id", $first, $last);

    foreach (eval("grep($expr, \@flds)"))
    {
	$_ =~ /^([0-9]+) /;
	if ($1 >= $first)
	{
	    local($idx) = $1 - $first;
	    $ids[$idx] =~ s/^([0-9]+) /\1: /;
	    push(@rtn, $ids[$idx]);
	}
    }
    @rtn;
}

sub greptext
{
    local($conn) = $_[0];
    local($cmd) = $_[1];
    local($expr) = $_[2];
    local($first) = $_[3];
    local($last) = $_[4];
    local(@msg);
    local(@rtn) = ();
    local($art);

    foreach $art ($first..$last)
    {
	@msg = split(/$cr/, &msgtext($conn, $art, $cmd));
	@msg = eval("grep($expr, \@msg)");
	push(@rtn, grep($_ = "$art $_", @msg));	# tack on article number
    }
    @rtn;
}

sub idgreptext
{
    local($conn) = $_[0];
    local($all) = $_[1] == "article";
    local($expr) = $_[2];
    local($first) = $_[3];
    local($last) = $_[4];
    local(@msgs, @lines, @match);
    local(@rtn) = ();
    local(@ids);

    if ($all)
    {
	&articles($conn, *msgs, $first..$last);
    }
    else
    {
	&bodies($conn, *msgs, $first..$last);
    }
    &fields($conn, *ids, "message-id", $first, $last);

    $first = 0;			# now use $first as loop counter
    foreach (@msgs)
    {
	@lines = split(/\r\n/, $_);
	if (eval("grep($expr, \@lines)"))
	{
	    $ids[$first] =~ s/^([0-9]+) /\1: /;
	    push(@rtn, $ids[$first]);
	}
	$first++;
    }

    @rtn;
}

# get the read messages information from a newsrc file
sub getrc
{
    local ($fname) = $_[0];
    local ($ng, $artcls);

    unless (open(RC, "<$fname"))
    {
	warn("Can't open $fname: $!");
        foreach (keys %groups) {
            $newsrc{$_} = "0-0";
	    push(@ngorder, $_);
	    $subscribed{$ng} = 0;
        }
        $subscribed{"news.announce.important"} = 1;
        $subscribed{"news.announce.newusers"}  = 1;
        $subscribed{"news.newusers.questions"} = 1;
        $newsrc{0} = 1;	# don't do this very often
	return;
    }

    while (<RC>)
    {
	chop;
	($ng, $artcls) = split(/[!: \t]+/, $_, 2);

        unless ($groups{$ng}) {
	    print "ignoring unknown group $ng in $fname\n";
	    next;
	}
        if ($newsrc{$ng}) {
	    print "ignoring duplicate entry for $ng in $fname\n";
	    next;
	}

	$newsrc{$ng} = ($artcls =~ /^\d.*\d$/) ? $artcls : "0-0";
	$subscribed{$ng} = /^[a-zA-Z0-9.+-]+:/;
	push(@ngorder, $ng);
    }
    $newsrc{0} = 1;	# don't do this very often
    close (RC);
}

# return the list of already-read articles in the user's newsrc file for
# the specified news group.  if the $force flag is true, get the
# information whether subscribed or not.  returns false if not subscribed
# and not # $force'd.  returns "0-0" if the group exists in the newsrc file,
# but has no already-read list was encountered.
sub newsrc_get
{
    local ($fname, $ng, $force) = @_;

    &getrc($fname) unless $newsrc{0};
    $force ? $newsrc{$ng}
        : $subscribed{$ng} && $newsrc{$ng};
}

#
# mode is "all subscribed", "all available", "with new articles"
#
sub subscribed {
    local ($conn,$fname,$mode) = @_;
    local (@result,$ng,$unread,$_);

    local($starttime) = time;
    local($gstarttime) = time;
    &getgroups($conn) unless %groups;
    local($gendtime) = time;
    local($nstarttime) = time;
    &getrc($fname) unless $newsrc{0};
    local($nendtime) = time;

    local($nnstarttime) = time;
    unless (defined(%newNewsGroup)) {
	foreach (keys %groups) {
	    $newNewsGroup{$_} = 1 unless $newsrc{$_};
	}
	$newNewsGroup{"dummy"}=0;
    }
    local($nnendtime) = time;

    local($rstarttime) = time;
    local($unread,$range,$line);

    foreach $ng (grep($newNewsGroup{$_},keys %newNewsGroup),@ngorder) {
	next if 
	    !$subscribed{$ng}
	    && $newsrc{$ng}
	    && ($mode ne "all available");
	($_ = $groupLine{$ng}) && (($unread,$range,$line) = split($;))
	    || (($unread,$range,$line) = &groupLine($ng));
#	print "unread <$unread> line <$line>\n";
	push(@result, $line) if $unread || $mode ne "with new articles";
    }
#    print "time in subscribed = ",(time-$starttime)," Sekunden, ",
#              ($gendtime-$gstarttime)," + ",
#              ($nendtime-$nstarttime)," + ",
#              ($nnendtime-$nnstarttime)," + ",
#              (time-$rstarttime),
#		  "\n";
    return @result;
}

sub groupLine {
    local($ng) = @_;
#    local($unread,$rangelist,$line) = split($;,$groupLine{$ng});
#    return ($unread,$rangelist,$line) if $line;

    local($subscribed,$entry) = ($subscribed{$ng},$newsrc{$ng});     
    local($last,$first) = (split(? ?,$groups{$ng}))[(0,1)];
    local($articles) = &canon_count("$first-$last");

    unless ($subscribed) {
	$rangelist="$first-$last";
        $unread=$articles;
    } else {
	$rangelist =  $entry ? 
	    &canon_inverse($entry,$first,$last) : "$first-$last";
	$unread = &canon_count($rangelist);
    }
# print "counting $ng <$rangelist> returns $unread in range <$first-$last>\n";

    $line = sprintf("%-45s %4d unread + %4d read ", 
		    $ng , $unread, $articles-$unread)
		 . ($entry ? ($subscribed ? "" : "(unsubscribed)") : "(new)");

    $groupLine{$ng} = "$unread$;$rangelist$;$line";
    return ($unread,$rangelist,$line);
}


# replace or create a newsrc entry
sub newsrc_put
{
    local($fname, $ng, $ranges) = @_;

    &getrc($fname) unless $newsrc{0};
    unless (defined($newsrc{$ng}))
    {
	push(@ngorder, $ng);
	$subscribed{$ng} = 1;
    }
    $newsrc{$ng} = $ranges;
}

# merge newly read articles into the newsrc entry
sub newsrc_merge
{
    local($ng, $ranges) = @_;

#  print "merging <$ng> <$newsrc{$ng}> with ranges <$ranges>\n";
    &getrc($fname) unless $newsrc{0};
    if ($newNewsGroup{$ng})
    {
#      print "merging new newsgroup <$ng>, inserting at pos $#ngorder and subscribe\n";
	push(@ngorder, $ng);
	$subscribed{$ng} = 1;
	$newsrc{$ng} = "0-0";
        undef $newNewsGroup{$ng};
    }
    $newsrc{$ng} = &canon_union($newsrc{$ng}, $ranges);
#  print "new newsrc entry is <$newsrc{$ng}>\n";
}

# update the newsrc file
sub newsrc_write
{
    local($fname) = $_[0];	# newsrc file name to write
    local(@ngs);
    local($rlist);

    open(FH, ">$fname") || die("Can't write to $fname: $!");
    foreach (@ngorder)
    {
	($rlist = $newsrc{$_}) =~ s/^0-0$//;
	printf(FH "%s%s %s\n", $_, $subscribed{$_} ? ":" : "!", $rlist);
    }
    close(FH);
}

# comparison function used in canon_artlist
sub cmp_range
{
    $a <=> $b;			# #force numeric comparison
}

# take a list of article ranges and return a canonical list.  the
# list returned will be sorted in ascending order with no overlapping
# ranges.  the input and output are in string format.
sub canon_artlist
{
    local($l) = $_[0];
    local(@l);
    local(@can);

    return "0-0" unless $l;
#    print "canon artlist receives <$l>\n";

    $l =~ s/\s+//;		# annihilate spaces
    @l = split(/,/, $l);	# get ranges into array

    # flip any descending ranges
    grep(/(\d+)-(\d+)/ && ($2 < $1) && ($_ = "$2-$1"), @l);

    # expand single numbers to (redundant) range format
    grep(/^(\d+)$/ && ($_ = "$1-$1"), @l);

    # sort the array by first elements
    @l = sort(cmp_range @l);

    # build a canonical list by combining overlapping adjacent ranges
    ($min, $max) = ($l[0] =~ /(\d+)-(\d+)/);
    foreach $el (@l)
    {
	local($beg, $end) = ($el =~ /(\d+)-(\d+)/);

	if ($beg > $max + 1)
	{
	    push(@can, "$min-$max");
	    $min = $beg;
	    $max = $end;
	}
	else
	{
	    $max = $end if $end > $max;
	}
    }
    push(@can, "$min-$max");	# don't forget the last range

    # handle single number ranges
    grep(/(\d+)-(\d+)/ && $1 == $2 && ($_ = "$1"), @can);

#    print "canon artlist returns <", join(',',@can), ">\n";
    # return a string delimited by commas
    join(',', @can);
}

# return the article list of articles not included in the input list,
# but bound by a low and high value.  this is used to determine unread
# articles given the entry in the .newsrc file and the range of
# articles held by the nntpserver.
sub canon_inverse
{
    local($l,$lo, $hi) = @_;
    local(@l) = ();

# print "canon inverse receives <$l> lo = <$lo>, hi = <$hi>\n";
    
    # build an array of article ranges
    @l = split(/,/, $l);
    grep(/^(\d+)$/ && ($_ = "$1-$1"), @l);

# print "paarliste <", join(',',@l), ">\n";

    # find overlapping articles
    @l = grep(/(\d+)-(\d+)/ && ($1 <= $hi && $2 >= $lo), @l);
    return ("$lo-$hi") unless @l;

# print "overlapping <", join(',',@l), ">\n";

    if (@l[0] <= $lo)
    {
	shift(@l) =~ /(\d+)-(\d+)/;
	$lo = $2 + 1;
    }

    grep(/(\d+)-(\d+)/ && ($_ = ($lo . "-" . ($1 - 1))) && ($lo = $2 + 1), @l);
    push(@l, "$lo-$hi") if ($lo <= $hi);

    # handle single number ranges
    grep(/(\d+)-(\d+)/ && $1 == $2 && ($_ = "$1"), @l);

# print "canon inverse wants to return <", join(',',@l), ">\n";

    # return a string delimited by commas
    join(',', @l) || "0-0";
}

# intersect two canonical article lists and return the result
sub canon_isect
{
    local(@first) = split(/,/, $_[0]);
    local(@second) = split(/,/, $_[1]);
    local(@can) = ();

    return("") if (!@first || !@second);

    # expand single numbers to (redundant) range format
    grep(/^(\d+)$/ && ($_ = "$1-$1"), @first);
    grep(/^(\d+)$/ && ($_ = "$1-$1"), @second);

    local($lo, $hi, @overlap);
    foreach $el (@first)
    {
	($lo, $hi) = split(/-/, $el);
	@overlap = grep(/(\d+)-(\d+)/ && ($1 <= $hi && $2 >= $lo), @second);
	next unless @overlap;	# save time if no overlapping ranges

	# fix up the first and last overlapping ranges
        $overlap[0] = "$lo-$2"
	    if ($overlap[0] =~ /(\d+)-(\d+)/) && ($1 < $lo);
	$overlap[$#overlap] = "$1-$hi"
	    if ($overlap[$#overlap] =~ /(\d+)-(\d+)/) && ($2 > $hi);
	push(@can, @overlap);
    }

    # handle single number ranges
    grep(/(\d+)-(\d+)/ && $1 == $2 && ($_ = "$1"), @can);

    # return a string delimited by commas
    join(',', @can);
}

# return the canonical union of two canonical article lists
sub canon_union
{
    &canon_artlist("$_[0],$_[1]"); # Hah!

}

# return an array of ranges that is the expansion of the canonical
# article list.
sub canon_expand {
    grep(/^(\d+)$/ && ($_ = "$1-$1") || 1, split(/,/, $_[0]));
}

# counts articles in an string of ranges
sub canon_count
{
    return 0 if $_[0] eq "0-0";
    local ($count) = 0;
    foreach (split(/,/, $_[0])) {
	$count ++ if /^(\d+)$/;
	$count += 1 + $2 - $1 if /(\d+)-(\d+)/ && $1 <= $2;
    }
    $count;
}

# tests whether an article is included in a given rangelist
sub inRangelist {
    local ($nr,$rnglist) = @_;
    return 0 if $rnglist eq "0-0";
    foreach (split(/,/, $rnglist)) {
#    print "is $nr in $_?\n";
	return ($1 == $nr) if /^(\d+)$/ && $1 >= $nr;
	return (($1 <= $nr && $nr <= $2)) if /(\d+)-(\d+)/ && $2 >= $nr;
    }	      
#    print "$nr it is not in $rnglist\n"; 
	     return 0;		
}

1;