Initial revision

lisp/gnus/earcon.el

@@ -0,0 +1,245 @@
+;;; earcon.el --- Sound effects for messages
+;; Copyright (C) 1996 Free Software Foundation
+
+;; Author: Steven L. Baur <steve@miranova.com>
+;; Keywords: news fun sound
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+;; This file provides access to sound effects in Gnus.
+
+;;; Code:
+
+(if (null (boundp 'running-xemacs))
+    (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)))
+
+(require 'gnus)
+(require 'gnus-audio)
+(require 'gnus-art)
+(eval-when-compile (require 'cl))
+
+(defgroup earcon nil
+  "Turn ** sounds ** into noise."
+  :group 'gnus-visual)
+
+(defcustom earcon-auto-play nil
+  "When True, automatically play sounds as well as buttonize them."
+  :type 'boolean
+  :group 'earcon)
+
+(defcustom earcon-prefix "**"
+  "String denoting the start of an earcon."
+  :type 'string
+  :group 'earcon)
+
+(defcustom earcon-suffix "**"
+  "String denoting the end of an earcon."
+  :type 'string
+  :group 'earcon)
+
+(defcustom earcon-regexp-alist
+  '(("boring" 1 "Boring.au")
+    ("evil[ \t]+laugh" 1 "Evil_Laugh.au")
+    ("gag\\|puke" 1 "Puke.au")
+    ("snicker" 1 "Snicker.au")
+    ("meow" 1 "catmeow.au")
+    ("sob\\|boohoo" 1 "cry.wav")
+    ("drum[ \t]*roll" 1 "drumroll.au")
+    ("blast" 1 "explosion.au")
+    ("flush\\|plonk!*" 1 "flush.au")
+    ("kiss" 1 "kiss.wav")
+    ("tee[ \t]*hee" 1 "laugh.au")
+    ("shoot" 1 "shotgun.wav")
+    ("yawn" 1 "snore.wav")
+    ("cackle" 1 "witch.au")
+    ("yell\\|roar" 1 "yell2.au")
+    ("whoop-de-doo" 1 "whistle.au"))
+  "A list of regexps to map earcons to real sounds."
+  :type '(repeat (list regexp
+		       (integer :tag "Match")
+		       (string :tag "Sound")))
+  :group 'earcon)
+
+(defvar earcon-button-marker-list nil)
+(make-variable-buffer-local 'earcon-button-marker-list)
+
+
+
+;;; FIXME!! clone of code from gnus-vis.el FIXME!!
+(defun earcon-article-push-button (event)
+  "Check text under the mouse pointer for a callback function.
+If the text under the mouse pointer has a `earcon-callback' property,
+call it with the value of the `earcon-data' text property."
+  (interactive "e")
+  (set-buffer (window-buffer (posn-window (event-start event))))
+  (let* ((pos (posn-point (event-start event)))
+         (data (get-text-property pos 'earcon-data))
+	 (fun (get-text-property pos 'earcon-callback)))
+    (if fun (funcall fun data))))
+
+(defun earcon-article-press-button ()
+  "Check text at point for a callback function.
+If the text at point has a `earcon-callback' property,
+call it with the value of the `earcon-data' text property."
+  (interactive)
+  (let* ((data (get-text-property (point) 'earcon-data))
+	 (fun (get-text-property (point) 'earcon-callback)))
+    (if fun (funcall fun data))))
+
+(defun earcon-article-prev-button (n)
+  "Move point to N buttons backward.
+If N is negative, move forward instead."
+  (interactive "p")
+  (earcon-article-next-button (- n)))
+
+(defun earcon-article-next-button (n)
+  "Move point to N buttons forward.
+If N is negative, move backward instead."
+  (interactive "p")
+  (let ((function (if (< n 0) 'previous-single-property-change
+		    'next-single-property-change))
+	(inhibit-point-motion-hooks t)
+	(backward (< n 0))
+	(limit (if (< n 0) (point-min) (point-max))))
+    (setq n (abs n))
+    (while (and (not (= limit (point)))
+		(> n 0))
+      ;; Skip past the current button.
+      (when (get-text-property (point) 'earcon-callback)
+	(goto-char (funcall function (point) 'earcon-callback nil limit)))
+      ;; Go to the next (or previous) button.
+      (gnus-goto-char (funcall function (point) 'earcon-callback nil limit))
+      ;; Put point at the start of the button.
+      (when (and backward (not (get-text-property (point) 'earcon-callback)))
+	(goto-char (funcall function (point) 'earcon-callback nil limit)))
+      ;; Skip past intangible buttons.
+      (when (get-text-property (point) 'intangible)
+	(incf n))
+      (decf n))
+    (unless (zerop n)
+      (gnus-message 5 "No more buttons"))
+    n))
+
+(defun earcon-article-add-button (from to fun &optional data)
+  "Create a button between FROM and TO with callback FUN and data DATA."
+  (and (boundp gnus-article-button-face)
+       gnus-article-button-face
+       (gnus-overlay-put (gnus-make-overlay from to)
+			 'face gnus-article-button-face))
+  (gnus-add-text-properties
+   from to
+   (nconc (and gnus-article-mouse-face
+	       (list gnus-mouse-face-prop gnus-article-mouse-face))
+	  (list 'gnus-callback fun)
+	  (and data (list 'gnus-data data)))))
+
+(defun earcon-button-entry ()
+  ;; Return the first entry in `gnus-button-alist' matching this place.
+  (let ((alist earcon-regexp-alist)
+	(case-fold-search t)
+	(entry nil))
+    (while alist
+      (setq entry (pop alist))
+      (if (looking-at (car entry))
+	  (setq alist nil)
+	(setq entry nil)))
+    entry))
+
+
+(defun earcon-button-push (marker)
+  ;; Push button starting at MARKER.
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (goto-char marker)
+    (let* ((entry (earcon-button-entry))
+	   (inhibit-point-motion-hooks t)
+	   (fun 'gnus-audio-play)
+	   (args (list (nth 2 entry))))
+      (cond
+       ((fboundp fun)
+	(apply fun args))
+       ((and (boundp fun)
+	     (fboundp (symbol-value fun)))
+	(apply (symbol-value fun) args))
+       (t
+	(gnus-message 1 "You must define `%S' to use this button"
+		      (cons fun args)))))))
+
+;;; FIXME!! clone of code from gnus-vis.el FIXME!!
+
+;;;###interactive
+(defun earcon-region (beg end)
+  "Play Sounds in the region between point and mark."
+  (interactive "r")
+  (earcon-buffer (current-buffer) beg end))
+
+;;;###interactive
+(defun earcon-buffer (&optional buffer st nd)
+  (interactive)
+  (save-excursion
+    ;; clear old markers.
+    (if (boundp 'earcon-button-marker-list)
+	(while earcon-button-marker-list
+	  (set-marker (pop earcon-button-marker-list) nil))
+      (setq earcon-button-marker-list nil))
+    (and buffer (set-buffer buffer))
+    (let ((buffer-read-only nil)
+	  (inhibit-point-motion-hooks t)
+	  (case-fold-search t)
+	  (alist earcon-regexp-alist)
+	  beg entry regexp)
+      (goto-char (point-min))
+      (setq beg (point))
+      (while (setq entry (pop alist))
+	(setq regexp (concat (regexp-quote earcon-prefix)
+			     ".*\\("
+			     (car entry)
+			     "\\).*"
+			     (regexp-quote earcon-suffix)))
+	(goto-char beg)
+	(while (re-search-forward regexp nil t)
+	  (let* ((start (and entry (match-beginning 1)))
+		 (end (and entry (match-end 1)))
+		 (from (match-beginning 1)))
+	    (earcon-article-add-button
+	     start end 'earcon-button-push
+	     (car (push (set-marker (make-marker) from)
+			earcon-button-marker-list)))
+	    (gnus-audio-play (caddr entry))))))))
+
+;;;###autoload
+(defun gnus-earcon-display ()
+  "Play sounds in message buffers."
+  (interactive)
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (goto-char (point-min))
+    ;; Skip headers
+    (unless (search-forward "\n\n" nil t)
+      (goto-char (point-max)))
+    (sit-for 0)
+    (earcon-buffer (current-buffer) (point))))
+
+;;;***
+
+(provide 'earcon)
+
+(run-hooks 'earcon-load-hook)
+
+;;; earcon.el ends here

lisp/gnus/gnus-async.el

@@ -0,0 +1,315 @@
+;;; gnus-async.el --- asynchronous support for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-sum)
+(require 'nntp)
+
+(defgroup gnus-asynchronous nil
+  "Support for asynchronous operations."
+  :group 'gnus)
+
+(defcustom gnus-asynchronous t
+  "*If nil, inhibit all Gnus asynchronicity.
+If non-nil, let the other asynch variables be heeded."
+  :group 'gnus-asynchronous
+  :type 'boolean)
+
+(defcustom gnus-use-article-prefetch 30
+  "*If non-nil, prefetch articles in groups that allow this.
+If a number, prefetch only that many articles forward;
+if t, prefetch as many articles as possible."
+  :group 'gnus-asynchronous
+  :type '(choice (const :tag "off" nil)
+		 (const :tag "all" t)
+		 (integer :tag "some" 0)))
+
+(defcustom gnus-prefetched-article-deletion-strategy '(read exit)
+  "List of symbols that say when to remove articles from the prefetch buffer.
+Possible values in this list are `read', which means that
+articles are removed as they are read, and `exit', which means
+that all articles belonging to a group are removed on exit
+from that group."
+  :group 'gnus-asynchronous
+  :type '(set (const read) (const exit)))
+
+(defcustom gnus-use-header-prefetch nil
+  "*If non-nil, prefetch the headers to the next group."
+  :group 'gnus-asynchronous
+  :type 'boolean)
+
+(defcustom gnus-async-prefetch-article-p 'gnus-async-unread-p
+  "Function called to say whether an article should be prefetched or not.
+The function is called with one parameter -- the article data.
+It should return non-nil if the article is to be prefetched."
+  :group 'gnus-asynchronous
+  :type 'function)
+
+;;; Internal variables.
+
+(defvar gnus-async-prefetch-article-buffer " *Async Prefetch Article*")
+(defvar gnus-async-article-alist nil)
+(defvar gnus-async-article-semaphore '(nil))
+(defvar gnus-async-fetch-list nil)
+
+(defvar gnus-async-prefetch-headers-buffer " *Async Prefetch Headers*")
+(defvar gnus-async-header-prefetched nil)
+
+;;; Utility functions.
+
+(defun gnus-group-asynchronous-p (group)
+  "Say whether GROUP is fetched from a server that supports asynchronicity."
+  (gnus-asynchronous-p (gnus-find-method-for-group group)))
+
+;;; Somewhat bogus semaphores.
+
+(defun gnus-async-get-semaphore (semaphore)
+  "Wait until SEMAPHORE is released."
+  (while (/= (length (nconc (symbol-value semaphore) (list nil))) 2)
+    (sleep-for 1)))
+
+(defun gnus-async-release-semaphore (semaphore)
+  "Release SEMAPHORE."
+  (setcdr (symbol-value semaphore) nil))
+
+(defmacro gnus-async-with-semaphore (&rest forms)
+  `(unwind-protect
+       (progn
+	 (gnus-async-get-semaphore 'gnus-async-article-semaphore)
+	 ,@forms)
+     (gnus-async-release-semaphore 'gnus-async-article-semaphore)))
+
+(put 'gnus-asynch-with-semaphore 'lisp-indent-function 0)
+(put 'gnus-asynch-with-semaphore 'edebug-form-spec '(body))
+
+;;;
+;;; Article prefetch
+;;;
+
+(gnus-add-shutdown 'gnus-async-close 'gnus)
+(defun gnus-async-close ()
+  (gnus-kill-buffer gnus-async-prefetch-article-buffer)
+  (gnus-kill-buffer gnus-async-prefetch-headers-buffer)
+  (setq gnus-async-article-alist nil
+	gnus-async-header-prefetched nil))
+
+(defun gnus-async-set-buffer ()
+  (nnheader-set-temp-buffer gnus-async-prefetch-article-buffer t))
+
+(defun gnus-async-halt-prefetch ()
+  "Stop prefetching."
+  (setq gnus-async-fetch-list nil))
+
+(defun gnus-async-prefetch-next (group article summary)
+  "Possibly prefetch several articles starting with the article after ARTICLE."
+  (when (and (gnus-buffer-live-p summary)
+	     gnus-asynchronous
+	     (gnus-group-asynchronous-p group))
+    (save-excursion
+      (set-buffer gnus-summary-buffer)
+      (let ((next (caadr (gnus-data-find-list article))))
+	(when next
+	  (if (not (fboundp 'run-with-idle-timer))
+	      ;; This is either an older Emacs or XEmacs, so we
+	      ;; do this, which leads to slightly slower article
+	      ;; buffer display.
+	      (gnus-async-prefetch-article group next summary)
+	    (run-with-idle-timer
+	     0.1 nil 'gnus-async-prefetch-article group next summary)))))))
+
+(defun gnus-async-prefetch-article (group article summary &optional next)
+  "Possibly prefetch several articles starting with ARTICLE."
+  (if (not (gnus-buffer-live-p summary))
+      (gnus-async-with-semaphore
+       (setq gnus-async-fetch-list nil))
+    (when (and gnus-asynchronous
+	       (gnus-alive-p))
+      (when next
+	(gnus-async-with-semaphore
+	 (pop gnus-async-fetch-list)))
+      (let ((do-fetch next)
+	    (do-message t)) ;(eq major-mode 'gnus-summary-mode)))
+	(when (and (gnus-group-asynchronous-p group)
+		   (gnus-buffer-live-p summary)
+		   (or (not next)
+		       gnus-async-fetch-list))
+	  (gnus-async-with-semaphore
+	   (unless next
+	     (setq do-fetch (not gnus-async-fetch-list))
+	     ;; Nix out any outstanding requests.
+	     (setq gnus-async-fetch-list nil)
+	     ;; Fill in the new list.
+	     (let ((n gnus-use-article-prefetch)
+		   (data (gnus-data-find-list article))
+		   d)
+	       (while (and (setq d (pop data))
+			   (if (numberp n)
+			       (natnump (decf n))
+			     n))
+		 (unless (or (gnus-async-prefetched-article-entry
+			      group (setq article (gnus-data-number d)))
+			     (not (natnump article))
+			     (not (funcall gnus-async-prefetch-article-p d)))
+		   ;; Not already fetched -- so we add it to the list.
+		   (push article gnus-async-fetch-list)))
+	       (setq gnus-async-fetch-list
+		     (nreverse gnus-async-fetch-list))))
+
+	   (when do-fetch
+	     (setq article (car gnus-async-fetch-list))))
+
+	  (when (and do-fetch article)
+	    ;; We want to fetch some more articles.
+	    (save-excursion
+	      (set-buffer summary)
+	      (let (mark)
+		(gnus-async-set-buffer)
+		(goto-char (point-max))
+		(setq mark (point-marker))
+		(let ((nnheader-callback-function
+		       (gnus-make-async-article-function
+			group article mark summary next))
+		      (nntp-server-buffer
+		       (get-buffer gnus-async-prefetch-article-buffer)))
+		  (when do-message
+		    (gnus-message 9 "Prefetching article %d in group %s"
+				  article group))
+		  (gnus-request-article article group))))))))))
+
+(defun gnus-make-async-article-function (group article mark summary next)
+  "Return a callback function."
+  `(lambda (arg)
+     (save-excursion
+       (when arg
+	 (gnus-async-set-buffer)
+	 (gnus-async-with-semaphore
+	  (push (list ',(intern (format "%s-%d" group article))
+		      ,mark (set-marker (make-marker) (point-max))
+		      ,group ,article)
+		gnus-async-article-alist)))
+       (if (not (gnus-buffer-live-p ,summary))
+	   (gnus-async-with-semaphore
+	    (setq gnus-async-fetch-list nil))
+	 (gnus-async-prefetch-article ,group ,next ,summary t)))))
+
+(defun gnus-async-unread-p (data)
+  "Return non-nil if DATA represents an unread article."
+  (gnus-data-unread-p data))
+
+(defun gnus-async-request-fetched-article (group article buffer)
+  "See whether we have ARTICLE from GROUP and put it in BUFFER."
+  (when (numberp article)
+    (let ((entry (gnus-async-prefetched-article-entry group article)))
+      (when entry
+	(save-excursion
+	  (gnus-async-set-buffer)
+	  (copy-to-buffer buffer (cadr entry) (caddr entry))
+	  ;; Remove the read article from the prefetch buffer.
+	  (when (memq 'read gnus-prefetched-article-deletion-strategy)
+	    (gnus-async-delete-prefected-entry entry))
+	  t)))))
+
+(defun gnus-async-delete-prefected-entry (entry)
+  "Delete ENTRY from buffer and alist."
+  (ignore-errors
+    (delete-region (cadr entry) (caddr entry))
+    (set-marker (cadr entry) nil)
+    (set-marker (caddr entry) nil))
+  (gnus-async-with-semaphore
+   (setq gnus-async-article-alist
+	 (delq entry gnus-async-article-alist))))
+
+(defun gnus-async-prefetch-remove-group (group)
+  "Remove all articles belonging to GROUP from the prefetch buffer."
+  (when (and (gnus-group-asynchronous-p group)
+	     (memq 'exit gnus-prefetched-article-deletion-strategy))
+    (let ((alist gnus-async-article-alist))
+      (save-excursion
+	(gnus-async-set-buffer)
+	(while alist
+	  (when (equal group (nth 3 (car alist)))
+	    (gnus-async-delete-prefected-entry (car alist)))
+	  (pop alist))))))
+
+(defun gnus-async-prefetched-article-entry (group article)
+  "Return the entry for ARTICLE in GROUP iff it has been prefetched."
+  (let ((entry (assq (intern (format "%s-%d" group article))
+		     gnus-async-article-alist)))
+    ;; Perhaps something has emptied the buffer?
+    (if (and entry
+	     (= (cadr entry) (caddr entry)))
+	(progn
+	  (ignore-errors
+	    (set-marker (cadr entry) nil)
+	    (set-marker (caddr entry) nil))
+	  (setq gnus-async-article-alist
+		(delq entry gnus-async-article-alist))
+	  nil)
+      entry)))
+
+;;;
+;;; Header prefetch
+;;;
+
+(defun gnus-async-prefetch-headers (group)
+  "Prefetch the headers for group GROUP."
+  (save-excursion
+    (let (unread)
+      (when (and gnus-use-header-prefetch
+		 gnus-asynchronous
+		 (gnus-group-asynchronous-p group)
+		 (listp gnus-async-header-prefetched)
+		 (setq unread (gnus-list-of-unread-articles group)))
+	;; Mark that a fetch is in progress.
+	(setq gnus-async-header-prefetched t)
+	(nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t)
+	(erase-buffer)
+	(let ((nntp-server-buffer (current-buffer))
+	      (nnheader-callback-function
+	       `(lambda (arg)
+		  (setq gnus-async-header-prefetched
+			,(cons group unread)))))
+	  (gnus-retrieve-headers unread group gnus-fetch-old-headers))))))
+
+(defun gnus-async-retrieve-fetched-headers (articles group)
+  "See whether we have prefetched headers."
+  (when (and gnus-use-header-prefetch
+	     (gnus-group-asynchronous-p group)
+	     (listp gnus-async-header-prefetched)
+	     (equal group (car gnus-async-header-prefetched))
+	     (equal articles (cdr gnus-async-header-prefetched)))
+    (save-excursion
+      (nnheader-set-temp-buffer gnus-async-prefetch-headers-buffer t)
+      (nntp-decode-text)
+      (copy-to-buffer nntp-server-buffer (point-min) (point-max))
+      (erase-buffer)
+      (setq gnus-async-header-prefetched nil)
+      t)))
+
+(provide 'gnus-async)
+
+;;; gnus-async.el ends here

lisp/gnus/gnus-audio.el

@@ -0,0 +1,132 @@
+;;; gnus-audio.el --- Sound effects for Gnus
+;; Copyright (C) 1996 Free Software Foundation
+
+;; Author: Steven L. Baur <steve@miranova.com>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+;; This file provides access to sound effects in Gnus.
+;; Prerelease:  This file is partially stripped to support earcons.el
+;; You can safely ignore most of it until Red Gnus.  **Evil Laugh**
+;;; Code:
+
+(when (null (boundp 'running-xemacs))
+  (defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version)))
+
+(require 'nnheader)
+(eval-when-compile (require 'cl))
+
+(defvar gnus-audio-inline-sound
+  (and (fboundp 'device-sound-enabled-p)
+       (device-sound-enabled-p))
+  "When t, we will not spawn a subprocess to play sounds.")
+
+(defvar gnus-audio-directory (nnheader-find-etc-directory "sounds")
+  "The directory containing the Sound Files.")
+
+(defvar gnus-audio-au-player "/usr/bin/showaudio"
+  "Executable program for playing sun AU format sound files")
+(defvar gnus-audio-wav-player "/usr/local/bin/play"
+  "Executable program for playing WAV files")
+
+
+;;; The following isn't implemented yet.  Wait for Red Gnus.
+;(defvar gnus-audio-effects-enabled t
+;  "When t, Gnus will use sound effects.")
+;(defvar gnus-audio-enable-hooks nil
+;  "Functions run when enabling sound effects.")
+;(defvar gnus-audio-disable-hooks nil
+;  "Functions run when disabling sound effects.")
+;(defvar gnus-audio-theme-song nil
+;  "Theme song for Gnus.")
+;(defvar gnus-audio-enter-group nil
+;  "Sound effect played when selecting a group.")
+;(defvar gnus-audio-exit-group nil
+;  "Sound effect played when exiting a group.")
+;(defvar gnus-audio-score-group nil
+;  "Sound effect played when scoring a group.")
+;(defvar gnus-audio-busy-sound nil
+;  "Sound effect played when going into a ... sequence.")
+
+
+;;;###autoload
+					;(defun gnus-audio-enable-sound ()
+;  "Enable Sound Effects for Gnus."
+;  (interactive)
+;  (setq gnus-audio-effects-enabled t)
+;  (run-hooks gnus-audio-enable-hooks))
+
+;;;###autoload
+					;(defun gnus-audio-disable-sound ()
+;  "Disable Sound Effects for Gnus."
+;  (interactive)
+;  (setq gnus-audio-effects-enabled nil)
+;  (run-hooks gnus-audio-disable-hooks))
+
+;;;###autoload
+(defun gnus-audio-play (file)
+  "Play a sound through the speaker."
+  (interactive)
+  (let ((sound-file (if (file-exists-p file)
+			file
+		      (concat gnus-audio-directory file))))
+    (when (file-exists-p sound-file)
+      (if gnus-audio-inline-sound
+	  (play-sound-file sound-file)
+	(cond ((string-match "\\.wav$" sound-file)
+	       (call-process gnus-audio-wav-player
+			     sound-file
+			     0
+			     nil
+			     sound-file))
+	      ((string-match "\\.au$" sound-file)
+	       (call-process gnus-audio-au-player
+			     sound-file
+			     0
+			     nil
+			     sound-file)))))))
+
+
+;;; The following isn't implemented yet, wait for Red Gnus
+					;(defun gnus-audio-startrek-sounds ()
+;  "Enable sounds from Star Trek the original series."
+;  (interactive)
+;  (setq gnus-audio-busy-sound "working.au")
+;  (setq gnus-audio-enter-group "bulkhead_door.au")
+;  (setq gnus-audio-exit-group "bulkhead_door.au")
+;  (setq gnus-audio-score-group "ST_laser.au")
+;  (setq gnus-audio-theme-song "startrek.au")
+;  (add-hook 'gnus-select-group-hook 'gnus-audio-startrek-select-group)
+;  (add-hook 'gnus-exit-group-hook 'gnus-audio-startrek-exit-group))
+;;;***
+
+(defvar gnus-startup-jingle "Tuxedomoon.Jingle4.au"
+  "Name of the Gnus startup jingle file.")
+
+(defun gnus-play-jingle ()
+  "Play the Gnus startup jingle, unless that's inhibited."
+  (interactive)
+  (gnus-audio-play gnus-startup-jingle))
+
+(provide 'gnus-audio)
+
+(run-hooks 'gnus-audio-load-hook)
+
+;;; gnus-audio.el ends here

lisp/gnus/gnus-bcklg.el

@@ -0,0 +1,152 @@
+;;; gnus-bcklg.el --- backlog functions for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+
+;;;
+;;; Buffering of read articles.
+;;;
+
+(defvar gnus-backlog-buffer " *Gnus Backlog*")
+(defvar gnus-backlog-articles nil)
+(defvar gnus-backlog-hashtb nil)
+
+(defun gnus-backlog-buffer ()
+  "Return the backlog buffer."
+  (or (get-buffer gnus-backlog-buffer)
+      (save-excursion
+	(set-buffer (get-buffer-create gnus-backlog-buffer))
+	(buffer-disable-undo (current-buffer))
+	(setq buffer-read-only t)
+	(gnus-add-current-to-buffer-list)
+	(get-buffer gnus-backlog-buffer))))
+
+(defun gnus-backlog-setup ()
+  "Initialize backlog variables."
+  (unless gnus-backlog-hashtb
+    (setq gnus-backlog-hashtb (gnus-make-hashtable 1024))))
+
+(gnus-add-shutdown 'gnus-backlog-shutdown 'gnus)
+
+(defun gnus-backlog-shutdown ()
+  "Clear all backlog variables and buffers."
+  (when (get-buffer gnus-backlog-buffer)
+    (kill-buffer gnus-backlog-buffer))
+  (setq gnus-backlog-hashtb nil
+	gnus-backlog-articles nil))
+
+(defun gnus-backlog-enter-article (group number buffer)
+  (gnus-backlog-setup)
+  (let ((ident (intern (concat group ":" (int-to-string number))
+		       gnus-backlog-hashtb))
+	b)
+    (if (memq ident gnus-backlog-articles)
+	()				; It's already kept.
+      ;; Remove the oldest article, if necessary.
+      (and (numberp gnus-keep-backlog)
+	   (>= (length gnus-backlog-articles) gnus-keep-backlog)
+	   (gnus-backlog-remove-oldest-article))
+      (push ident gnus-backlog-articles)
+      ;; Insert the new article.
+      (save-excursion
+	(set-buffer (gnus-backlog-buffer))
+	(let (buffer-read-only)
+	  (goto-char (point-max))
+	  (unless (bolp)
+	    (insert "\n"))
+	  (setq b (point))
+	  (insert-buffer-substring buffer)
+	  ;; Tag the beginning of the article with the ident.
+	  (gnus-put-text-property b (1+ b) 'gnus-backlog ident))))))
+
+(defun gnus-backlog-remove-oldest-article ()
+  (save-excursion
+    (set-buffer (gnus-backlog-buffer))
+    (goto-char (point-min))
+    (if (zerop (buffer-size))
+	()				; The buffer is empty.
+      (let ((ident (get-text-property (point) 'gnus-backlog))
+	    buffer-read-only)
+	;; Remove the ident from the list of articles.
+	(when ident
+	  (setq gnus-backlog-articles (delq ident gnus-backlog-articles)))
+	;; Delete the article itself.
+	(delete-region
+	 (point) (next-single-property-change
+		  (1+ (point)) 'gnus-backlog nil (point-max)))))))
+
+(defun gnus-backlog-remove-article (group number)
+  "Remove article NUMBER in GROUP from the backlog."
+  (when (numberp number)
+    (gnus-backlog-setup)
+    (let ((ident (intern (concat group ":" (int-to-string number))
+			 gnus-backlog-hashtb))
+	  beg end)
+      (when (memq ident gnus-backlog-articles)
+	;; It was in the backlog.
+	(save-excursion
+	  (set-buffer (gnus-backlog-buffer))
+	  (let (buffer-read-only)
+	    (when (setq beg (text-property-any
+			     (point-min) (point-max) 'gnus-backlog
+			     ident))
+	      ;; Find the end (i. e., the beginning of the next article).
+	      (setq end
+		    (next-single-property-change
+		     (1+ beg) 'gnus-backlog (current-buffer) (point-max)))
+	      (delete-region beg end)
+	      ;; Return success.
+	      t)))))))
+
+(defun gnus-backlog-request-article (group number buffer)
+  (when (numberp number)
+    (gnus-backlog-setup)
+    (let ((ident (intern (concat group ":" (int-to-string number))
+			 gnus-backlog-hashtb))
+	  beg end)
+      (when (memq ident gnus-backlog-articles)
+	;; It was in the backlog.
+	(save-excursion
+	  (set-buffer (gnus-backlog-buffer))
+	  (if (not (setq beg (text-property-any
+			      (point-min) (point-max) 'gnus-backlog
+			      ident)))
+	      ;; It wasn't in the backlog after all.
+	      (ignore
+	       (setq gnus-backlog-articles (delq ident gnus-backlog-articles)))
+	    ;; Find the end (i. e., the beginning of the next article).
+	    (setq end
+		  (next-single-property-change
+		   (1+ beg) 'gnus-backlog (current-buffer) (point-max)))))
+	(let ((buffer-read-only nil))
+	  (erase-buffer)
+	  (insert-buffer-substring gnus-backlog-buffer beg end)
+	  t)))))
+
+(provide 'gnus-bcklg)
+
+;;; gnus-bcklg.el ends here

lisp/gnus/gnus-cache.el

@@ -0,0 +1,657 @@
+;;; gnus-cache.el --- cache interface for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-int)
+(require 'gnus-range)
+(require 'gnus-start)
+(eval-when-compile
+  (require 'gnus-sum))
+
+(defgroup gnus-cache nil
+  "Cache interface."
+  :group 'gnus)
+
+(defcustom gnus-cache-directory
+  (nnheader-concat gnus-directory "cache/")
+  "*The directory where cached articles will be stored."
+  :group 'gnus-cache
+  :type 'directory)
+
+(defcustom gnus-cache-active-file
+  (concat (file-name-as-directory gnus-cache-directory) "active")
+  "*The cache active file."
+  :group 'gnus-cache
+  :type 'file)
+
+(defcustom gnus-cache-enter-articles '(ticked dormant)
+  "Classes of articles to enter into the cache."
+  :group 'gnus-cache
+  :type '(set (const ticked) (const dormant) (const unread) (const read)))
+
+(defcustom gnus-cache-remove-articles '(read)
+  "Classes of articles to remove from the cache."
+  :group 'gnus-cache
+  :type '(set (const ticked) (const dormant) (const unread) (const read)))
+
+(defcustom gnus-uncacheable-groups nil
+  "*Groups that match this regexp will not be cached.
+
+If you want to avoid caching your nnml groups, you could set this
+variable to \"^nnml\"."
+  :group 'gnus-cache
+  :type '(choice (const :tag "off" nil)
+		 regexp))
+
+
+
+;;; Internal variables.
+
+(defvar gnus-cache-removable-articles nil)
+(defvar gnus-cache-buffer nil)
+(defvar gnus-cache-active-hashtb nil)
+(defvar gnus-cache-active-altered nil)
+
+(eval-and-compile
+  (autoload 'nnml-generate-nov-databases-1 "nnml")
+  (autoload 'nnvirtual-find-group-art "nnvirtual"))
+
+
+
+;;; Functions called from Gnus.
+
+(defun gnus-cache-open ()
+  "Initialize the cache."
+  (when (or (file-exists-p gnus-cache-directory)
+	    (and gnus-use-cache
+		 (not (eq gnus-use-cache 'passive))))
+    (gnus-cache-read-active)))
+
+;; Complexities of byte-compiling make this kludge necessary.  Eeek.
+(ignore-errors
+  (gnus-add-shutdown 'gnus-cache-close 'gnus))
+
+(defun gnus-cache-close ()
+  "Shut down the cache."
+  (gnus-cache-write-active)
+  (gnus-cache-save-buffers)
+  (setq gnus-cache-active-hashtb nil))
+
+(defun gnus-cache-save-buffers ()
+  ;; save the overview buffer if it exists and has been modified
+  ;; delete empty cache subdirectories
+  (when gnus-cache-buffer
+    (let ((buffer (cdr gnus-cache-buffer))
+	  (overview-file (gnus-cache-file-name
+			  (car gnus-cache-buffer) ".overview")))
+      ;; write the overview only if it was modified
+      (when (buffer-modified-p buffer)
+	(save-excursion
+	  (set-buffer buffer)
+	  (if (> (buffer-size) 0)
+	      ;; Non-empty overview, write it to a file.
+	      (gnus-write-buffer overview-file)
+	    ;; Empty overview file, remove it
+	    (when (file-exists-p overview-file)
+	      (delete-file overview-file))
+	    ;; If possible, remove group's cache subdirectory.
+	    (condition-case nil
+		;; FIXME: we can detect the error type and warn the user
+		;; of any inconsistencies (articles w/o nov entries?).
+		;; for now, just be conservative...delete only if safe -- sj
+		(delete-directory (file-name-directory overview-file))
+	      (error nil)))))
+      ;; Kill the buffer -- it's either unmodified or saved.
+      (gnus-kill-buffer buffer)
+      (setq gnus-cache-buffer nil))))
+
+(defun gnus-cache-possibly-enter-article
+  (group article headers ticked dormant unread &optional force)
+  (when (and (or force (not (eq gnus-use-cache 'passive)))
+	     (numberp article)
+	     (> article 0)
+	     (vectorp headers))		; This might be a dummy article.
+    ;; If this is a virtual group, we find the real group.
+    (when (gnus-virtual-group-p group)
+      (let ((result (nnvirtual-find-group-art
+		     (gnus-group-real-name group) article)))
+	(setq group (car result)
+	      headers (copy-sequence headers))
+	(mail-header-set-number headers (cdr result))))
+    (let ((number (mail-header-number headers))
+	  file dir)
+      (when (and (> number 0)		; Reffed article.
+		 (or force
+		     (and (or (not gnus-uncacheable-groups)
+			      (not (string-match
+				    gnus-uncacheable-groups group)))
+			  (gnus-cache-member-of-class
+			   gnus-cache-enter-articles ticked dormant unread)))
+		 (not (file-exists-p (setq file (gnus-cache-file-name
+						 group number)))))
+	;; Possibly create the cache directory.
+	(gnus-make-directory (setq dir (file-name-directory file)))
+	;; Save the article in the cache.
+	(if (file-exists-p file)
+	    t				; The article already is saved.
+	  (save-excursion
+	    (set-buffer nntp-server-buffer)
+	    (let ((gnus-use-cache nil))
+	      (gnus-request-article-this-buffer number group))
+	    (when (> (buffer-size) 0)
+	      (gnus-write-buffer file)
+	      (gnus-cache-change-buffer group)
+	      (set-buffer (cdr gnus-cache-buffer))
+	      (goto-char (point-max))
+	      (forward-line -1)
+	      (while (condition-case ()
+			 (when (not (bobp))
+			   (> (read (current-buffer)) number))
+		       (error
+			;; The line was malformed, so we just remove it!!
+			(gnus-delete-line)
+			t))
+		(forward-line -1))
+	      (if (bobp)
+		  (if (not (eobp))
+		      (progn
+			(beginning-of-line)
+			(when (< (read (current-buffer)) number)
+			  (forward-line 1)))
+		    (beginning-of-line))
+		(forward-line 1))
+	      (beginning-of-line)
+	      ;; [number subject from date id references chars lines xref]
+	      (insert (format "%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t%s\t\n"
+			      (mail-header-number headers)
+			      (mail-header-subject headers)
+			      (mail-header-from headers)
+			      (mail-header-date headers)
+			      (mail-header-id headers)
+			      (or (mail-header-references headers) "")
+			      (or (mail-header-chars headers) "")
+			      (or (mail-header-lines headers) "")
+			      (or (mail-header-xref headers) "")))
+	      ;; Update the active info.
+	      (set-buffer gnus-summary-buffer)
+	      (gnus-cache-update-active group number)
+	      (push article gnus-newsgroup-cached)
+	      (gnus-summary-update-secondary-mark article))
+	    t))))))
+
+(defun gnus-cache-enter-remove-article (article)
+  "Mark ARTICLE for later possible removal."
+  (when article
+    (push article gnus-cache-removable-articles)))
+
+(defun gnus-cache-possibly-remove-articles ()
+  "Possibly remove some of the removable articles."
+  (if (not (gnus-virtual-group-p gnus-newsgroup-name))
+      (gnus-cache-possibly-remove-articles-1)
+    (let ((arts gnus-cache-removable-articles)
+	  ga)
+      (while arts
+	(when (setq ga (nnvirtual-find-group-art
+			(gnus-group-real-name gnus-newsgroup-name) (pop arts)))
+	  (let ((gnus-cache-removable-articles (list (cdr ga)))
+		(gnus-newsgroup-name (car ga)))
+	    (gnus-cache-possibly-remove-articles-1)))))
+    (setq gnus-cache-removable-articles nil)))
+
+(defun gnus-cache-possibly-remove-articles-1 ()
+  "Possibly remove some of the removable articles."
+  (unless (eq gnus-use-cache 'passive)
+    (let ((articles gnus-cache-removable-articles)
+	  (cache-articles gnus-newsgroup-cached)
+	  article)
+      (gnus-cache-change-buffer gnus-newsgroup-name)
+      (while articles
+	(when (memq (setq article (pop articles)) cache-articles)
+	  ;; The article was in the cache, so we see whether we are
+	  ;; supposed to remove it from the cache.
+	  (gnus-cache-possibly-remove-article
+	   article (memq article gnus-newsgroup-marked)
+	   (memq article gnus-newsgroup-dormant)
+	   (or (memq article gnus-newsgroup-unreads)
+	       (memq article gnus-newsgroup-unselected))))))
+    ;; The overview file might have been modified, save it
+    ;; safe because we're only called at group exit anyway.
+    (gnus-cache-save-buffers)))
+
+(defun gnus-cache-request-article (article group)
+  "Retrieve ARTICLE in GROUP from the cache."
+  (let ((file (gnus-cache-file-name group article))
+	(buffer-read-only nil))
+    (when (file-exists-p file)
+      (erase-buffer)
+      (gnus-kill-all-overlays)
+      (insert-file-contents file)
+      t)))
+
+(defun gnus-cache-possibly-alter-active (group active)
+  "Alter the ACTIVE info for GROUP to reflect the articles in the cache."
+  (when (equal group "no.norsk") (error "hie"))
+  (when gnus-cache-active-hashtb
+    (let ((cache-active (gnus-gethash group gnus-cache-active-hashtb)))
+      (and cache-active
+	   (< (car cache-active) (car active))
+	   (setcar active (car cache-active)))
+      (and cache-active
+	   (> (cdr cache-active) (cdr active))
+	   (setcdr active (cdr cache-active))))))
+
+(defun gnus-cache-retrieve-headers (articles group &optional fetch-old)
+  "Retrieve the headers for ARTICLES in GROUP."
+  (let ((cached
+	 (setq gnus-newsgroup-cached (gnus-cache-articles-in-group group))))
+    (if (not cached)
+	;; No cached articles here, so we just retrieve them
+	;; the normal way.
+	(let ((gnus-use-cache nil))
+	  (gnus-retrieve-headers articles group fetch-old))
+      (let ((uncached-articles (gnus-sorted-intersection
+				(gnus-sorted-complement articles cached)
+				articles))
+	    (cache-file (gnus-cache-file-name group ".overview"))
+	    type)
+	;; We first retrieve all the headers that we don't have in
+	;; the cache.
+	(let ((gnus-use-cache nil))
+	  (when uncached-articles
+	    (setq type (and articles
+			    (gnus-retrieve-headers
+			     uncached-articles group fetch-old)))))
+	(gnus-cache-save-buffers)
+	;; Then we insert the cached headers.
+	(save-excursion
+	  (cond
+	   ((not (file-exists-p cache-file))
+	    ;; There are no cached headers.
+	    type)
+	   ((null type)
+	    ;; There were no uncached headers (or retrieval was
+	    ;; unsuccessful), so we use the cached headers exclusively.
+	    (set-buffer nntp-server-buffer)
+	    (erase-buffer)
+	    (insert-file-contents cache-file)
+	    'nov)
+	   ((eq type 'nov)
+	    ;; We have both cached and uncached NOV headers, so we
+	    ;; braid them.
+	    (gnus-cache-braid-nov group cached)
+	    type)
+	   (t
+	    ;; We braid HEADs.
+	    (gnus-cache-braid-heads group (gnus-sorted-intersection
+					   cached articles))
+	    type)))))))
+
+(defun gnus-cache-enter-article (&optional n)
+  "Enter the next N articles into the cache.
+If not given a prefix, use the process marked articles instead.
+Returns the list of articles entered."
+  (interactive "P")
+  (gnus-set-global-variables)
+  (let ((articles (gnus-summary-work-articles n))
+	article out)
+    (while (setq article (pop articles))
+      (if (natnump article)
+	  (when (gnus-cache-possibly-enter-article
+		 gnus-newsgroup-name article
+		 (gnus-summary-article-header article)
+		 nil nil nil t)
+	    (push article out))
+	(gnus-message 2 "Can't cache article %d" article))
+      (gnus-summary-remove-process-mark article)
+      (gnus-summary-update-secondary-mark article))
+    (gnus-summary-next-subject 1)
+    (gnus-summary-position-point)
+    (nreverse out)))
+
+(defun gnus-cache-remove-article (n)
+  "Remove the next N articles from the cache.
+If not given a prefix, use the process marked articles instead.
+Returns the list of articles removed."
+  (interactive "P")
+  (gnus-set-global-variables)
+  (gnus-cache-change-buffer gnus-newsgroup-name)
+  (let ((articles (gnus-summary-work-articles n))
+	article out)
+    (while articles
+      (setq article (pop articles))
+      (when (gnus-cache-possibly-remove-article article nil nil nil t)
+	(push article out))
+      (gnus-summary-remove-process-mark article)
+      (gnus-summary-update-secondary-mark article))
+    (gnus-summary-next-subject 1)
+    (gnus-summary-position-point)
+    (nreverse out)))
+
+(defun gnus-cached-article-p (article)
+  "Say whether ARTICLE is cached in the current group."
+  (memq article gnus-newsgroup-cached))
+
+(defun gnus-summary-insert-cached-articles ()
+  "Insert all the articles cached for this group into the current buffer."
+  (interactive)
+  (let ((cached gnus-newsgroup-cached)
+	(gnus-verbose (max 6 gnus-verbose)))
+    (unless cached
+      (error "No cached articles for this group"))
+    (while cached
+      (gnus-summary-goto-subject (pop cached) t))))
+
+;;; Internal functions.
+
+(defun gnus-cache-change-buffer (group)
+  (and gnus-cache-buffer
+       ;; See if the current group's overview cache has been loaded.
+       (or (string= group (car gnus-cache-buffer))
+	   ;; Another overview cache is current, save it.
+	   (gnus-cache-save-buffers)))
+  ;; if gnus-cache buffer is nil, create it
+  (unless gnus-cache-buffer
+    ;; Create cache buffer
+    (save-excursion
+      (setq gnus-cache-buffer
+	    (cons group
+		  (set-buffer (get-buffer-create " *gnus-cache-overview*"))))
+      (buffer-disable-undo (current-buffer))
+      ;; Insert the contents of this group's cache overview.
+      (erase-buffer)
+      (let ((file (gnus-cache-file-name group ".overview")))
+	(when (file-exists-p file)
+	  (nnheader-insert-file-contents file)))
+      ;; We have a fresh (empty/just loaded) buffer,
+      ;; mark it as unmodified to save a redundant write later.
+      (set-buffer-modified-p nil))))
+
+;; Return whether an article is a member of a class.
+(defun gnus-cache-member-of-class (class ticked dormant unread)
+  (or (and ticked (memq 'ticked class))
+      (and dormant (memq 'dormant class))
+      (and unread (memq 'unread class))
+      (and (not unread) (not ticked) (not dormant) (memq 'read class))))
+
+(defun gnus-cache-file-name (group article)
+  (concat (file-name-as-directory gnus-cache-directory)
+	  (file-name-as-directory
+	   (nnheader-translate-file-chars
+	    (if (gnus-use-long-file-name 'not-cache)
+		group
+	      (let ((group (nnheader-replace-chars-in-string group ?/ ?_)))
+		;; Translate the first colon into a slash.
+		(when (string-match ":" group)
+		  (aset group (match-beginning 0) ?/))
+		(nnheader-replace-chars-in-string group ?. ?/)))))
+	  (if (stringp article) article (int-to-string article))))
+
+(defun gnus-cache-update-article (group article)
+  "If ARTICLE is in the cache, remove it and re-enter it."
+  (when (gnus-cache-possibly-remove-article article nil nil nil t)
+    (let ((gnus-use-cache nil))
+      (gnus-cache-possibly-enter-article
+       gnus-newsgroup-name article (gnus-summary-article-header article)
+       nil nil nil t))))
+
+(defun gnus-cache-possibly-remove-article (article ticked dormant unread
+						   &optional force)
+  "Possibly remove ARTICLE from the cache."
+  (let ((group gnus-newsgroup-name)
+	(number article)
+	file)
+    ;; If this is a virtual group, we find the real group.
+    (when (gnus-virtual-group-p group)
+      (let ((result (nnvirtual-find-group-art
+		     (gnus-group-real-name group) article)))
+	(setq group (car result)
+	      number (cdr result))))
+    (setq file (gnus-cache-file-name group number))
+    (when (and (file-exists-p file)
+	       (or force
+		   (gnus-cache-member-of-class
+		    gnus-cache-remove-articles ticked dormant unread)))
+      (save-excursion
+	(delete-file file)
+	(set-buffer (cdr gnus-cache-buffer))
+	(goto-char (point-min))
+	(when (or (looking-at (concat (int-to-string number) "\t"))
+		  (search-forward (concat "\n" (int-to-string number) "\t")
+				  (point-max) t))
+	  (delete-region (progn (beginning-of-line) (point))
+			 (progn (forward-line 1) (point)))))
+      (setq gnus-newsgroup-cached
+	    (delq article gnus-newsgroup-cached))
+      (gnus-summary-update-secondary-mark article)
+      t)))
+
+(defun gnus-cache-articles-in-group (group)
+  "Return a sorted list of cached articles in GROUP."
+  (let ((dir (file-name-directory (gnus-cache-file-name group 1))))
+    (when (file-exists-p dir)
+      (sort (mapcar (lambda (name) (string-to-int name))
+		    (directory-files dir nil "^[0-9]+$" t))
+	    '<))))
+
+(defun gnus-cache-braid-nov (group cached)
+  (let ((cache-buf (get-buffer-create " *gnus-cache*"))
+	beg end)
+    (gnus-cache-save-buffers)
+    (save-excursion
+      (set-buffer cache-buf)
+      (buffer-disable-undo (current-buffer))
+      (erase-buffer)
+      (insert-file-contents (gnus-cache-file-name group ".overview"))
+      (goto-char (point-min))
+      (insert "\n")
+      (goto-char (point-min)))
+    (set-buffer nntp-server-buffer)
+    (goto-char (point-min))
+    (while cached
+      (while (and (not (eobp))
+		  (< (read (current-buffer)) (car cached)))
+	(forward-line 1))
+      (beginning-of-line)
+      (save-excursion
+	(set-buffer cache-buf)
+	(if (search-forward (concat "\n" (int-to-string (car cached)) "\t")
+			    nil t)
+	    (setq beg (progn (beginning-of-line) (point))
+		  end (progn (end-of-line) (point)))
+	  (setq beg nil)))
+      (when beg
+	(insert-buffer-substring cache-buf beg end)
+	(insert "\n"))
+      (setq cached (cdr cached)))
+    (kill-buffer cache-buf)))
+
+(defun gnus-cache-braid-heads (group cached)
+  (let ((cache-buf (get-buffer-create " *gnus-cache*")))
+    (save-excursion
+      (set-buffer cache-buf)
+      (buffer-disable-undo (current-buffer))
+      (erase-buffer))
+    (set-buffer nntp-server-buffer)
+    (goto-char (point-min))
+    (while cached
+      (while (and (not (eobp))
+		  (looking-at "2.. +\\([0-9]+\\) ")
+		  (< (progn (goto-char (match-beginning 1))
+			    (read (current-buffer)))
+		     (car cached)))
+	(search-forward "\n.\n" nil 'move))
+      (beginning-of-line)
+      (save-excursion
+	(set-buffer cache-buf)
+	(erase-buffer)
+	(insert-file-contents (gnus-cache-file-name group (car cached)))
+	(goto-char (point-min))
+	(insert "220 ")
+	(princ (car cached) (current-buffer))
+	(insert " Article retrieved.\n")
+	(search-forward "\n\n" nil 'move)
+	(delete-region (point) (point-max))
+	(forward-char -1)
+	(insert "."))
+      (insert-buffer-substring cache-buf)
+      (setq cached (cdr cached)))
+    (kill-buffer cache-buf)))
+
+;;;###autoload
+(defun gnus-jog-cache ()
+  "Go through all groups and put the articles into the cache.
+
+Usage:
+$ emacs -batch -l ~/.emacs -l gnus -f gnus-jog-cache"
+  (interactive)
+  (let ((gnus-mark-article-hook nil)
+	(gnus-expert-user t)
+	(nnmail-spool-file nil)
+	(gnus-use-dribble-file nil)
+	(gnus-novice-user nil)
+	(gnus-large-newsgroup nil))
+    ;; Start Gnus.
+    (gnus)
+    ;; Go through all groups...
+    (gnus-group-mark-buffer)
+    (gnus-group-universal-argument
+     nil nil
+     (lambda ()
+       (interactive)
+       (gnus-summary-read-group (gnus-group-group-name) nil t)
+       ;; ... and enter the articles into the cache.
+       (when (eq major-mode 'gnus-summary-mode)
+	 (gnus-uu-mark-buffer)
+	 (gnus-cache-enter-article)
+	 (kill-buffer (current-buffer)))))))
+
+(defun gnus-cache-read-active (&optional force)
+  "Read the cache active file."
+  (gnus-make-directory gnus-cache-directory)
+  (if (not (and (file-exists-p gnus-cache-active-file)
+		(or force (not gnus-cache-active-hashtb))))
+      ;; There is no active file, so we generate one.
+      (gnus-cache-generate-active)
+    ;; We simply read the active file.
+    (save-excursion
+      (gnus-set-work-buffer)
+      (insert-file-contents gnus-cache-active-file)
+      (gnus-active-to-gnus-format
+       nil (setq gnus-cache-active-hashtb
+		 (gnus-make-hashtable
+		  (count-lines (point-min) (point-max)))))
+      (setq gnus-cache-active-altered nil))))
+
+(defun gnus-cache-write-active (&optional force)
+  "Write the active hashtb to the active file."
+  (when (or force
+	    (and gnus-cache-active-hashtb
+		 gnus-cache-active-altered))
+    (nnheader-temp-write gnus-cache-active-file
+      (mapatoms
+       (lambda (sym)
+	 (when (and sym (boundp sym))
+	   (insert (format "%s %d %d y\n"
+			   (symbol-name sym) (cdr (symbol-value sym))
+			   (car (symbol-value sym))))))
+       gnus-cache-active-hashtb))
+    ;; Mark the active hashtb as unaltered.
+    (setq gnus-cache-active-altered nil)))
+
+(defun gnus-cache-update-active (group number &optional low)
+  "Update the upper bound of the active info of GROUP to NUMBER.
+If LOW, update the lower bound instead."
+  (let ((active (gnus-gethash group gnus-cache-active-hashtb)))
+    (if (null active)
+	;; We just create a new active entry for this group.
+	(gnus-sethash group (cons number number) gnus-cache-active-hashtb)
+      ;; Update the lower or upper bound.
+      (if low
+	  (setcar active number)
+	(setcdr active number)))
+    ;; Mark the active hashtb as altered.
+    (setq gnus-cache-active-altered t)))
+
+;;;###autoload
+(defun gnus-cache-generate-active (&optional directory)
+  "Generate the cache active file."
+  (interactive)
+  (let* ((top (null directory))
+	 (directory (expand-file-name (or directory gnus-cache-directory)))
+	 (files (directory-files directory 'full))
+	 (group
+	  (if top
+	      ""
+	    (string-match
+	     (concat "^" (file-name-as-directory
+			  (expand-file-name gnus-cache-directory)))
+	     (directory-file-name directory))
+	    (nnheader-replace-chars-in-string
+	     (substring (directory-file-name directory) (match-end 0))
+	     ?/ ?.)))
+	 nums alphs)
+    (when top
+      (gnus-message 5 "Generating the cache active file...")
+      (setq gnus-cache-active-hashtb (gnus-make-hashtable 123)))
+    ;; Separate articles from all other files and directories.
+    (while files
+      (if (string-match "^[0-9]+$" (file-name-nondirectory (car files)))
+	  (push (string-to-int (file-name-nondirectory (pop files))) nums)
+	(push (pop files) alphs)))
+    ;; If we have nums, then this is probably a valid group.
+    (when (setq nums (sort nums '<))
+      (gnus-sethash group (cons (car nums) (gnus-last-element nums))
+		    gnus-cache-active-hashtb))
+    ;; Go through all the other files.
+    (while alphs
+      (when (and (file-directory-p (car alphs))
+		 (not (string-match "^\\.\\.?$"
+				    (file-name-nondirectory (car alphs)))))
+	;; We descend directories.
+	(gnus-cache-generate-active (car alphs)))
+      (setq alphs (cdr alphs)))
+    ;; Write the new active file.
+    (when top
+      (gnus-cache-write-active t)
+      (gnus-message 5 "Generating the cache active file...done"))))
+
+;;;###autoload
+(defun gnus-cache-generate-nov-databases (dir)
+  "Generate NOV files recursively starting in DIR."
+  (interactive (list gnus-cache-directory))
+  (gnus-cache-close)
+  (let ((nnml-generate-active-function 'identity))
+    (nnml-generate-nov-databases-1 dir)))
+
+(defun gnus-cache-move-cache (dir)
+  "Move the cache tree to somewhere else."
+  (interactive "DMove the cache tree to: ")
+  (rename-file gnus-cache-directory dir))
+
+(provide 'gnus-cache)
+
+;;; gnus-cache.el ends here

lisp/gnus/gnus-cite.el

@@ -0,0 +1,911 @@
+;;; gnus-cite.el --- parse citations in articles for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-art)
+(require 'gnus-range)
+
+;;; Customization:
+
+(defgroup gnus-cite nil
+  "Citation."
+  :prefix "gnus-cite-"
+  :link '(custom-manual "(gnus)Article Highlighting")
+  :group 'gnus-article)
+
+(defcustom gnus-cite-reply-regexp
+  "^\\(Subject: Re\\|In-Reply-To\\|References\\):"
+  "If headers match this regexp it is reasonable to believe that
+article has citations."
+  :group 'gnus-cite
+  :type 'string)
+
+(defcustom gnus-cite-always-check nil
+  "Check article always for citations. Set it t to check all articles."
+  :group 'gnus-cite
+  :type '(choice (const :tag "no" nil)
+		  (const :tag "yes" t)))
+
+(defcustom gnus-cited-text-button-line-format "%(%{[...]%}%)\n"
+  "Format of cited text buttons."
+  :group 'gnus-cite
+  :type 'string)
+
+(defcustom gnus-cited-lines-visible nil
+  "The number of lines of hidden cited text to remain visible."
+  :group 'gnus-cite
+  :type '(choice (const :tag "none" nil)
+		 integer))
+
+(defcustom gnus-cite-parse-max-size 25000
+  "Maximum article size (in bytes) where parsing citations is allowed.
+Set it to nil to parse all articles."
+  :group 'gnus-cite
+  :type '(choice (const :tag "all" nil)
+		 integer))
+
+(defcustom gnus-cite-prefix-regexp
+    "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
+  "Regexp matching the longest possible citation prefix on a line."
+  :group 'gnus-cite
+  :type 'regexp)
+
+(defcustom gnus-cite-max-prefix 20
+  "Maximum possible length for a citation prefix."
+  :group 'gnus-cite
+  :type 'integer)
+
+(defcustom gnus-supercite-regexp
+  (concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
+	  ">>>>> +\"\\([^\"\n]+\\)\" +==")
+  "Regexp matching normal Supercite attribution lines.
+The first grouping must match prefixes added by other packages."
+  :group 'gnus-cite
+  :type 'regexp)
+
+(defcustom gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
+  "Regexp matching mangled Supercite attribution lines.
+The first regexp group should match the Supercite attribution."
+  :group 'gnus-cite
+  :type 'regexp)
+
+(defcustom gnus-cite-minimum-match-count 2
+  "Minimum number of identical prefixes before we believe it's a citation."
+  :group 'gnus-cite
+  :type 'integer)
+
+(defcustom gnus-cite-attribution-prefix "in article\\|in <"
+  "Regexp matching the beginning of an attribution line."
+  :group 'gnus-cite
+  :type 'regexp)
+
+(defcustom gnus-cite-attribution-suffix
+  "\\(wrote\\|writes\\|said\\|says\\):[ \t]*$"
+  "Regexp matching the end of an attribution line.
+The text matching the first grouping will be used as a button."
+  :group 'gnus-cite
+  :type 'regexp)
+
+(defface gnus-cite-attribution-face '((t
+				       (:underline t)))
+  "Face used for attribution lines.")
+
+(defcustom gnus-cite-attribution-face 'gnus-cite-attribution-face
+  "Face used for attribution lines.
+It is merged with the face for the cited text belonging to the attribution."
+  :group 'gnus-cite
+  :type 'face)
+
+(defface gnus-cite-face-1 '((((class color)
+			      (background dark))
+			     (:foreground "light blue"))
+			    (((class color)
+			      (background light))
+			     (:foreground "MidnightBlue"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-2 '((((class color)
+			      (background dark))
+			     (:foreground "light cyan"))
+			    (((class color)
+			      (background light))
+			     (:foreground "firebrick"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-3 '((((class color)
+			      (background dark))
+			     (:foreground "light yellow"))
+			    (((class color)
+			      (background light))
+			     (:foreground "dark green"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-4 '((((class color)
+			      (background dark))
+			     (:foreground "light pink"))
+			    (((class color)
+			      (background light))
+			     (:foreground "OrangeRed"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-5 '((((class color)
+			      (background dark))
+			     (:foreground "pale green"))
+			    (((class color)
+			      (background light))
+			     (:foreground "dark khaki"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-6 '((((class color)
+			      (background dark))
+			     (:foreground "beige"))
+			    (((class color)
+			      (background light))
+			     (:foreground "dark violet"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-7 '((((class color)
+			      (background dark))
+			     (:foreground "orange"))
+			    (((class color)
+			      (background light))
+			     (:foreground "SteelBlue4"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-8 '((((class color)
+			      (background dark))
+			     (:foreground "magenta"))
+			    (((class color)
+			      (background light))
+			     (:foreground "magenta"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-9 '((((class color)
+			      (background dark))
+			     (:foreground "violet"))
+			    (((class color)
+			      (background light))
+			     (:foreground "violet"))
+			    (t
+			     (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-10 '((((class color)
+			       (background dark))
+			      (:foreground "medium purple"))
+			     (((class color)
+			       (background light))
+			      (:foreground "medium purple"))
+			     (t
+			      (:italic t)))
+  "Citation face.")
+
+(defface gnus-cite-face-11 '((((class color)
+			       (background dark))
+			      (:foreground "turquoise"))
+			     (((class color)
+			       (background light))
+			      (:foreground "turquoise"))
+			     (t
+			      (:italic t)))
+  "Citation face.")
+
+(defcustom gnus-cite-face-list
+  '(gnus-cite-face-1 gnus-cite-face-2 gnus-cite-face-3 gnus-cite-face-4
+    gnus-cite-face-5 gnus-cite-face-6 gnus-cite-face-7 gnus-cite-face-8
+    gnus-cite-face-9 gnus-cite-face-10 gnus-cite-face-11)
+  "List of faces used for highlighting citations.
+
+When there are citations from multiple articles in the same message,
+Gnus will try to give each citation from each article its own face.
+This should make it easier to see who wrote what."
+  :group 'gnus-cite
+  :type '(repeat face))
+
+(defcustom gnus-cite-hide-percentage 50
+  "Only hide excess citation if above this percentage of the body."
+  :group 'gnus-cite
+  :type 'number)
+
+(defcustom gnus-cite-hide-absolute 10
+  "Only hide excess citation if above this number of lines in the body."
+  :group 'gnus-cite
+  :type 'integer)
+
+;;; Internal Variables:
+
+(defvar gnus-cite-article nil)
+
+(defvar gnus-cite-prefix-alist nil)
+;; Alist of citation prefixes.
+;; The cdr is a list of lines with that prefix.
+
+(defvar gnus-cite-attribution-alist nil)
+;; Alist of attribution lines.
+;; The car is a line number.
+;; The cdr is the prefix for the citation started by that line.
+
+(defvar gnus-cite-loose-prefix-alist nil)
+;; Alist of citation prefixes that have no matching attribution.
+;; The cdr is a list of lines with that prefix.
+
+(defvar gnus-cite-loose-attribution-alist nil)
+;; Alist of attribution lines that have no matching citation.
+;; Each member has the form (WROTE IN PREFIX TAG), where
+;; WROTE: is the attribution line number
+;; IN: is the line number of the previous line if part of the same attribution,
+;; PREFIX: Is the citation prefix of the attribution line(s), and
+;; TAG: Is a Supercite tag, if any.
+
+(defvar gnus-cited-text-button-line-format-alist
+  `((?b (marker-position beg) ?d)
+    (?e (marker-position end) ?d)
+    (?l (- end beg) ?d)))
+(defvar gnus-cited-text-button-line-format-spec nil)
+
+;;; Commands:
+
+(defun gnus-article-highlight-citation (&optional force)
+  "Highlight cited text.
+Each citation in the article will be highlighted with a different face.
+The faces are taken from `gnus-cite-face-list'.
+Attribution lines are highlighted with the same face as the
+corresponding citation merged with `gnus-cite-attribution-face'.
+
+Text is considered cited if at least `gnus-cite-minimum-match-count'
+lines matches `gnus-cite-prefix-regexp' with the same prefix.
+
+Lines matching `gnus-cite-attribution-suffix' and perhaps
+`gnus-cite-attribution-prefix' are considered attribution lines."
+  (interactive (list 'force))
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (gnus-cite-parse-maybe force)
+    (let ((buffer-read-only nil)
+	  (alist gnus-cite-prefix-alist)
+	  (faces gnus-cite-face-list)
+	  (inhibit-point-motion-hooks t)
+	  face entry prefix skip numbers number face-alist)
+      ;; Loop through citation prefixes.
+      (while alist
+	(setq entry (car alist)
+	      alist (cdr alist)
+	      prefix (car entry)
+	      numbers (cdr entry)
+	      face (car faces)
+	      faces (or (cdr faces) gnus-cite-face-list)
+	      face-alist (cons (cons prefix face) face-alist))
+	(while numbers
+	  (setq number (car numbers)
+		numbers (cdr numbers))
+	  (and (not (assq number gnus-cite-attribution-alist))
+	       (not (assq number gnus-cite-loose-attribution-alist))
+	       (gnus-cite-add-face number prefix face))))
+      ;; Loop through attribution lines.
+      (setq alist gnus-cite-attribution-alist)
+      (while alist
+	(setq entry (car alist)
+	      alist (cdr alist)
+	      number (car entry)
+	      prefix (cdr entry)
+	      skip (gnus-cite-find-prefix number)
+	      face (cdr (assoc prefix face-alist)))
+	;; Add attribution button.
+	(goto-line number)
+	(when (re-search-forward gnus-cite-attribution-suffix
+				 (save-excursion (end-of-line 1) (point))
+				 t)
+	  (gnus-article-add-button (match-beginning 1) (match-end 1)
+				   'gnus-cite-toggle prefix))
+	;; Highlight attribution line.
+	(gnus-cite-add-face number skip face)
+	(gnus-cite-add-face number skip gnus-cite-attribution-face))
+      ;; Loop through attribution lines.
+      (setq alist gnus-cite-loose-attribution-alist)
+      (while alist
+	(setq entry (car alist)
+	      alist (cdr alist)
+	      number (car entry)
+	      skip (gnus-cite-find-prefix number))
+	(gnus-cite-add-face number skip gnus-cite-attribution-face)))))
+
+(defun gnus-dissect-cited-text ()
+  "Dissect the article buffer looking for cited text."
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (gnus-cite-parse-maybe)
+    (let ((alist gnus-cite-prefix-alist)
+	  prefix numbers number marks m)
+      ;; Loop through citation prefixes.
+      (while alist
+	(setq numbers (pop alist)
+	      prefix (pop numbers))
+	(while numbers
+	  (setq number (pop numbers))
+	  (goto-char (point-min))
+	  (forward-line number)
+	  (push (cons (point-marker) "") marks)
+	  (while (and numbers
+		      (= (1- number) (car numbers)))
+	    (setq number (pop numbers)))
+	  (goto-char (point-min))
+	  (forward-line (1- number))
+	  (push (cons (point-marker) prefix) marks)))
+      ;; Skip to the beginning of the body.
+      (goto-char (point-min))
+      (search-forward "\n\n" nil t)
+      (push (cons (point-marker) "") marks)
+      ;; Find the end of the body.
+      (goto-char (point-max))
+      (gnus-article-search-signature)
+      (push (cons (point-marker) "") marks)
+      ;; Sort the marks.
+      (setq marks (sort marks (lambda (m1 m2) (< (car m1) (car m2)))))
+      (let ((omarks marks))
+	(setq marks nil)
+	(while (cdr omarks)
+	  (if (= (caar omarks) (caadr omarks))
+	      (progn
+		(unless (equal (cdar omarks) "")
+		  (push (car omarks) marks))
+		(unless (equal (cdadr omarks) "")
+		  (push (cadr omarks) marks))
+		(unless (and (equal (cdar omarks) "")
+			     (equal (cdadr omarks) "")
+			     (not (cddr omarks)))
+		  (setq omarks (cdr omarks))))
+	    (push (car omarks) marks))
+	  (setq omarks (cdr omarks)))
+	(when (car omarks)
+	  (push (car omarks) marks))
+	(setq marks (setq m (nreverse marks)))
+	(while (cddr m)
+	  (if (and (equal (cdadr m) "")
+		   (equal (cdar m) (cdaddr m))
+		   (goto-char (caadr m))
+		   (forward-line 1)
+		   (= (point) (caaddr m)))
+	      (setcdr m (cdddr m))
+	    (setq m (cdr m))))
+	marks))))
+
+(defun gnus-article-fill-cited-article (&optional force width)
+  "Do word wrapping in the current article.
+If WIDTH (the numerical prefix), use that text width when filling."
+  (interactive (list t current-prefix-arg))
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (let ((buffer-read-only nil)
+	  (inhibit-point-motion-hooks t)
+	  (marks (gnus-dissect-cited-text))
+	  (adaptive-fill-mode nil)
+	  (filladapt-mode nil)
+	  (fill-column (if width (prefix-numeric-value width) fill-column)))
+      (save-restriction
+	(while (cdr marks)
+	  (widen)
+	  (narrow-to-region (caar marks) (caadr marks))
+	  (let ((adaptive-fill-regexp
+		 (concat "^" (regexp-quote (cdar marks)) " *"))
+		(fill-prefix (cdar marks)))
+	    (fill-region (point-min) (point-max)))
+	  (set-marker (caar marks) nil)
+	  (setq marks (cdr marks)))
+	(when marks
+	  (set-marker (caar marks) nil))
+	;; All this information is now incorrect.
+	(setq gnus-cite-prefix-alist nil
+	      gnus-cite-attribution-alist nil
+	      gnus-cite-loose-prefix-alist nil
+	      gnus-cite-loose-attribution-alist nil)))))
+
+(defun gnus-article-hide-citation (&optional arg force)
+  "Toggle hiding of all cited text except attribution lines.
+See the documentation for `gnus-article-highlight-citation'.
+If given a negative prefix, always show; if given a positive prefix,
+always hide."
+  (interactive (append (gnus-article-hidden-arg) (list 'force)))
+  (setq gnus-cited-text-button-line-format-spec
+	(gnus-parse-format gnus-cited-text-button-line-format
+			   gnus-cited-text-button-line-format-alist t))
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (cond
+     ((gnus-article-check-hidden-text 'cite arg)
+      t)
+     ((gnus-article-text-type-exists-p 'cite)
+      (let ((buffer-read-only nil))
+	(gnus-article-hide-text-of-type 'cite)))
+     (t
+      (let ((buffer-read-only nil)
+	    (marks (gnus-dissect-cited-text))
+	    (inhibit-point-motion-hooks t)
+	    (props (nconc (list 'article-type 'cite)
+			  gnus-hidden-properties))
+	    beg end)
+	(while marks
+	  (setq beg nil
+		end nil)
+	  (while (and marks (string= (cdar marks) ""))
+	    (setq marks (cdr marks)))
+	  (when marks
+	    (setq beg (caar marks)))
+	  (while (and marks (not (string= (cdar marks) "")))
+	    (setq marks (cdr marks)))
+	  (when marks
+	    (setq end (caar marks)))
+	  ;; Skip past lines we want to leave visible.
+	  (when (and beg end gnus-cited-lines-visible)
+	    (goto-char beg)
+	    (forward-line gnus-cited-lines-visible)
+	    (if (>= (point) end)
+		(setq beg nil)
+	      (setq beg (point-marker))))
+	  (when (and beg end)
+	    (gnus-add-text-properties beg end props)
+	    (goto-char beg)
+	    (unless (save-excursion (search-backward "\n\n" nil t))
+	      (insert "\n"))
+	    (put-text-property
+	     (point)
+	     (progn
+	       (gnus-article-add-button
+		(point)
+		(progn (eval gnus-cited-text-button-line-format-spec) (point))
+		`gnus-article-toggle-cited-text (cons beg end))
+	       (point))
+	     'article-type 'annotation)
+	    (set-marker beg (point)))))))))
+
+(defun gnus-article-toggle-cited-text (region)
+  "Toggle hiding the text in REGION."
+  (let (buffer-read-only)
+    (funcall
+     (if (text-property-any
+	  (car region) (1- (cdr region))
+	  (car gnus-hidden-properties) (cadr gnus-hidden-properties))
+	 'remove-text-properties 'gnus-add-text-properties)
+     (car region) (cdr region) gnus-hidden-properties)))
+
+(defun gnus-article-hide-citation-maybe (&optional arg force)
+  "Toggle hiding of cited text that has an attribution line.
+If given a negative prefix, always show; if given a positive prefix,
+always hide.
+This will do nothing unless at least `gnus-cite-hide-percentage'
+percent and at least `gnus-cite-hide-absolute' lines of the body is
+cited text with attributions.  When called interactively, these two
+variables are ignored.
+See also the documentation for `gnus-article-highlight-citation'."
+  (interactive (append (gnus-article-hidden-arg) (list 'force)))
+  (unless (gnus-article-check-hidden-text 'cite arg)
+    (save-excursion
+      (set-buffer gnus-article-buffer)
+      (gnus-cite-parse-maybe force)
+      (goto-char (point-min))
+      (search-forward "\n\n" nil t)
+      (let ((start (point))
+	    (atts gnus-cite-attribution-alist)
+	    (buffer-read-only nil)
+	    (inhibit-point-motion-hooks t)
+	    (hiden 0)
+	    total)
+	(goto-char (point-max))
+	(gnus-article-search-signature)
+	(setq total (count-lines start (point)))
+	(while atts
+	  (setq hiden (+ hiden (length (cdr (assoc (cdar atts)
+						   gnus-cite-prefix-alist))))
+		atts (cdr atts)))
+	(when (or force
+		  (and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
+		       (> hiden gnus-cite-hide-absolute)))
+	  (setq atts gnus-cite-attribution-alist)
+	  (while atts
+	    (setq total (cdr (assoc (cdar atts) gnus-cite-prefix-alist))
+		  atts (cdr atts))
+	    (while total
+	      (setq hiden (car total)
+		    total (cdr total))
+	      (goto-line hiden)
+	      (unless (assq hiden gnus-cite-attribution-alist)
+		(gnus-add-text-properties
+		 (point) (progn (forward-line 1) (point))
+		 (nconc (list 'article-type 'cite)
+			gnus-hidden-properties))))))))))
+
+(defun gnus-article-hide-citation-in-followups ()
+  "Hide cited text in non-root articles."
+  (interactive)
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (let ((article (cdr gnus-article-current)))
+      (unless (save-excursion
+		(set-buffer gnus-summary-buffer)
+		(gnus-article-displayed-root-p article))
+	(gnus-article-hide-citation)))))
+
+;;; Internal functions:
+
+(defun gnus-cite-parse-maybe (&optional force)
+  ;; Parse if the buffer has changes since last time.
+  (if (equal gnus-cite-article gnus-article-current)
+      ()
+    ;;Reset parser information.
+    (setq gnus-cite-prefix-alist nil
+	  gnus-cite-attribution-alist nil
+	  gnus-cite-loose-prefix-alist nil
+	  gnus-cite-loose-attribution-alist nil)
+    ;; Parse if not too large.
+    (if (and (not force)
+	     gnus-cite-parse-max-size
+	     (> (buffer-size) gnus-cite-parse-max-size))
+	()
+      (setq gnus-cite-article (cons (car gnus-article-current)
+				    (cdr gnus-article-current)))
+      (gnus-cite-parse-wrapper))))
+
+(defun gnus-cite-parse-wrapper ()
+  ;; Wrap chopped gnus-cite-parse
+  (goto-char (point-min))
+  (unless (search-forward "\n\n" nil t)
+    (goto-char (point-max)))
+  (save-excursion
+    (gnus-cite-parse-attributions))
+  ;; Try to avoid check citation if there is no reason to believe
+  ;; that article has citations
+  (if (or gnus-cite-always-check
+	  (save-excursion
+	    (re-search-backward gnus-cite-reply-regexp nil t))
+	  gnus-cite-loose-attribution-alist)
+      (progn (save-excursion
+	       (gnus-cite-parse))
+	     (save-excursion
+	       (gnus-cite-connect-attributions)))))
+
+(defun gnus-cite-parse ()
+  ;; Parse and connect citation prefixes and attribution lines.
+
+  ;; Parse current buffer searching for citation prefixes.
+  (let ((line (1+ (count-lines (point-min) (point))))
+	(case-fold-search t)
+	(max (save-excursion
+	       (goto-char (point-max))
+	       (gnus-article-search-signature)
+	       (point)))
+	alist entry start begin end numbers prefix)
+    ;; Get all potential prefixes in `alist'.
+    (while (< (point) max)
+      ;; Each line.
+      (setq begin (point)
+	    end (progn (beginning-of-line 2) (point))
+	    start end)
+      (goto-char begin)
+      ;; Ignore standard Supercite attribution prefix.
+      (when (looking-at gnus-supercite-regexp)
+	(if (match-end 1)
+	    (setq end (1+ (match-end 1)))
+	  (setq end (1+ begin))))
+      ;; Ignore very long prefixes.
+      (when (> end (+ (point) gnus-cite-max-prefix))
+	(setq end (+ (point) gnus-cite-max-prefix)))
+      (while (re-search-forward gnus-cite-prefix-regexp (1- end) t)
+	;; Each prefix.
+	(setq end (match-end 0)
+	      prefix (buffer-substring begin end))
+	(gnus-set-text-properties 0 (length prefix) nil prefix)
+	(setq entry (assoc prefix alist))
+	(if entry
+	    (setcdr entry (cons line (cdr entry)))
+	  (push (list prefix line) alist))
+	(goto-char begin))
+      (goto-char start)
+      (setq line (1+ line)))
+    ;; We got all the potential prefixes.  Now create
+    ;; `gnus-cite-prefix-alist' containing the oldest prefix for each
+    ;; line that appears at least gnus-cite-minimum-match-count
+    ;; times.  First sort them by length.  Longer is older.
+    (setq alist (sort alist (lambda (a b)
+			      (> (length (car a)) (length (car b))))))
+    (while alist
+      (setq entry (car alist)
+	    prefix (car entry)
+	    numbers (cdr entry)
+	    alist (cdr alist))
+      (cond ((null numbers)
+	     ;; No lines with this prefix that wasn't also part of
+	     ;; a longer prefix.
+	     )
+	    ((< (length numbers) gnus-cite-minimum-match-count)
+	     ;; Too few lines with this prefix.  We keep it a bit
+	     ;; longer in case it is an exact match for an attribution
+	     ;; line, but we don't remove the line from other
+	     ;; prefixes.
+	     (push entry gnus-cite-prefix-alist))
+	    (t
+	     (push entry
+		   gnus-cite-prefix-alist)
+	     ;; Remove articles from other prefixes.
+	     (let ((loop alist)
+		   current)
+	       (while loop
+		 (setq current (car loop)
+		       loop (cdr loop))
+		 (setcdr current
+			 (gnus-set-difference (cdr current) numbers)))))))))
+
+(defun gnus-cite-parse-attributions ()
+  (let (al-alist)
+    ;; Parse attributions
+    (while (re-search-forward gnus-cite-attribution-suffix (point-max) t)
+      (let* ((start (match-beginning 0))
+	     (end (match-end 0))
+	     (wrote (count-lines (point-min) end))
+	     (prefix (gnus-cite-find-prefix wrote))
+	     ;; Check previous line for an attribution leader.
+	     (tag (progn
+		    (beginning-of-line 1)
+		    (when (looking-at gnus-supercite-secondary-regexp)
+		      (buffer-substring (match-beginning 1)
+					(match-end 1)))))
+	     (in (progn
+		   (goto-char start)
+		   (and (re-search-backward gnus-cite-attribution-prefix
+					    (save-excursion
+					      (beginning-of-line 0)
+					      (point))
+					    t)
+			(not (re-search-forward gnus-cite-attribution-suffix
+						start t))
+			(count-lines (point-min) (1+ (point)))))))
+	(when (eq wrote in)
+	  (setq in nil))
+	(goto-char end)
+	;; don't add duplicates
+	(let ((al (buffer-substring (save-excursion (beginning-of-line 0)
+						    (1+ (point)))
+				    end)))
+	  (if (not (assoc al al-alist))
+	      (progn
+		(push (list wrote in prefix tag)
+		      gnus-cite-loose-attribution-alist)
+		(push (cons al t) al-alist))))))))
+
+(defun gnus-cite-connect-attributions ()
+  ;; Connect attributions to citations
+
+  ;; No citations have been connected to attribution lines yet.
+  (setq gnus-cite-loose-prefix-alist (append gnus-cite-prefix-alist nil))
+
+  ;; Parse current buffer searching for attribution lines.
+  ;; Find exact supercite citations.
+  (gnus-cite-match-attributions 'small nil
+				(lambda (prefix tag)
+				  (when tag
+				    (concat "\\`"
+					    (regexp-quote prefix) "[ \t]*"
+					    (regexp-quote tag) ">"))))
+  ;; Find loose supercite citations after attributions.
+  (gnus-cite-match-attributions 'small t
+				(lambda (prefix tag)
+				  (when tag
+				    (concat "\\<"
+					    (regexp-quote tag)
+					    "\\>"))))
+  ;; Find loose supercite citations anywhere.
+  (gnus-cite-match-attributions 'small nil
+				(lambda (prefix tag)
+				  (when tag
+				    (concat "\\<"
+					    (regexp-quote tag)
+					    "\\>"))))
+  ;; Find nested citations after attributions.
+  (gnus-cite-match-attributions 'small-if-unique t
+				(lambda (prefix tag)
+				  (concat "\\`" (regexp-quote prefix) ".+")))
+  ;; Find nested citations anywhere.
+  (gnus-cite-match-attributions 'small nil
+				(lambda (prefix tag)
+				  (concat "\\`" (regexp-quote prefix) ".+")))
+  ;; Remove loose prefixes with too few lines.
+  (let ((alist gnus-cite-loose-prefix-alist)
+	entry)
+    (while alist
+      (setq entry (car alist)
+	    alist (cdr alist))
+      (when (< (length (cdr entry)) gnus-cite-minimum-match-count)
+	(setq gnus-cite-prefix-alist
+	      (delq entry gnus-cite-prefix-alist)
+	      gnus-cite-loose-prefix-alist
+	      (delq entry gnus-cite-loose-prefix-alist)))))
+  ;; Find flat attributions.
+  (gnus-cite-match-attributions 'first t nil)
+  ;; Find any attributions (are we getting desperate yet?).
+  (gnus-cite-match-attributions 'first nil nil))
+
+(defun gnus-cite-match-attributions (sort after fun)
+  ;; Match all loose attributions and citations (SORT AFTER FUN) .
+  ;;
+  ;; If SORT is `small', the citation with the shortest prefix will be
+  ;; used, if it is `first' the first prefix will be used, if it is
+  ;; `small-if-unique' the shortest prefix will be used if the
+  ;; attribution line does not share its own prefix with other
+  ;; loose attribution lines, otherwise the first prefix will be used.
+  ;;
+  ;; If AFTER is non-nil, only citations after the attribution line
+  ;; will be considered.
+  ;;
+  ;; If FUN is non-nil, it will be called with the arguments (WROTE
+  ;; PREFIX TAG) and expected to return a regular expression.  Only
+  ;; citations whose prefix matches the regular expression will be
+  ;; considered.
+  ;;
+  ;; WROTE is the attribution line number.
+  ;; PREFIX is the attribution line prefix.
+  ;; TAG is the Supercite tag on the attribution line.
+  (let ((atts gnus-cite-loose-attribution-alist)
+	(case-fold-search t)
+	att wrote in prefix tag regexp limit smallest best size)
+    (while atts
+      (setq att (car atts)
+	    atts (cdr atts)
+	    wrote (nth 0 att)
+	    in (nth 1 att)
+	    prefix (nth 2 att)
+	    tag (nth 3 att)
+	    regexp (if fun (funcall fun prefix tag) "")
+	    size (cond ((eq sort 'small) t)
+		       ((eq sort 'first) nil)
+		       (t (< (length (gnus-cite-find-loose prefix)) 2)))
+	    limit (if after wrote -1)
+	    smallest 1000000
+	    best nil)
+      (let ((cites gnus-cite-loose-prefix-alist)
+	    cite candidate numbers first compare)
+	(while cites
+	  (setq cite (car cites)
+		cites (cdr cites)
+		candidate (car cite)
+		numbers (cdr cite)
+		first (apply 'min numbers)
+		compare (if size (length candidate) first))
+	  (and (> first limit)
+	       regexp
+	       (string-match regexp candidate)
+	       (< compare smallest)
+	       (setq best cite
+		     smallest compare))))
+      (if (null best)
+	  ()
+	(setq gnus-cite-loose-attribution-alist
+	      (delq att gnus-cite-loose-attribution-alist))
+	(push (cons wrote (car best)) gnus-cite-attribution-alist)
+	(when in
+	  (push (cons in (car best)) gnus-cite-attribution-alist))
+	(when (memq best gnus-cite-loose-prefix-alist)
+	  (let ((loop gnus-cite-prefix-alist)
+		(numbers (cdr best))
+		current)
+	    (setq gnus-cite-loose-prefix-alist
+		  (delq best gnus-cite-loose-prefix-alist))
+	    (while loop
+	      (setq current (car loop)
+		    loop (cdr loop))
+	      (if (eq current best)
+		  ()
+		(setcdr current (gnus-set-difference (cdr current) numbers))
+		(when (null (cdr current))
+		  (setq gnus-cite-loose-prefix-alist
+			(delq current gnus-cite-loose-prefix-alist)
+			atts (delq current atts)))))))))))
+
+(defun gnus-cite-find-loose (prefix)
+  ;; Return a list of loose attribution lines prefixed by PREFIX.
+  (let* ((atts gnus-cite-loose-attribution-alist)
+	 att line lines)
+    (while atts
+      (setq att (car atts)
+	    line (car att)
+	    atts (cdr atts))
+      (when (string-equal (gnus-cite-find-prefix line) prefix)
+	(push line lines)))
+    lines))
+
+(defun gnus-cite-add-face (number prefix face)
+  ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
+  (when face
+    (let ((inhibit-point-motion-hooks t)
+	  from to)
+      (goto-line number)
+      (unless (eobp);; Sometimes things become confused.
+	(forward-char (length prefix))
+	(skip-chars-forward " \t")
+	(setq from (point))
+	(end-of-line 1)
+	(skip-chars-backward " \t")
+	(setq to (point))
+	(when (< from to)
+	  (gnus-overlay-put (gnus-make-overlay from to) 'face face))))))
+
+(defun gnus-cite-toggle (prefix)
+  (save-excursion
+    (set-buffer gnus-article-buffer)
+    (let ((buffer-read-only nil)
+	  (numbers (cdr (assoc prefix gnus-cite-prefix-alist)))
+	  (inhibit-point-motion-hooks t)
+	  number)
+      (while numbers
+	(setq number (car numbers)
+	      numbers (cdr numbers))
+	(goto-line number)
+	(cond ((get-text-property (point) 'invisible)
+	       (remove-text-properties (point) (progn (forward-line 1) (point))
+				       gnus-hidden-properties))
+	      ((assq number gnus-cite-attribution-alist))
+	      (t
+	       (gnus-add-text-properties
+		(point) (progn (forward-line 1) (point))
+		(nconc (list 'article-type 'cite)
+		       gnus-hidden-properties))))))))
+
+(defun gnus-cite-find-prefix (line)
+  ;; Return citation prefix for LINE.
+  (let ((alist gnus-cite-prefix-alist)
+	(prefix "")
+	entry)
+    (while alist
+      (setq entry (car alist)
+	    alist (cdr alist))
+      (when (memq line (cdr entry))
+	(setq prefix (car entry))))
+    prefix))
+
+(gnus-add-shutdown 'gnus-cache-close 'gnus)
+
+(defun gnus-cache-close ()
+  (setq gnus-cite-prefix-alist nil))
+
+(gnus-ems-redefine)
+
+(provide 'gnus-cite)
+
+;;; gnus-cite.el ends here

lisp/gnus/gnus-cus.el

@@ -0,0 +1,650 @@
+;;; gnus-cus.el --- customization commands for Gnus
+;;
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'wid-edit)
+(require 'gnus-score)
+
+;;; Widgets:
+
+;; There should be special validation for this.
+(define-widget 'gnus-email-address 'string
+  "An email address")
+
+(defun gnus-custom-mode ()
+  "Major mode for editing Gnus customization buffers.
+
+The following commands are available:
+
+\\[widget-forward]		Move to next button or editable field.
+\\[widget-backward]		Move to previous button or editable field.
+\\[widget-button-click]		Activate button under the mouse pointer.
+\\[widget-button-press]		Activate button under point.
+
+Entry to this mode calls the value of `gnus-custom-mode-hook'
+if that value is non-nil."
+  (kill-all-local-variables)
+  (setq major-mode 'gnus-custom-mode
+	mode-name "Gnus Customize")
+  (use-local-map widget-keymap)
+  (run-hooks 'gnus-custom-mode-hook))
+
+;;; Group Customization:
+
+(defconst gnus-group-parameters
+  '((to-address (gnus-email-address :tag "To Address") "\
+This will be used when doing followups and posts.
+
+This is primarily useful in mail groups that represent closed
+mailing lists--mailing lists where it's expected that everybody that
+writes to the mailing list is subscribed to it.  Since using this
+parameter ensures that the mail only goes to the mailing list itself,
+it means that members won't receive two copies of your followups.
+
+Using `to-address' will actually work whether the group is foreign or
+not.  Let's say there's a group on the server that is called
+`fa.4ad-l'.  This is a real newsgroup, but the server has gotten the
+articles from a mail-to-news gateway.  Posting directly to this group
+is therefore impossible--you have to send mail to the mailing list
+address instead.")
+
+    (to-list (gnus-email-address :tag "To List") "\
+This address will be used when doing a `a' in the group.
+
+It is totally ignored when doing a followup--except that if it is
+present in a news group, you'll get mail group semantics when doing
+`f'.")
+
+    (broken-reply-to (const :tag "Broken Reply To" t) "\
+Ignore `Reply-To' headers in this group.
+
+That can be useful if you're reading a mailing list group where the
+listserv has inserted `Reply-To' headers that point back to the
+listserv itself.  This is broken behavior.  So there!")
+
+    (to-group (string :tag "To Group") "\
+All posts will be send to the specified group.")
+
+    (gcc-self (choice :tag  "GCC"
+		      :value t
+		      (const t)
+		      (const none)
+		      (string :format "%v" :hide-front-space t)) "\
+Specify default value for GCC header.
+
+If this symbol is present in the group parameter list and set to `t',
+new composed messages will be `Gcc''d to the current group. If it is
+present and set to `none', no `Gcc:' header will be generated, if it
+is present and a string, this string will be inserted literally as a
+`gcc' header (this symbol takes precedence over any default `Gcc'
+rules as described later).")
+
+    (auto-expire (const :tag "Automatic Expire" t) "\
+All articles that are read will be marked as expirable.")
+
+    (total-expire (const :tag "Total Expire" t) "\
+All read articles will be put through the expiry process
+
+This happens even if they are not marked as expirable.
+Use with caution.")
+
+    (expiry-wait (choice :tag  "Expire Wait"
+			 :value never
+			 (const never)
+			 (const immediate)
+			 (number :hide-front-space t
+				 :format "%v")) "\
+When to expire.
+
+Overrides any `nnmail-expiry-wait' and `nnmail-expiry-wait-function'
+when expiring expirable messages. The value can either be a number of
+days (not necessarily an integer) or the symbols `never' or
+`immediate'.")
+
+    (score-file (file :tag "Score File") "\
+Make the specified file into the current score file.
+This means that all score commands you issue will end up in this file.")
+
+    (adapt-file (file :tag "Adapt File") "\
+Make the specified file into the current adaptive file.
+All adaptive score entries will be put into this file.")
+
+    (admin-address (gnus-email-address :tag "Admin Address") "\
+Administration address for a mailing list.
+
+When unsubscribing to a mailing list you should never send the
+unsubscription notice to the mailing list itself.  Instead, you'd
+send messages to the administrative address.  This parameter allows
+you to put the admin address somewhere convenient.")
+
+    (display (choice :tag "Display"
+		     :value default
+		     (const all)
+		     (const default)) "\
+Which articles to display on entering the group.
+
+`all'
+     Display all articles, both read and unread.
+
+`default'
+     Display the default visible articles, which normally includes
+     unread and ticked articles.")
+
+    (comment (string :tag  "Comment") "\
+An arbitrary comment on the group."))
+  "Alist of valid group parameters.
+
+Each entry has the form (NAME TYPE DOC), where NAME is the parameter
+itself (a symbol), TYPE is the parameters type (a sexp widget), and
+DOC is a documentation string for the parameter.")
+
+(defvar gnus-custom-params)
+(defvar gnus-custom-method)
+(defvar gnus-custom-group)
+
+(defun gnus-group-customize (group &optional part)
+  "Edit the group on the current line."
+  (interactive (list (gnus-group-group-name)))
+  (let ((part (or part 'info))
+	info
+	(types (mapcar (lambda (entry)
+			 `(cons :format "%v%h\n"
+				:doc ,(nth 2 entry)
+				(const :format "" ,(nth 0 entry))
+				,(nth 1 entry)))
+		       gnus-group-parameters)))
+    (unless group
+      (error "No group on current line"))
+    (unless (setq info (gnus-get-info group))
+      (error "Killed group; can't be edited"))
+    ;; Ready.
+    (kill-buffer (get-buffer-create "*Gnus Customize*"))
+    (switch-to-buffer (get-buffer-create "*Gnus Customize*"))
+    (gnus-custom-mode)
+    (make-local-variable 'gnus-custom-group)
+    (setq gnus-custom-group group)
+    (widget-insert "Customize the ")
+    (widget-create 'info-link
+		   :help-echo "Push me to learn more."
+		   :tag "group parameters"
+		   "(gnus)Group Parameters")
+    (widget-insert " for <")
+    (widget-insert group)
+    (widget-insert "> and press ")
+    (widget-create 'push-button
+		   :tag "done"
+		   :help-echo "Push me when done customizing."
+		   :action 'gnus-group-customize-done)
+    (widget-insert ".\n\n")
+    (make-local-variable 'gnus-custom-params)
+    (setq gnus-custom-params
+	  (widget-create 'group
+			 :value (gnus-info-params info)
+			 `(set :inline t
+			       :greedy t
+			       :tag "Parameters"
+			       :format "%t:\n%h%v"
+			       :doc "\
+These special paramerters are recognized by Gnus.
+Check the [ ] for the parameters you want to apply to this group, then
+edit the value to suit your taste."
+			       ,@types)
+			 '(repeat :inline t
+				  :tag "Variables"
+				  :format "%t:\n%h%v%i\n\n"
+				  :doc "\
+Set variables local to the group you are entering.
+
+If you want to turn threading off in `news.answers', you could put
+`(gnus-show-threads nil)' in the group parameters of that group.
+`gnus-show-threads' will be made into a local variable in the summary
+buffer you enter, and the form `nil' will be `eval'ed there.
+
+This can also be used as a group-specific hook function, if you'd
+like.  If you want to hear a beep when you enter a group, you could
+put something like `(dummy-variable (ding))' in the parameters of that
+group.  `dummy-variable' will be set to the result of the `(ding)'
+form, but who cares?"
+				  (group :value (nil nil)
+					 (symbol :tag "Variable")
+					 (sexp :tag
+					       "Value")))
+
+			 '(repeat :inline t
+				  :tag "Unknown entries"
+				  sexp)))
+    (widget-insert "\n\nYou can also edit the ")
+    (widget-create 'info-link
+		   :tag "select method"
+		   :help-echo "Push me to learn more about select methods."
+		   "(gnus)Select Methods")
+    (widget-insert " for the group.\n")
+    (setq gnus-custom-method
+	  (widget-create 'sexp
+			 :tag "Method"
+			 :value (gnus-info-method info)))
+    (use-local-map widget-keymap)
+    (widget-setup)))
+
+(defun gnus-group-customize-done (&rest ignore)
+  "Apply changes and bury the buffer."
+  (interactive)
+  (gnus-group-edit-group-done 'params gnus-custom-group
+			      (widget-value gnus-custom-params))
+  (gnus-group-edit-group-done 'method gnus-custom-group
+			      (widget-value gnus-custom-method))
+  (bury-buffer))
+
+;;; Score Customization:
+
+(defconst gnus-score-parameters
+  '((mark (number :tag "Mark") "\
+The value of this entry should be a number.
+Any articles with a score lower than this number will be marked as read.")
+
+    (expunge (number :tag "Expunge") "\
+The value of this entry should be a number.
+Any articles with a score lower than this number will be removed from
+the summary buffer.")
+
+    (mark-and-expunge (number :tag "Mark-and-expunge") "\
+The value of this entry should be a number.
+Any articles with a score lower than this number will be marked as
+read and removed from the summary buffer.")
+
+    (thread-mark-and-expunge (number :tag "Thread-mark-and-expunge") "\
+The value of this entry should be a number.
+All articles that belong to a thread that has a total score below this
+number will be marked as read and removed from the summary buffer.
+`gnus-thread-score-function' says how to compute the total score
+for a thread.")
+
+    (files (repeat :tag "Files" file) "\
+The value of this entry should be any number of file names.
+These files are assumed to be score files as well, and will be loaded
+the same way this one was.")
+
+    (exclude-files (repeat :tag "Exclude-files" file) "\
+The clue of this entry should be any number of files.
+These files will not be loaded, even though they would normally be so,
+for some reason or other.")
+
+    (eval (sexp :tag "Eval" :value nil) "\
+The value of this entry will be `eval'el.
+This element will be ignored when handling global score files.")
+
+    (read-only (boolean :tag "Read-only" :value t) "\
+Read-only score files will not be updated or saved.
+Global score files should feature this atom.")
+
+    (orphan (number :tag "Orphan") "\
+The value of this entry should be a number.
+Articles that do not have parents will get this number added to their
+scores.  Imagine you follow some high-volume newsgroup, like
+`comp.lang.c'.  Most likely you will only follow a few of the threads,
+also want to see any new threads.
+
+You can do this with the following two score file entries:
+
+     (orphan -500)
+     (mark-and-expunge -100)
+
+When you enter the group the first time, you will only see the new
+threads.  You then raise the score of the threads that you find
+interesting (with `I T' or `I S'), and ignore (`C y') the rest.
+Next time you enter the group, you will see new articles in the
+interesting threads, plus any new threads.
+
+I.e.---the orphan score atom is for high-volume groups where there
+exist a few interesting threads which can't be found automatically
+by ordinary scoring rules.")
+
+    (adapt (choice :tag "Adapt"
+		   (const t)
+		   (const ignore)
+		   (sexp :format "%v"
+			 :hide-front-space t)) "\
+This entry controls the adaptive scoring.
+If it is `t', the default adaptive scoring rules will be used.  If it
+is `ignore', no adaptive scoring will be performed on this group.  If
+it is a list, this list will be used as the adaptive scoring rules.
+If it isn't present, or is something other than `t' or `ignore', the
+default adaptive scoring rules will be used.  If you want to use
+adaptive scoring on most groups, you'd set `gnus-use-adaptive-scoring'
+to `t', and insert an `(adapt ignore)' in the groups where you do not
+want adaptive scoring.  If you only want adaptive scoring in a few
+groups, you'd set `gnus-use-adaptive-scoring' to `nil', and insert
+`(adapt t)' in the score files of the groups where you want it.")
+
+    (adapt-file (file :tag "Adapt-file") "\
+All adaptive score entries will go to the file named by this entry.
+It will also be applied when entering the group.  This atom might
+be handy if you want to adapt on several groups at once, using the
+same adaptive file for a number of groups.")
+
+    (local (repeat :tag "Local"
+		   (group :value (nil nil)
+			  (symbol :tag "Variable")
+			  (sexp :tag "Value"))) "\
+The value of this entry should be a list of `(VAR VALUE)' pairs.
+Each VAR will be made buffer-local to the current summary buffer,
+and set to the value specified.  This is a convenient, if somewhat
+strange, way of setting variables in some groups if you don't like
+hooks much.")
+    (touched (sexp :format "Touched\n") "Internal variable."))
+  "Alist of valid symbolic score parameters.
+
+Each entry has the form (NAME TYPE DOC), where NAME is the parameter
+itself (a symbol), TYPE is the parameters type (a sexp widget), and DOC is a
+documentation string for the parameter.")
+
+(define-widget 'gnus-score-string 'group
+  "Edit score entries for string-valued headers."
+  :convert-widget 'gnus-score-string-convert)
+
+(defun gnus-score-string-convert (widget)
+  ;; Set args appropriately.
+  (let* ((tag (widget-get widget :tag))
+	 (item `(const :format "" :value ,(downcase tag)))
+	 (match '(string :tag "Match"))
+	 (score '(choice :tag "Score"
+			(const :tag "default" nil)
+			(integer :format "%v"
+				 :hide-front-space t)))
+	 (expire '(choice :tag "Expire"
+			  (const :tag "off" nil)
+			  (integer :format "%v"
+				   :hide-front-space t)))
+	 (type '(choice :tag "Type"
+			:value s
+			;; I should really create a forgiving :match
+			;; function for each type below, that only
+			;; looked at the first letter.
+			(const :tag "Regexp" r)
+			(const :tag "Regexp (fixed case)" R)
+			(const :tag "Substring" s)
+			(const :tag "Substring (fixed case)" S)
+			(const :tag "Exact" e)
+			(const :tag "Exact (fixed case)" E)
+			(const :tag "Word" w)
+			(const :tag "Word (fixed case)" W)
+			(const :tag "default" nil)))
+	 (group `(group ,match ,score ,expire ,type))
+	 (doc (concat (or (widget-get widget :doc)
+			  (concat "Change score based on the " tag
+				  " header.\n"))
+		      "
+You can have an arbitrary number of score entries for this header,
+each score entry has four elements:
+
+1. The \"match element\".  This should be the string to look for in the
+   header.
+
+2. The \"score element\".  This number should be an integer in the
+   neginf to posinf interval.  This number is added to the score
+   of the article if the match is successful.  If this element is
+   not present, the `gnus-score-interactive-default-score' number
+   will be used instead.  This is 1000 by default.
+
+3. The \"date element\".  This date says when the last time this score
+   entry matched, which provides a mechanism for expiring the
+   score entries.  It this element is not present, the score
+   entry is permanent.  The date is represented by the number of
+   days since December 31, 1 ce.
+
+4. The \"type element\".  This element specifies what function should
+   be used to see whether this score entry matches the article.
+
+   There are the regexp, as well as substring types, and exact match,
+   and word match types.  If this element is not present, Gnus will
+   assume that substring matching should be used.  There is case
+   sensitive variants of all match types.")))
+    (widget-put widget :args `(,item
+			       (repeat :inline t
+				       :indent 0
+				       :tag ,tag
+				       :doc ,doc
+				       :format "%t:\n%h%v%i\n\n"
+				       (choice :format "%v"
+					       :value ("" nil nil s)
+					       ,group
+					       sexp)))))
+  widget)
+
+(define-widget 'gnus-score-integer 'group
+  "Edit score entries for integer-valued headers."
+  :convert-widget 'gnus-score-integer-convert)
+
+(defun gnus-score-integer-convert (widget)
+  ;; Set args appropriately.
+  (let* ((tag (widget-get widget :tag))
+	 (item `(const :format "" :value ,(downcase tag)))
+	 (match '(integer :tag "Match"))
+	 (score '(choice :tag "Score"
+			(const :tag "default" nil)
+			(integer :format "%v"
+				 :hide-front-space t)))
+	 (expire '(choice :tag "Expire"
+			  (const :tag "off" nil)
+			  (integer :format "%v"
+				   :hide-front-space t)))
+	 (type '(choice :tag "Type"
+			:value <
+			(const <)
+			(const >)
+			(const =)
+			(const >=)
+			(const <=)))
+	 (group `(group ,match ,score ,expire ,type))
+	 (doc (concat (or (widget-get widget :doc)
+			  (concat "Change score based on the " tag
+				  " header.")))))
+    (widget-put widget :args `(,item
+			       (repeat :inline t
+				       :indent 0
+				       :tag ,tag
+				       :doc ,doc
+				       :format "%t:\n%h%v%i\n\n"
+				       ,group))))
+  widget)
+
+(define-widget 'gnus-score-date 'group
+  "Edit score entries for date-valued headers."
+  :convert-widget 'gnus-score-date-convert)
+
+(defun gnus-score-date-convert (widget)
+  ;; Set args appropriately.
+  (let* ((tag (widget-get widget :tag))
+	 (item `(const :format "" :value ,(downcase tag)))
+	 (match '(string :tag "Match"))
+	 (score '(choice :tag "Score"
+			(const :tag "default" nil)
+			(integer :format "%v"
+				 :hide-front-space t)))
+	 (expire '(choice :tag "Expire"
+			  (const :tag "off" nil)
+			  (integer :format "%v"
+				   :hide-front-space t)))
+	 (type '(choice :tag "Type"
+			:value regexp
+			(const regexp)
+			(const before)
+			(const at)
+			(const after)))
+	 (group `(group ,match ,score ,expire ,type))
+	 (doc (concat (or (widget-get widget :doc)
+			  (concat "Change score based on the " tag
+				  " header."))
+		      "
+For the Date header we have three kinda silly match types: `before',
+`at' and `after'.  I can't really imagine this ever being useful, but,
+like, it would feel kinda silly not to provide this function.  Just in
+case.  You never know.  Better safe than sorry.  Once burnt, twice
+shy.  Don't judge a book by its cover.  Never not have sex on a first
+date.  (I have been told that at least one person, and I quote,
+\"found this function indispensable\", however.)
+
+A more useful match type is `regexp'.  With it, you can match the date
+string using a regular expression.  The date is normalized to ISO8601
+compact format first---`YYYYMMDDTHHMMSS'.  If you want to match all
+articles that have been posted on April 1st in every year, you could
+use `....0401.........' as a match string, for instance.  (Note that
+the date is kept in its original time zone, so this will match
+articles that were posted when it was April 1st where the article was
+posted from.  Time zones are such wholesome fun for the whole family,
+eh?")))
+    (widget-put widget :args `(,item
+			       (repeat :inline t
+				       :indent 0
+				       :tag ,tag
+				       :doc ,doc
+				       :format "%t:\n%h%v%i\n\n"
+				       ,group))))
+  widget)
+
+(defvar gnus-custom-scores)
+(defvar gnus-custom-score-alist)
+
+(defun gnus-score-customize (file)
+  "Customize score file FILE."
+  (interactive (list gnus-current-score-file))
+  (let ((scores (gnus-score-load file))
+	(types (mapcar (lambda (entry)
+		 `(group :format "%v%h\n"
+			 :doc ,(nth 2 entry)
+			 (const :format "" ,(nth 0 entry))
+			 ,(nth 1 entry)))
+	       gnus-score-parameters)))
+    ;; Ready.
+    (kill-buffer (get-buffer-create "*Gnus Customize*"))
+    (switch-to-buffer (get-buffer-create "*Gnus Customize*"))
+    (gnus-custom-mode)
+    (make-local-variable 'gnus-custom-score-alist)
+    (setq gnus-custom-score-alist scores)
+    (widget-insert "Customize the ")
+    (widget-create 'info-link
+		   :help-echo "Push me to learn more."
+		   :tag "score entries"
+		   "(gnus)Score File Format")
+    (widget-insert " for\n\t")
+    (widget-insert file)
+    (widget-insert "\nand press ")
+    (widget-create 'push-button
+		   :tag "done"
+		   :help-echo "Push me when done customizing."
+		   :action 'gnus-score-customize-done)
+    (widget-insert ".\n
+Check the [ ] for the entries you want to apply to this score file, then
+edit the value to suit your taste.  Don't forget to mark the checkbox,
+if you do all your changes will be lost.  ")
+    (widget-create 'push-button
+		   :action (lambda (&rest ignore)
+			     (require 'gnus-audio)
+			     (gnus-audio-play "Evil_Laugh.au"))
+		   "Bhahahah!")
+    (widget-insert "\n\n")
+    (make-local-variable 'gnus-custom-scores)
+    (setq gnus-custom-scores
+	  (widget-create 'group
+			 :value scores
+			 `(checklist :inline t
+				     :greedy t
+				     (gnus-score-string :tag "From")
+				     (gnus-score-string :tag "Subject")
+				     (gnus-score-string :tag "References")
+				     (gnus-score-string :tag "Xref")
+				     (gnus-score-string :tag "Message-ID")
+				     (gnus-score-integer :tag "Lines")
+				     (gnus-score-integer :tag "Chars")
+				     (gnus-score-date :tag "Date")
+				     (gnus-score-string :tag "Head"
+							:doc "\
+Match all headers in the article.
+
+Using one of `Head', `Body', `All' will slow down scoring considerable.
+")
+				     (gnus-score-string :tag "Body"
+							:doc "\
+Match the body sans header of the article.
+
+Using one of `Head', `Body', `All' will slow down scoring considerable.
+")
+				     (gnus-score-string :tag "All"
+							:doc "\
+Match the entire article, including both headers and body.
+
+Using one of `Head', `Body', `All' will slow down scoring
+considerable.
+")
+				     (gnus-score-string :tag
+							"Followup"
+							:doc "\
+Score all followups to the specified authors.
+
+This entry is somewhat special, in that it will match the `From:'
+header, and affect the score of not only the matching articles, but
+also all followups to the matching articles.  This allows you
+e.g. increase the score of followups to your own articles, or decrease
+the score of followups to the articles of some known trouble-maker.
+")
+				     (gnus-score-string :tag "Thread"
+							:doc "\
+Add a score entry on all articles that are part of a thread.
+
+This match key works along the same lines as the `Followup' match key.
+If you say that you want to score on a (sub-)thread that is started by
+an article with a `Message-ID' X, then you add a `thread' match.  This
+will add a new `thread' match for each article that has X in its
+`References' header.  (These new `thread' matches will use the
+`Message-ID's of these matching articles.)  This will ensure that you
+can raise/lower the score of an entire thread, even though some
+articles in the thread may not have complete `References' headers.
+Note that using this may lead to undeterministic scores of the
+articles in the thread.
+")
+				     ,@types)
+			 '(repeat :inline t
+				  :tag "Unknown entries"
+				  sexp)))
+    (use-local-map widget-keymap)
+    (widget-setup)))
+
+(defun gnus-score-customize-done (&rest ignore)
+  "Reset the score alist with the present value."
+  (let ((alist gnus-custom-score-alist)
+	(value (widget-value gnus-custom-scores)))
+    (setcar alist (car value))
+    (setcdr alist (cdr value))
+    (gnus-score-set 'touched '(t) alist))
+  (bury-buffer))
+
+;;; The End:
+
+(provide 'gnus-cus)
+
+;;; gnus-cus.el ends here
+

lisp/gnus/gnus-demon.el

@@ -0,0 +1,290 @@
+;;; gnus-demon.el --- daemonic Gnus behaviour
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-int)
+(require 'nnheader)
+(eval-and-compile
+  (if (string-match "XEmacs" (emacs-version))
+      (require 'itimer)
+    (require 'timer)))
+
+(defgroup gnus-demon nil
+  "Demonic behaviour."
+  :group 'gnus)
+
+(defcustom gnus-demon-handlers nil
+  "Alist of daemonic handlers to be run at intervals.
+Each handler is a list on the form
+
+\(FUNCTION TIME IDLE)
+
+FUNCTION is the function to be called.
+TIME is the number of `gnus-demon-timestep's between each call.
+If nil, never call.  If t, call each `gnus-demon-timestep'.
+If IDLE is t, only call if Emacs has been idle for a while.  If IDLE
+is a number, only call when Emacs has been idle more than this number
+of `gnus-demon-timestep's.  If IDLE is nil, don't care about
+idleness.  If IDLE is a number and TIME is nil, then call once each
+time Emacs has been idle for IDLE `gnus-demon-timestep's."
+  :group 'gnus-demon
+  :type '(repeat (list function
+		       (choice :tag "Time"
+			       (const :tag "never" nil)
+			       (const :tag "one" t)
+			       (integer :tag "steps" 1))
+		       (choice :tag "Idle"
+			       (const :tag "don't care" nil)
+			       (const :tag "for a while" t)
+			       (integer :tag "steps" 1)))))
+
+(defcustom gnus-demon-timestep 60
+  "*Number of seconds in each demon timestep."
+  :group 'gnus-demon
+  :type 'integer)
+
+;;; Internal variables.
+
+(defvar gnus-demon-timer nil)
+(defvar gnus-demon-idle-has-been-called nil)
+(defvar gnus-demon-idle-time 0)
+(defvar gnus-demon-handler-state nil)
+(defvar gnus-demon-last-keys nil)
+(defvar gnus-inhibit-demon nil
+  "*If non-nil, no daemonic function will be run.")
+
+(eval-and-compile
+  (autoload 'timezone-parse-date "timezone")
+  (autoload 'timezone-make-arpa-date "timezone"))
+
+;;; Functions.
+
+(defun gnus-demon-add-handler (function time idle)
+  "Add the handler FUNCTION to be run at TIME and IDLE."
+  ;; First remove any old handlers that use this function.
+  (gnus-demon-remove-handler function)
+  ;; Then add the new one.
+  (push (list function time idle) gnus-demon-handlers)
+  (gnus-demon-init))
+
+(defun gnus-demon-remove-handler (function &optional no-init)
+  "Remove the handler FUNCTION from the list of handlers."
+  (setq gnus-demon-handlers
+	(delq (assq function gnus-demon-handlers)
+	      gnus-demon-handlers))
+  (unless no-init
+    (gnus-demon-init)))
+
+(defun gnus-demon-init ()
+  "Initialize the Gnus daemon."
+  (interactive)
+  (gnus-demon-cancel)
+  (if (null gnus-demon-handlers)
+      ()				; Nothing to do.
+    ;; Set up timer.
+    (setq gnus-demon-timer
+	  (nnheader-run-at-time
+	   gnus-demon-timestep gnus-demon-timestep 'gnus-demon))
+    ;; Reset control variables.
+    (setq gnus-demon-handler-state
+	  (mapcar
+	   (lambda (handler)
+	     (list (car handler) (gnus-demon-time-to-step (nth 1 handler))
+		   (nth 2 handler)))
+	   gnus-demon-handlers))
+    (setq gnus-demon-idle-time 0)
+    (setq gnus-demon-idle-has-been-called nil)
+    (setq gnus-use-demon t)))
+
+(gnus-add-shutdown 'gnus-demon-cancel 'gnus)
+
+(defun gnus-demon-cancel ()
+  "Cancel any Gnus daemons."
+  (interactive)
+  (when gnus-demon-timer
+    (nnheader-cancel-timer gnus-demon-timer))
+  (setq gnus-demon-timer nil
+	gnus-use-demon nil)
+  (condition-case ()
+      (nnheader-cancel-function-timers 'gnus-demon)
+    (error t)))
+
+(defun gnus-demon-is-idle-p ()
+  "Whether Emacs is idle or not."
+  ;; We do this simply by comparing the 100 most recent keystrokes
+  ;; with the ones we had last time.  If they are the same, one might
+  ;; guess that Emacs is indeed idle.  This only makes sense if one
+  ;; calls this function seldom -- like once a minute, which is what
+  ;; we do here.
+  (let ((keys (recent-keys)))
+    (or (equal keys gnus-demon-last-keys)
+	(progn
+	  (setq gnus-demon-last-keys keys)
+	  nil))))
+
+(defun gnus-demon-time-to-step (time)
+  "Find out how many seconds to TIME, which is on the form \"17:43\"."
+  (if (not (stringp time))
+      time
+    (let* ((date (current-time-string))
+	   (dv (timezone-parse-date date))
+	   (tdate (timezone-make-arpa-date
+		   (string-to-number (aref dv 0))
+		   (string-to-number (aref dv 1))
+		   (string-to-number (aref dv 2)) time
+		   (or (aref dv 4) "UT")))
+	   (nseconds (gnus-time-minus
+		      (gnus-encode-date tdate) (gnus-encode-date date))))
+      (round
+       (/ (+ (if (< (car nseconds) 0)
+ 		 86400 0)
+ 	     (* 65536 (car nseconds))
+ 	     (nth 1 nseconds))
+ 	  gnus-demon-timestep)))))
+
+(defun gnus-demon ()
+  "The Gnus daemon that takes care of running all Gnus handlers."
+  ;; Increase or reset the time Emacs has been idle.
+  (if (gnus-demon-is-idle-p)
+      (incf gnus-demon-idle-time)
+    (setq gnus-demon-idle-time 0)
+    (setq gnus-demon-idle-has-been-called nil))
+  ;; Disable all daemonic stuff if we're in the minibuffer
+  (when (and (not (window-minibuffer-p (selected-window)))
+	     (not gnus-inhibit-demon))
+    ;; Then we go through all the handler and call those that are
+    ;; sufficiently ripe.
+    (let ((handlers gnus-demon-handler-state)
+	  (gnus-inhibit-demon t)
+	  handler time idle)
+      (while handlers
+	(setq handler (pop handlers))
+	(cond
+	 ((numberp (setq time (nth 1 handler)))
+	  ;; These handlers use a regular timeout mechanism.  We decrease
+	  ;; the timer if it hasn't reached zero yet.
+	  (unless (zerop time)
+	    (setcar (nthcdr 1 handler) (decf time)))
+	  (and (zerop time)		; If the timer now is zero...
+	       ;; Test for appropriate idleness
+	       (progn
+		 (setq idle (nth 2 handler))
+		 (cond
+		  ((null idle) t)	; Don't care about idle.
+		  ((numberp idle)	; Numerical idle...
+		   (< idle gnus-demon-idle-time)) ; Idle timed out.
+		  (t (< 0 gnus-demon-idle-time)))) ; Or just need to be idle.
+	       ;; So we call the handler.
+	       (progn
+		 (funcall (car handler))
+		 ;; And reset the timer.
+		 (setcar (nthcdr 1 handler)
+			 (gnus-demon-time-to-step
+			  (nth 1 (assq (car handler) gnus-demon-handlers)))))))
+	 ;; These are only supposed to be called when Emacs is idle.
+	 ((null (setq idle (nth 2 handler)))
+	  ;; We do nothing.
+	  )
+	 ((not (numberp idle))
+	  ;; We want to call this handler each and every time that
+	  ;; Emacs is idle.
+	  (funcall (car handler)))
+	 (t
+	  ;; We want to call this handler only if Emacs has been idle
+	  ;; for a specified number of timesteps.
+	  (and (not (memq (car handler) gnus-demon-idle-has-been-called))
+	       (< idle gnus-demon-idle-time)
+	       (progn
+		 (funcall (car handler))
+		 ;; Make sure the handler won't be called once more in
+		 ;; this idle-cycle.
+		 (push (car handler) gnus-demon-idle-has-been-called)))))))))
+
+(defun gnus-demon-add-nocem ()
+  "Add daemonic NoCeM handling to Gnus."
+  (gnus-demon-add-handler 'gnus-demon-scan-nocem 60 t))
+
+(defun gnus-demon-scan-nocem ()
+  "Scan NoCeM groups for NoCeM messages."
+  (save-window-excursion
+    (gnus-nocem-scan-groups)))
+
+(defun gnus-demon-add-disconnection ()
+  "Add daemonic server disconnection to Gnus."
+  (gnus-demon-add-handler 'gnus-demon-close-connections nil 30))
+
+(defun gnus-demon-close-connections ()
+  (save-window-excursion
+    (gnus-close-backends)))
+
+(defun gnus-demon-add-scanmail ()
+  "Add daemonic scanning of mail from the mail backends."
+  (gnus-demon-add-handler 'gnus-demon-scan-mail 120 60))
+
+(defun gnus-demon-scan-mail ()
+  (save-window-excursion
+    (let ((servers gnus-opened-servers)
+	  server)
+      (while (setq server (car (pop servers)))
+	(and (gnus-check-backend-function 'request-scan (car server))
+	     (or (gnus-server-opened server)
+		 (gnus-open-server server))
+	     (gnus-request-scan nil server))))))
+
+(defun gnus-demon-add-rescan ()
+  "Add daemonic scanning of new articles from all backends."
+  (gnus-demon-add-handler 'gnus-demon-scan-news 120 60))
+
+(defun gnus-demon-scan-news ()
+  (save-window-excursion
+    (when (gnus-alive-p)
+      (save-excursion
+	(set-buffer gnus-group-buffer)
+	(gnus-group-get-new-news)))))
+
+(defun gnus-demon-add-scan-timestamps ()
+  "Add daemonic updating of timestamps in empty newgroups."
+  (gnus-demon-add-handler 'gnus-demon-scan-timestamps nil 30))
+
+(defun gnus-demon-scan-timestamps ()
+  "Set the timestamp on all newsgroups with no unread and no ticked articles."
+  (when (gnus-alive-p)
+    (let ((cur-time (current-time))
+	  (newsrc (cdr gnus-newsrc-alist))
+	  info group unread has-ticked)
+      (while (setq info (pop newsrc))
+	(setq group (gnus-info-group info)
+	      unread (gnus-group-unread group)
+	      has-ticked (cdr (assq 'tick (gnus-info-marks info))))
+	(when (and (numberp unread)
+		   (= unread 0)
+		   (not has-ticked))
+	  (gnus-group-set-parameter group 'timestamp cur-time))))))
+
+(provide 'gnus-demon)
+
+;;; gnus-demon.el ends here

lisp/gnus/gnus-dup.el

@@ -0,0 +1,158 @@
+;;; gnus-dup.el --- suppression of duplicate articles in Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This package tries to mark articles as read the second time the
+;; user reads a copy.  This is useful if the server doesn't support
+;; Xref properly, or if the user reads the same group from several
+;; servers.
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-art)
+
+(defgroup gnus-duplicate nil
+  "Suppression of duplicate articles."
+  :group 'gnus)
+
+(defcustom gnus-save-duplicate-list nil
+  "*If non-nil, save the duplicate list when shutting down Gnus.
+If nil, duplicate suppression will only work on duplicates
+seen in the same session."
+  :group 'gnus-duplicate
+  :type 'boolean)
+
+(defcustom gnus-duplicate-list-length 10000
+  "*The number of Message-IDs to keep in the duplicate suppression list."
+  :group 'gnus-duplicate
+  :type 'integer)
+
+(defcustom gnus-duplicate-file (nnheader-concat gnus-directory "suppression")
+  "*The name of the file to store the duplicate suppression list."
+  :group 'gnus-duplicate
+  :type 'file)
+
+;;; Internal variables
+
+(defvar gnus-dup-list nil)
+(defvar gnus-dup-hashtb nil)
+
+(defvar gnus-dup-list-dirty nil)
+
+;;;
+;;; Starting and stopping
+;;;
+
+(gnus-add-shutdown 'gnus-dup-close 'gnus)
+
+(defun gnus-dup-close ()
+  "Possibly save the duplicate suppression list and shut down the subsystem."
+  (gnus-dup-save)
+  (setq gnus-dup-list nil
+	gnus-dup-hashtb nil
+	gnus-dup-list-dirty nil))
+
+(defun gnus-dup-open ()
+  "Possibly read the duplicate suppression list and start the subsystem."
+  (if gnus-save-duplicate-list
+      (gnus-dup-read)
+    (setq gnus-dup-list nil))
+  (setq gnus-dup-hashtb (gnus-make-hashtable gnus-duplicate-list-length))
+  ;; Enter all Message-IDs into the hash table.
+  (let ((list gnus-dup-list)
+	(obarray gnus-dup-hashtb))
+    (while list
+      (intern (pop list)))))
+
+(defun gnus-dup-read ()
+  "Read the duplicate suppression list."
+  (setq gnus-dup-list nil)
+  (when (file-exists-p gnus-duplicate-file)
+    (load gnus-duplicate-file t t t)))
+
+(defun gnus-dup-save ()
+  "Save the duplicate suppression list."
+  (when (and gnus-save-duplicate-list
+	     gnus-dup-list-dirty)
+    (nnheader-temp-write gnus-duplicate-file
+      (gnus-prin1 `(setq gnus-dup-list ',gnus-dup-list))))
+  (setq gnus-dup-list-dirty nil))
+
+;;;
+;;; Interface functions
+;;;
+
+(defun gnus-dup-enter-articles ()
+  "Enter articles from the current group for future duplicate suppression."
+  (unless gnus-dup-list
+    (gnus-dup-open))
+  (setq gnus-dup-list-dirty t)		; mark list for saving
+  (let ((data gnus-newsgroup-data)
+ 	datum msgid)
+    ;; Enter the Message-IDs of all read articles into the list
+    ;; and hash table.
+    (while (setq datum (pop data))
+      (when (and (not (gnus-data-pseudo-p datum))
+		 (> (gnus-data-number datum) 0)
+		 (gnus-data-read-p datum)
+		 (not (= (gnus-data-mark datum) gnus-canceled-mark))
+ 		 (setq msgid (mail-header-id (gnus-data-header datum)))
+ 		 (not (nnheader-fake-message-id-p msgid))
+ 		 (not (intern-soft msgid gnus-dup-hashtb)))
+	(push msgid gnus-dup-list)
+ 	(intern msgid gnus-dup-hashtb))))
+  ;; Chop off excess Message-IDs from the list.
+  (let ((end (nthcdr gnus-duplicate-list-length gnus-dup-list)))
+    (when end
+      (setcdr end nil))))
+
+(defun gnus-dup-suppress-articles ()
+  "Mark duplicate articles as read."
+  (unless gnus-dup-list
+    (gnus-dup-open))
+  (gnus-message 6 "Suppressing duplicates...")
+  (let ((headers gnus-newsgroup-headers)
+	number header)
+    (while (setq header (pop headers))
+      (when (and (intern-soft (mail-header-id header) gnus-dup-hashtb)
+		 (gnus-summary-article-unread-p (mail-header-number header)))
+	(setq gnus-newsgroup-unreads
+	      (delq (setq number (mail-header-number header))
+		    gnus-newsgroup-unreads))
+	(push (cons number gnus-duplicate-mark)
+	      gnus-newsgroup-reads))))
+  (gnus-message 6 "Suppressing duplicates...done"))
+
+(defun gnus-dup-unsuppress-article (article)
+  "Stop suppression of ARTICLE."
+  (let ((id (mail-header-id (gnus-data-header (gnus-data-find article)))))
+    (when id
+      (setq gnus-dup-list-dirty t)
+      (setq gnus-dup-list (delete id gnus-dup-list))
+      (unintern id gnus-dup-hashtb))))
+
+(provide 'gnus-dup)
+
+;;; gnus-dup.el ends here

lisp/gnus/gnus-eform.el

@@ -0,0 +1,130 @@
+;;; gnus-eform.el --- a mode for editing forms for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-win)
+
+;;;
+;;; Editing forms
+;;;
+
+(defgroup gnus-edit-form nil
+  "A mode for editing forms."
+  :group 'gnus)
+
+(defcustom gnus-edit-form-mode-hook nil
+  "Hook run in `gnus-edit-form-mode' buffers."
+  :group 'gnus-edit-form
+  :type 'hook)
+
+(defcustom gnus-edit-form-menu-hook nil
+  "Hook run when creating menus in `gnus-edit-form-mode' buffers."
+  :group 'gnus-edit-form
+  :type 'hook)
+
+;;; Internal variables
+
+(defvar gnus-edit-form-done-function nil)
+(defvar gnus-edit-form-buffer "*Gnus edit form*")
+
+(defvar gnus-edit-form-mode-map nil)
+(unless gnus-edit-form-mode-map
+  (setq gnus-edit-form-mode-map (copy-keymap emacs-lisp-mode-map))
+  (gnus-define-keys gnus-edit-form-mode-map
+    "\C-c\C-c" gnus-edit-form-done
+    "\C-c\C-k" gnus-edit-form-exit))
+
+(defun gnus-edit-form-make-menu-bar ()
+  (unless (boundp 'gnus-edit-form-menu)
+    (easy-menu-define
+     gnus-edit-form-menu gnus-edit-form-mode-map ""
+     '("Edit Form"
+       ["Exit and save changes" gnus-edit-form-done t]
+       ["Exit" gnus-edit-form-exit t]))
+    (run-hooks 'gnus-edit-form-menu-hook)))
+
+(defun gnus-edit-form-mode ()
+  "Major mode for editing forms.
+It is a slightly enhanced emacs-lisp-mode.
+
+\\{gnus-edit-form-mode-map}"
+  (interactive)
+  (when (gnus-visual-p 'group-menu 'menu)
+    (gnus-edit-form-make-menu-bar))
+  (kill-all-local-variables)
+  (setq major-mode 'gnus-edit-form-mode)
+  (setq mode-name "Edit Form")
+  (use-local-map gnus-edit-form-mode-map)
+  (make-local-variable 'gnus-edit-form-done-function)
+  (make-local-variable 'gnus-prev-winconf)
+  (run-hooks 'gnus-edit-form-mode-hook))
+
+(defun gnus-edit-form (form documentation exit-func)
+  "Edit FORM in a new buffer.
+Call EXIT-FUNC on exit.  Display DOCUMENTATION in the beginning
+of the buffer."
+  (let ((winconf (current-window-configuration)))
+    (set-buffer (get-buffer-create gnus-edit-form-buffer))
+    (gnus-configure-windows 'edit-form)
+    (gnus-add-current-to-buffer-list)
+    (gnus-edit-form-mode)
+    (setq gnus-prev-winconf winconf)
+    (setq gnus-edit-form-done-function exit-func)
+    (erase-buffer)
+    (insert documentation)
+    (unless (bolp)
+      (insert "\n"))
+    (goto-char (point-min))
+    (while (not (eobp))
+      (insert ";;; ")
+      (forward-line 1))
+    (insert ";; Type `C-c C-c' after you've finished editing.\n")
+    (insert "\n")
+    (let ((p (point)))
+      (pp form (current-buffer))
+      (insert "\n")
+      (goto-char p))))
+
+(defun gnus-edit-form-done ()
+  "Update changes and kill the current buffer."
+  (interactive)
+  (goto-char (point-min))
+  (let ((form (read (current-buffer)))
+	(func gnus-edit-form-done-function))
+    (gnus-edit-form-exit)
+    (funcall func form)))
+
+(defun gnus-edit-form-exit ()
+  "Kill the current buffer."
+  (interactive)
+  (let ((winconf gnus-prev-winconf))
+    (kill-buffer (current-buffer))
+    (set-window-configuration winconf)))
+
+(provide 'gnus-eform)
+
+;;; gnus-eform.el ends here

lisp/gnus/gnus-ems.el

@@ -0,0 +1,212 @@
+;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-when-compile (require 'cl))
+
+;;; Function aliases later to be redefined for XEmacs usage.
+
+(defvar gnus-xemacs (string-match "XEmacs\\|Lucid" emacs-version)
+  "Non-nil if running under XEmacs.")
+
+(defvar gnus-mouse-2 [mouse-2])
+(defvar gnus-down-mouse-2 [down-mouse-2])
+
+(eval-and-compile
+  (autoload 'gnus-xmas-define "gnus-xmas")
+  (autoload 'gnus-xmas-redefine "gnus-xmas")
+  (autoload 'appt-select-lowest-window "appt.el"))
+
+(or (fboundp 'mail-file-babyl-p)
+    (fset 'mail-file-babyl-p 'rmail-file-p))
+
+;;; Mule functions.
+
+(defun gnus-mule-cite-add-face (number prefix face)
+  ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
+  (when face
+    (let ((inhibit-point-motion-hooks t)
+	  from to)
+      (goto-line number)
+      (if (boundp 'MULE)
+	  (forward-char (chars-in-string prefix))
+	(forward-char (length prefix)))
+      (skip-chars-forward " \t")
+      (setq from (point))
+      (end-of-line 1)
+      (skip-chars-backward " \t")
+      (setq to (point))
+      (when (< from to)
+	(gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
+
+(defun gnus-mule-max-width-function (el max-width)
+  (` (let* ((val (eval (, el)))
+	    (valstr (if (numberp val)
+			(int-to-string val) val)))
+       (if (> (length valstr) (, max-width))
+	   (truncate-string valstr (, max-width))
+	 valstr))))
+
+(eval-and-compile
+  (if (string-match "XEmacs\\|Lucid" emacs-version)
+      nil
+
+    (defvar gnus-mouse-face-prop 'mouse-face
+      "Property used for highlighting mouse regions.")
+
+    (defvar gnus-article-x-face-command
+      "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -"
+      "String or function to be executed to display an X-Face header.
+If it is a string, the command will be executed in a sub-shell
+asynchronously.	 The compressed face will be piped to this command."))
+
+  (cond
+   ((string-match "XEmacs\\|Lucid" emacs-version)
+    (gnus-xmas-define))
+
+   ((or (not (boundp 'emacs-minor-version))
+	(< emacs-minor-version 30))
+    ;; Remove the `intangible' prop.
+    (let ((props (and (boundp 'gnus-hidden-properties)
+		      gnus-hidden-properties)))
+      (while (and props (not (eq (car (cdr props)) 'intangible)))
+	(setq props (cdr props)))
+      (when props
+	(setcdr props (cdr (cdr (cdr props))))))
+    (unless (fboundp 'buffer-substring-no-properties)
+      (defun buffer-substring-no-properties (beg end)
+	(format "%s" (buffer-substring beg end)))))
+
+   ((boundp 'MULE)
+    (provide 'gnusutil))))
+
+(eval-and-compile
+  (cond
+   ((not window-system)
+    (defun gnus-dummy-func (&rest args))
+    (let ((funcs '(mouse-set-point set-face-foreground
+				   set-face-background x-popup-menu)))
+      (while funcs
+	(unless (fboundp (car funcs))
+	  (fset (car funcs) 'gnus-dummy-func))
+	(setq funcs (cdr funcs))))))
+  (unless (fboundp 'file-regular-p)
+    (defun file-regular-p (file)
+      (and (not (file-directory-p file))
+	   (not (file-symlink-p file))
+	   (file-exists-p file))))
+  (unless (fboundp 'face-list)
+    (defun face-list (&rest args))))
+
+(eval-and-compile
+  (let ((case-fold-search t))
+    (cond
+     ((string-match "windows-nt\\|os/2\\|emx" (format "%s" system-type))
+      (setq nnheader-file-name-translation-alist
+	    (append nnheader-file-name-translation-alist
+		    '((?: . ?_)
+		      (?+ . ?-))))))))
+
+(defvar gnus-tmp-unread)
+(defvar gnus-tmp-replied)
+(defvar gnus-tmp-score-char)
+(defvar gnus-tmp-indentation)
+(defvar gnus-tmp-opening-bracket)
+(defvar gnus-tmp-lines)
+(defvar gnus-tmp-name)
+(defvar gnus-tmp-closing-bracket)
+(defvar gnus-tmp-subject-or-nil)
+
+(defun gnus-ems-redefine ()
+  (cond
+   ((string-match "XEmacs\\|Lucid" emacs-version)
+    (gnus-xmas-redefine))
+
+   ((featurep 'mule)
+    ;; Mule and new Emacs definitions
+
+    ;; [Note] Now there are three kinds of mule implementations,
+    ;; original MULE, XEmacs/mule and beta version of Emacs including
+    ;; some mule features. Unfortunately these API are different. In
+    ;; particular, Emacs (including original MULE) and XEmacs are
+    ;; quite different.
+    ;; Predicates to check are following:
+    ;; (boundp 'MULE) is t only if MULE (original; anything older than
+    ;;                     Mule 2.3) is running.
+    ;; (featurep 'mule) is t when every mule variants are running.
+
+    ;; These implementations may be able to share between original
+    ;; MULE and beta version of new Emacs. In addition, it is able to
+    ;; detect XEmacs/mule by (featurep 'mule) and to check variable
+    ;; `emacs-version'. In this case, implementation for XEmacs/mule
+    ;; may be able to share between XEmacs and XEmacs/mule.
+
+    (defalias 'gnus-truncate-string 'truncate-string)
+
+    (defvar gnus-summary-display-table nil
+      "Display table used in summary mode buffers.")
+    (fset 'gnus-cite-add-face 'gnus-mule-cite-add-face)
+    (fset 'gnus-max-width-function 'gnus-mule-max-width-function)
+    (fset 'gnus-summary-set-display-table 'ignore)
+
+    (when (boundp 'gnus-check-before-posting)
+      (setq gnus-check-before-posting
+	    (delq 'long-lines
+		  (delq 'control-chars gnus-check-before-posting))))
+
+    (defun gnus-summary-line-format-spec ()
+      (insert gnus-tmp-unread gnus-tmp-replied
+	      gnus-tmp-score-char gnus-tmp-indentation)
+      (put-text-property
+       (point)
+       (progn
+	 (insert
+	  gnus-tmp-opening-bracket
+	  (format "%4d: %-20s"
+		  gnus-tmp-lines
+		  (if (> (length gnus-tmp-name) 20)
+		      (truncate-string gnus-tmp-name 20)
+		    gnus-tmp-name))
+	  gnus-tmp-closing-bracket)
+	 (point))
+       gnus-mouse-face-prop gnus-mouse-face)
+      (insert " " gnus-tmp-subject-or-nil "\n"))
+    )))
+
+(defun gnus-region-active-p ()
+  "Say whether the region is active."
+  (and (boundp 'transient-mark-mode)
+       transient-mark-mode
+       (boundp 'mark-active)
+       mark-active))
+
+(provide 'gnus-ems)
+
+;; Local Variables:
+;; byte-compile-warnings: '(redefine callargs)
+;; End:
+
+;;; gnus-ems.el ends here

lisp/gnus/gnus-gl.el

@@ -0,0 +1,862 @@
+;;; gnus-gl.el --- an interface to GroupLens for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Brad Miller <bmiller@cs.umn.edu>
+;; Keywords: news, score
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; GroupLens software and documentation is copyright (c) 1995 by Paul
+;; Resnick (Massachusetts Institute of Technology); Brad Miller, John
+;; Riedl, Jon Herlocker, and Joseph Konstan (University of Minnesota),
+;; and David Maltz (Carnegie-Mellon University).
+;;
+;; Permission to use, copy, modify, and distribute this documentation
+;; for non-commercial and commercial purposes without fee is hereby
+;; granted provided that this copyright notice and permission notice
+;; appears in all copies and that the names of the individuals and
+;; institutions holding this copyright are not used in advertising or
+;; publicity pertaining to this software without specific, written
+;; prior permission.  The copyright holders make no representations
+;; about the suitability of this software and documentation for any
+;; purpose.  It is provided ``as is'' without express or implied
+;; warranty.
+;;
+;; The copyright holders request that they be notified of
+;; modifications of this code.  Please send electronic mail to
+;; grouplens@cs.umn.edu for more information or to announce derived
+;; works.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Author: Brad Miller
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; User Documentation:
+;; To use GroupLens you must load this file.
+;; You must also register a pseudonym with the Better Bit Bureau.
+;; http://www.cs.umn.edu/Research/GroupLens
+;;
+;;    ---------------- For your .emacs or .gnus file ----------------
+;;
+;; As of version 2.5, grouplens now works as a minor mode of
+;; gnus-summary-mode.  To get make that work you just need a couple of
+;; hooks.
+;; (setq gnus-use-grouplens t)
+;; (setq grouplens-pseudonym "")
+;; (setq grouplens-bbb-host "grouplens.cs.umn.edu")
+;;
+;; (setq gnus-summary-default-score 0)
+;;
+;;                              USING GROUPLENS
+;; How do I Rate an article??
+;;   Before you type n to go to the next article, hit a number from 1-5
+;;   Type r in the summary buffer and you will be prompted.
+;;   Note that when you're in grouplens-minor-mode 'r' masks the
+;;   usual reply binding for 'r'
+;;
+;; What if, Gasp, I find a bug???
+;; Please type M-x gnus-gl-submit-bug-report.  This will set up a
+;; mail buffer with the  state of variables and buffers that will help
+;; me debug the problem.  A short description up front would help too!
+;;
+;; How do I display the prediction for an article:
+;;  If you set the gnus-summary-line-format as shown above, the score
+;;  (prediction) will be shown automatically.
+;;
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Programmer  Notes
+;; 10/9/95
+;; gnus-scores-articles contains the articles
+;; When scoring is done, the call tree looks something like:
+;; gnus-possibly-score-headers
+;;  ==> gnus-score-headers
+;;      ==> gnus-score-load-file
+;;          ==> get-all-mids  (from the eval form)
+;;
+;; it would be nice to have one that gets called after all the other
+;; headers have been scored.
+;; we may want a variable gnus-grouplens-scale-factor
+;; and gnus-grouplens-offset  this would probably be either -3 or 0
+;; to make the scores centered around zero or not.
+;; Notes 10/12/95
+;; According to Lars, Norse god of gnus, the simple way to insert a
+;; call to an external function is to have a function added to the
+;; variable gnus-score-find-files-function  This new function
+;; gnus-grouplens-score-alist will return a core alist that
+;; has (("message-id" ("<message-id-xxxx>" score) ("<message-id-xxxy>" score))
+;; This seems like it would be pretty inefficient, though workable.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;  TODO
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; 3. Add some more ways to rate messages
+;; 4. Better error handling for token timeouts.
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; bugs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+
+;;; Code:
+
+(require 'gnus-score)
+(require 'cl)
+(require 'gnus)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; User variables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defvar gnus-summary-grouplens-line-format
+  "%U\%R\%z%l%I\%(%[%4L: %-20,20n%]%) %s\n"
+  "*The line format spec in summary GroupLens mode buffers.")
+
+(defvar grouplens-pseudonym ""
+  "User's pseudonym.
+This pseudonym is obtained during the registration process")
+
+(defvar grouplens-bbb-host "grouplens.cs.umn.edu"
+  "Host where the bbbd is running" )
+
+(defvar grouplens-bbb-port 9000
+  "Port where the bbbd is listening" )
+
+(defvar grouplens-newsgroups
+  '("comp.groupware" "comp.human-factors" "comp.lang.c++"
+    "comp.lang.java" "comp.os.linux.admin" "comp.os.linux.advocacy"
+    "comp.os.linux.announce" "comp.os.linux.answers"
+    "comp.os.linux.development" "comp.os.linux.development.apps"
+    "comp.os.linux.development.system" "comp.os.linux.hardware"
+    "comp.os.linux.help" "comp.os.linux.m68k" "comp.os.linux.misc"
+    "comp.os.linux.networking" "comp.os.linux.setup" "comp.os.linux.x"
+    "mn.general" "rec.arts.movies" "rec.arts.movies.current-films"
+    "rec.food.recipes" "rec.humor")
+  "*Groups that are part of the GroupLens experiment.")
+
+(defvar grouplens-prediction-display 'prediction-spot
+  "valid values are:
+      prediction-spot -- an * corresponding to the prediction between 1 and 5,
+      confidence-interval -- a numeric confidence interval
+      prediction-bar --  |#####     | the longer the bar, the better the article,
+      confidence-bar --  |  -----   } the prediction is in the middle of the bar,
+      confidence-spot -- )  *       | the spot gets bigger with more confidence,
+      prediction-num  --   plain-old numeric value,
+      confidence-plus-minus  -- prediction +/i confidence")
+
+(defvar grouplens-score-offset 0
+  "Offset the prediction by this value.
+Setting this variable to -2 would have the following effect on
+GroupLens scores:
+
+   1   -->   -2
+   2   -->   -1
+   3   -->    0
+   4   -->    1
+   5   -->    2
+
+The reason is that a user might want to do this is to combine
+GroupLens predictions with scores calculated by other score methods.")
+
+(defvar grouplens-score-scale-factor 1
+  "This variable allows the user to magnify the effect of GroupLens scores.
+The scale factor is applied after the offset.")
+
+(defvar gnus-grouplens-override-scoring 'override
+  "Tell GroupLens to override the normal Gnus scoring mechanism.
+GroupLens scores can be combined with gnus scores in one of three ways.
+'override -- just use grouplens predictions for grouplens groups
+'combine  -- combine grouplens scores with gnus scores
+'separate -- treat grouplens scores completely separate from gnus")
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; Program global variables
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar grouplens-bbb-token nil
+  "Current session token number")
+
+(defvar grouplens-bbb-process nil
+  "Process Id of current bbbd network stream process")
+
+(defvar grouplens-bbb-buffer nil
+  "Buffer associated with the BBBD process")
+
+(defvar grouplens-rating-alist nil
+  "Current set of  message-id rating pairs")
+
+(defvar grouplens-current-hashtable nil
+  "A hashtable to hold predictions from the BBB")
+
+(defvar grouplens-current-group nil)
+
+;;(defvar bbb-alist nil)
+
+(defvar bbb-timeout-secs 10
+  "Number of seconds to wait for some response from the BBB.
+If this times out we give up and assume that something has died..." )
+
+(defvar grouplens-previous-article nil
+  "Message-ID of the last article read.")
+
+(defvar bbb-read-point)
+(defvar bbb-response-point)
+
+(defun bbb-renew-hash-table ()
+  (setq grouplens-current-hashtable (make-vector 100 0)))
+
+(bbb-renew-hash-table)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;  Utility Functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun bbb-connect-to-bbbd (host port)
+  (unless grouplens-bbb-buffer
+    (setq grouplens-bbb-buffer
+	  (get-buffer-create (format " *BBBD trace: %s*" host)))
+    (save-excursion
+      (set-buffer grouplens-bbb-buffer)
+      (make-local-variable 'bbb-read-point)
+      (make-local-variable 'bbb-response-point)
+      (setq bbb-read-point (point-min))))
+
+  ;; if an old process is still running for some reason, kill it
+  (when grouplens-bbb-process
+    (ignore-errors
+      (when (eq 'open (process-status grouplens-bbb-process))
+	(set-process-buffer grouplens-bbb-process nil)
+	(delete-process grouplens-bbb-process))))
+
+  ;; clear the trace buffer of old output
+  (save-excursion
+    (set-buffer grouplens-bbb-buffer)
+    (erase-buffer))
+
+  ;; open the connection to the server
+  (catch 'done
+    (condition-case error
+	(setq grouplens-bbb-process
+	      (open-network-stream "BBBD" grouplens-bbb-buffer host port))
+      (error (gnus-message 3 "Error: Failed to connect to BBB")
+	     nil))
+    (and (null grouplens-bbb-process)
+	 (throw 'done nil))
+    (save-excursion
+      (set-buffer grouplens-bbb-buffer)
+      (setq bbb-read-point (point-min))
+      (or (bbb-read-response grouplens-bbb-process)
+	  (throw 'done nil))))
+
+  ;; return the process
+  grouplens-bbb-process)
+
+(defun bbb-send-command (process command)
+  (goto-char (point-max))
+  (insert command)
+  (insert "\r\n")
+  (setq bbb-read-point (point))
+  (setq bbb-response-point (point))
+  (set-marker (process-mark process) (point)) ; process output also comes here
+  (process-send-string process command)
+  (process-send-string process "\r\n")
+  (process-send-eof process))
+
+(defun bbb-read-response (process)
+  "This function eats the initial response of OK or ERROR from the BBB."
+  (let ((case-fold-search nil)
+	match-end)
+    (goto-char bbb-read-point)
+    (while (and (not (search-forward "\r\n" nil t))
+		(accept-process-output process bbb-timeout-secs))
+      (goto-char bbb-read-point))
+    (setq match-end (point))
+    (goto-char bbb-read-point)
+    (setq bbb-read-point match-end)
+    (looking-at "OK")))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;       Login Functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun bbb-login ()
+  "return the token number if login is successful, otherwise return nil"
+  (interactive)
+  (setq grouplens-bbb-token nil)
+  (if (not (equal grouplens-pseudonym ""))
+      (let ((bbb-process
+	     (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port)))
+	(if bbb-process
+	    (save-excursion
+	      (set-buffer (process-buffer bbb-process))
+	      (bbb-send-command bbb-process
+				(concat "login " grouplens-pseudonym))
+	      (if (bbb-read-response bbb-process)
+		  (setq grouplens-bbb-token (bbb-extract-token-number))
+	      (gnus-message 3 "Error: GroupLens login failed")))))
+    (gnus-message 3 "Error: you must set a pseudonym"))
+  grouplens-bbb-token)
+
+(defun bbb-extract-token-number ()
+  (let ((token-pos (search-forward "token=" nil t)))
+    (when (looking-at "[0-9]+")
+      (buffer-substring token-pos (match-end 0)))))
+
+(gnus-add-shutdown 'bbb-logout 'gnus)
+
+(defun bbb-logout ()
+  "logout of bbb session"
+  (when grouplens-bbb-token
+    (let ((bbb-process
+	   (bbb-connect-to-bbbd grouplens-bbb-host grouplens-bbb-port)))
+      (when bbb-process
+	(save-excursion
+	  (set-buffer (process-buffer bbb-process))
+	  (bbb-send-command bbb-process (concat "logout " grouplens-bbb-token))
+	  (bbb-read-response bbb-process))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;       Get Predictions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun bbb-build-mid-scores-alist (groupname)
+  "this function can be called as part of the function to return the
+list of score files to use.  See the gnus variable
+gnus-score-find-score-files-function.
+
+*Note:*  If you want to use grouplens scores along with calculated scores,
+you should see the offset and scale variables.  At this point, I don't
+recommend using both scores and grouplens predictions together."
+  (setq grouplens-current-group groupname)
+  (when (member groupname grouplens-newsgroups)
+    (setq grouplens-previous-article nil)
+    ;; scores-alist should be a list of lists:
+    ;;  ((("message-id" ("<mid1>" score1 nil s) ("<mid2> score2 nil s))))
+    ;;`((("message-id" . ,predict-list))) ; Yes, this is the return value
+    (list
+     (list
+      (list (append (list "message-id")
+		    (bbb-get-predictions (bbb-get-all-mids) groupname)))))))
+
+(defun bbb-get-predictions (midlist groupname)
+  "Ask the bbb for predictions, and build up the score alist."
+  (gnus-message 5 "Fetching Predictions...")
+  (if grouplens-bbb-token
+      (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host
+					      grouplens-bbb-port)))
+	(when bbb-process
+	  (save-excursion
+	    (set-buffer (process-buffer bbb-process))
+	    (bbb-send-command bbb-process
+			      (bbb-build-predict-command midlist groupname
+							 grouplens-bbb-token))
+	    (if (bbb-read-response bbb-process)
+		(bbb-get-prediction-response bbb-process)
+	      (gnus-message 1 "Invalid Token, login and try again")
+	      (ding)))))
+    (gnus-message 3 "Error: You are not logged in to a BBB")
+    (ding)))
+
+(defun bbb-get-all-mids ()
+  (mapcar (function (lambda (x) (mail-header-id x))) gnus-newsgroup-headers))
+
+(defun bbb-build-predict-command (mlist grpname token)
+  (concat "getpredictions " token " " grpname "\r\n"
+	  (mapconcat 'identity mlist "\r\n") "\r\n.\r\n"))
+
+(defun bbb-get-prediction-response (process)
+  (let ((case-fold-search nil))
+    (goto-char bbb-read-point)
+    (while (and (not (search-forward ".\r\n" nil t))
+		(accept-process-output process bbb-timeout-secs))
+      (goto-char bbb-read-point))
+    (goto-char (+ bbb-response-point 4));; we ought to be right before OK
+    (bbb-build-response-alist)))
+
+;; build-response-alist assumes that the cursor has been positioned at
+;; the first line of the list of mid/rating pairs.
+(defun bbb-build-response-alist ()
+  (let (resp mid pred)
+    (while
+	(cond
+	 ((looking-at "\\(<.*>\\) :nopred=")
+	  ;;(push `(,(bbb-get-mid) ,gnus-summary-default-score nil s) resp)
+	  (forward-line 1)
+	  t)
+	 ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\) :conflow=\\([0-9]\.[0-9][0-9]\\) :confhigh=\\([0-9]\.[0-9][0-9]\\)")
+	  (setq mid (bbb-get-mid)
+		pred (bbb-get-pred))
+	  (push `(,mid ,pred nil s) resp)
+	  (gnus-sethash mid (list pred (bbb-get-confl) (bbb-get-confh))
+		      grouplens-current-hashtable)
+	  (forward-line 1)
+	  t)
+	 ((looking-at "\\(<.*>\\) :pred=\\([0-9]\.[0-9][0-9]\\)")
+	  (setq mid (bbb-get-mid)
+		pred (bbb-get-pred))
+	  (push `(,mid ,pred nil s) resp)
+	  (gnus-sethash mid (list pred 0 0) grouplens-current-hashtable)
+	  (forward-line 1)
+	  t)
+	 (t nil)))
+    resp))
+
+;; these "get" functions assume that there is an active match lying
+;; around.  Where the first parenthesized expression is the
+;; message-id, and the second is the prediction, the third and fourth
+;; are the confidence interval
+;;
+;; Since gnus assumes that scores are integer values?? we round the
+;; prediction.
+(defun bbb-get-mid ()
+  (buffer-substring (match-beginning 1) (match-end 1)))
+
+(defun bbb-get-pred ()
+  (let ((tpred (string-to-number (buffer-substring (match-beginning 2)
+						   (match-end 2)))))
+    (if (> tpred 0)
+	(round (* grouplens-score-scale-factor
+		  (+ grouplens-score-offset tpred)))
+      1)))
+
+(defun bbb-get-confl ()
+  (string-to-number (buffer-substring (match-beginning 4) (match-end 4))))
+
+(defun bbb-get-confh ()
+  (string-to-number (buffer-substring (match-beginning 4) (match-end 4))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;      Prediction Display
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defconst grplens-rating-range 4.0)
+(defconst grplens-maxrating 5)
+(defconst grplens-minrating 1)
+(defconst grplens-predstringsize 12)
+
+(defvar gnus-tmp-score)
+(defun bbb-grouplens-score (header)
+  (if (eq gnus-grouplens-override-scoring 'separate)
+      (bbb-grouplens-other-score header)
+    (let* ((rate-string (make-string 12 ?\ ))
+	   (mid (mail-header-id header))
+	   (hashent (gnus-gethash mid grouplens-current-hashtable))
+	   (iscore gnus-tmp-score)
+	   (low (car (cdr hashent)))
+	   (high (car (cdr (cdr hashent)))))
+      (aset rate-string 0 ?|)
+      (aset rate-string 11 ?|)
+      (unless (member grouplens-current-group grouplens-newsgroups)
+	(unless (equal grouplens-prediction-display 'prediction-num)
+	  (cond ((< iscore 0)
+		 (setq iscore 1))
+		((> iscore 5)
+		 (setq iscore 5))))
+	(setq low 0)
+	(setq high 0))
+      (if (and (bbb-valid-score iscore)
+	       (not (null mid)))
+	  (cond
+	   ;; prediction-spot
+	   ((equal grouplens-prediction-display 'prediction-spot)
+	    (setq rate-string (bbb-fmt-prediction-spot rate-string iscore)))
+	   ;; confidence-interval
+	   ((equal grouplens-prediction-display 'confidence-interval)
+	    (setq rate-string (bbb-fmt-confidence-interval iscore low high)))
+	   ;; prediction-bar
+	   ((equal grouplens-prediction-display 'prediction-bar)
+	    (setq rate-string (bbb-fmt-prediction-bar rate-string iscore)))
+	   ;; confidence-bar
+	   ((equal grouplens-prediction-display 'confidence-bar)
+	    (setq rate-string (format "|   %4.2f   |" iscore)))
+	   ;; confidence-spot
+	   ((equal grouplens-prediction-display 'confidence-spot)
+	    (setq rate-string (format "|   %4.2f   |" iscore)))
+	   ;; prediction-num
+	   ((equal grouplens-prediction-display 'prediction-num)
+	    (setq rate-string (bbb-fmt-prediction-num iscore)))
+	   ;; confidence-plus-minus
+	   ((equal grouplens-prediction-display 'confidence-plus-minus)
+	    (setq rate-string (bbb-fmt-confidence-plus-minus iscore low high))
+	    )
+	   (t (gnus-message 3 "Invalid prediction display type")))
+	(aset rate-string 5 ?N) (aset rate-string 6 ?A))
+      rate-string)))
+
+;; Gnus user format function that doesn't depend on
+;; bbb-build-mid-scores-alist being used as the score function, but is
+;; instead called from gnus-select-group-hook. -- LAB
+(defun bbb-grouplens-other-score (header)
+  (if (not (member grouplens-current-group grouplens-newsgroups))
+      ;; Return an empty string
+      ""
+    (let* ((rate-string (make-string 12 ?\ ))
+           (mid (mail-header-id header))
+           (hashent (gnus-gethash mid grouplens-current-hashtable))
+           (pred (or (nth 0 hashent) 0))
+           (low (nth 1 hashent))
+           (high (nth 2 hashent)))
+      ;; Init rate-string
+      (aset rate-string 0 ?|)
+      (aset rate-string 11 ?|)
+      (unless (equal grouplens-prediction-display 'prediction-num)
+	(cond ((< pred 0)
+	       (setq pred 1))
+	      ((> pred 5)
+	       (setq pred 5))))
+      ;; If no entry in BBB hash mark rate string as NA and return
+      (cond
+       ((null hashent)
+	(aset rate-string 5 ?N)
+	(aset rate-string 6 ?A)
+	rate-string)
+
+       ((equal grouplens-prediction-display 'prediction-spot)
+	(bbb-fmt-prediction-spot rate-string pred))
+
+       ((equal grouplens-prediction-display 'confidence-interval)
+	(bbb-fmt-confidence-interval pred low high))
+
+       ((equal grouplens-prediction-display 'prediction-bar)
+	(bbb-fmt-prediction-bar rate-string pred))
+
+       ((equal grouplens-prediction-display 'confidence-bar)
+	(format "|   %4.2f   |" pred))
+
+       ((equal grouplens-prediction-display 'confidence-spot)
+	(format "|   %4.2f   |" pred))
+
+       ((equal grouplens-prediction-display 'prediction-num)
+	(bbb-fmt-prediction-num pred))
+
+       ((equal grouplens-prediction-display 'confidence-plus-minus)
+	(bbb-fmt-confidence-plus-minus pred low high))
+
+       (t
+	(gnus-message 3 "Invalid prediction display type")
+	(aset rate-string 0 ?|)
+	(aset rate-string 11 ?|)
+	rate-string)))))
+
+(defun bbb-valid-score (score)
+  (or (equal grouplens-prediction-display 'prediction-num)
+      (and (>= score grplens-minrating)
+	   (<= score grplens-maxrating))))
+
+(defun bbb-requires-confidence (format-type)
+  (or (equal format-type 'confidence-plus-minus)
+      (equal format-type 'confidence-spot)
+      (equal format-type 'confidence-interval)))
+
+(defun bbb-have-confidence (clow chigh)
+  (not (or (null clow)
+	   (null chigh))))
+
+(defun bbb-fmt-prediction-spot (rate-string score)
+  (aset rate-string
+	(round (* (/ (- score grplens-minrating) grplens-rating-range)
+		  (+ (- grplens-predstringsize 4) 1.49)))
+	?*)
+  rate-string)
+
+(defun bbb-fmt-confidence-interval (score low high)
+  (if (bbb-have-confidence low high)
+      (format "|%4.2f-%4.2f |" low high)
+    (bbb-fmt-prediction-num score)))
+
+(defun bbb-fmt-confidence-plus-minus (score low high)
+  (if (bbb-have-confidence low high)
+      (format "|%3.1f+/-%4.2f|" score (/ (- high low) 2.0))
+    (bbb-fmt-prediction-num score)))
+
+(defun bbb-fmt-prediction-bar (rate-string score)
+  (let* ((i 1)
+	 (step (/ grplens-rating-range (- grplens-predstringsize 4)))
+	 (half-step (/ step 2))
+	 (loc (- grplens-minrating half-step)))
+    (while (< i (- grplens-predstringsize 2))
+      (if (> score loc)
+	  (aset rate-string i ?#)
+	(aset rate-string i ?\ ))
+      (setq i (+ i 1))
+      (setq loc (+ loc step)))
+    )
+  rate-string)
+
+(defun bbb-fmt-prediction-num (score)
+  (format "|   %4.2f   |" score))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;       Put Ratings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun bbb-put-ratings ()
+  (if (and grouplens-bbb-token
+	   grouplens-rating-alist
+	   (member gnus-newsgroup-name grouplens-newsgroups))
+      (let ((bbb-process (bbb-connect-to-bbbd grouplens-bbb-host
+					      grouplens-bbb-port))
+	    (rate-command (bbb-build-rate-command grouplens-rating-alist)))
+	(if bbb-process
+	    (save-excursion
+	      (set-buffer (process-buffer bbb-process))
+	      (gnus-message 5 "Sending Ratings...")
+	      (bbb-send-command bbb-process rate-command)
+	      (if (bbb-read-response bbb-process)
+		  (setq grouplens-rating-alist nil)
+		(gnus-message 1
+			      "Token timed out: call bbb-login and quit again")
+		(ding))
+	      (gnus-message 5 "Sending Ratings...Done"))
+	  (gnus-message 3 "No BBB connection")))
+    (setq grouplens-rating-alist nil)))
+
+(defun bbb-build-rate-command (rate-alist)
+  (concat "putratings " grouplens-bbb-token " " grouplens-current-group " \r\n"
+	  (mapconcat '(lambda (this)	; form (mid . (score . time))
+			(concat (car this)
+				" :rating=" (cadr this) ".00"
+				" :time=" (cddr this)))
+		     rate-alist "\r\n")
+	  "\r\n.\r\n"))
+
+;; Interactive rating functions.
+(defun bbb-summary-rate-article (rating &optional midin)
+  (interactive "nRating: ")
+  (when (member gnus-newsgroup-name grouplens-newsgroups)
+    (let ((mid (or midin (bbb-get-current-id))))
+      (if (and rating
+	       (>= rating grplens-minrating)
+	       (<= rating grplens-maxrating)
+	       mid)
+	  (let ((oldrating (assoc mid grouplens-rating-alist)))
+	    (if oldrating
+		(setcdr oldrating (cons rating 0))
+	      (push `(,mid . (,rating . 0)) grouplens-rating-alist))
+	    (gnus-summary-mark-article nil (int-to-string rating)))
+	(gnus-message 3 "Invalid rating")))))
+
+(defun grouplens-next-unread-article (rating)
+  "Select unread article after current one."
+  (interactive "P")
+  (when rating
+    (bbb-summary-rate-article rating))
+  (gnus-summary-next-unread-article))
+
+(defun grouplens-best-unread-article (rating)
+  "Select unread article after current one."
+  (interactive "P")
+  (when rating
+    (bbb-summary-rate-article rating))
+  (gnus-summary-best-unread-article))
+
+(defun grouplens-summary-catchup-and-exit (rating)
+  "Mark all articles not marked as unread in this newsgroup as read,
+    then exit.   If prefix argument ALL is non-nil, all articles are
+    marked as read."
+  (interactive "P")
+  (when rating
+    (bbb-summary-rate-article rating))
+  (if (numberp rating)
+      (gnus-summary-catchup-and-exit)
+    (gnus-summary-catchup-and-exit rating)))
+
+(defun grouplens-score-thread (score)
+  "Raise the score of the articles in the current thread with SCORE."
+  (interactive "nRating: ")
+  (let (e)
+    (save-excursion
+      (let ((articles (gnus-summary-articles-in-thread))
+	    article)
+	(while (setq article (pop articles))
+	  (gnus-summary-goto-subject article)
+	  (gnus-set-global-variables)
+	  (bbb-summary-rate-article score
+				    (mail-header-id
+				     (gnus-summary-article-header article)))))
+      (setq e (point)))
+    (let ((gnus-summary-check-current t))
+      (or (zerop (gnus-summary-next-subject 1 t))
+	  (goto-char e))))
+  (gnus-summary-recenter)
+  (gnus-summary-position-point)
+  (gnus-set-mode-line 'summary))
+
+(defun bbb-exit-group ()
+  (bbb-put-ratings)
+  (bbb-renew-hash-table))
+
+(defun bbb-get-current-id ()
+  (if gnus-current-headers
+      (mail-header-id gnus-current-headers)
+    (gnus-message 3 "You must select an article before you rate it")))
+
+(defun bbb-grouplens-group-p (group)
+  "Say whether GROUP is a GroupLens group."
+  (if (member group grouplens-newsgroups) " (GroupLens Enhanced)" ""))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;          TIME SPENT READING
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar grouplens-current-starting-time nil)
+
+(defun grouplens-start-timer ()
+  (setq grouplens-current-starting-time (current-time)))
+
+(defun grouplens-elapsed-time ()
+  (let ((et (bbb-time-float (current-time))))
+    (- et (bbb-time-float grouplens-current-starting-time))))
+
+(defun bbb-time-float (timeval)
+  (+ (* (car timeval) 65536)
+     (cadr timeval)))
+
+(defun grouplens-do-time ()
+  (when (member gnus-newsgroup-name grouplens-newsgroups)
+    (when grouplens-previous-article
+      (let ((elapsed-time (grouplens-elapsed-time))
+	    (oldrating (assoc grouplens-previous-article
+			      grouplens-rating-alist)))
+	(if (not oldrating)
+	    (push `(,grouplens-previous-article . (0 . ,elapsed-time))
+		  grouplens-rating-alist)
+	  (setcdr oldrating (cons (cadr oldrating) elapsed-time)))))
+    (grouplens-start-timer)
+    (setq grouplens-previous-article (bbb-get-current-id))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;          BUG REPORTING
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defconst gnus-gl-version "gnus-gl.el 2.50")
+(defconst gnus-gl-maintainer-address "grouplens-bug@cs.umn.edu")
+(defun gnus-gl-submit-bug-report ()
+  "Submit via mail a bug report on gnus-gl"
+  (interactive)
+  (require 'reporter)
+  (reporter-submit-bug-report gnus-gl-maintainer-address
+			      (concat "gnus-gl.el " gnus-gl-version)
+			      (list 'grouplens-pseudonym
+				    'grouplens-bbb-host
+				    'grouplens-bbb-port
+				    'grouplens-newsgroups
+				    'grouplens-bbb-token
+				    'grouplens-bbb-process
+				    'grouplens-current-group
+				    'grouplens-previous-article)
+			      nil
+			      'gnus-gl-get-trace))
+
+(defun gnus-gl-get-trace ()
+  "Insert the contents of the BBBD trace buffer"
+  (when grouplens-bbb-buffer
+    (insert-buffer grouplens-bbb-buffer)))
+
+;;
+;; GroupLens minor mode
+;;
+
+(defvar gnus-grouplens-mode nil
+  "Minor mode for providing a GroupLens interface in Gnus summary buffers.")
+
+(defvar gnus-grouplens-mode-map nil)
+
+(unless gnus-grouplens-mode-map
+  (setq gnus-grouplens-mode-map (make-keymap))
+  (gnus-define-keys
+   gnus-grouplens-mode-map
+   "n" grouplens-next-unread-article
+   "r" bbb-summary-rate-article
+   "k" grouplens-score-thread
+   "c" grouplens-summary-catchup-and-exit
+   "," grouplens-best-unread-article))
+
+(defun gnus-grouplens-make-menu-bar ()
+  (unless (boundp 'gnus-grouplens-menu)
+    (easy-menu-define
+     gnus-grouplens-menu gnus-grouplens-mode-map ""
+     '("GroupLens"
+       ["Login" bbb-login t]
+       ["Rate" bbb-summary-rate-article t]
+       ["Next article" grouplens-next-unread-article t]
+       ["Best article" grouplens-best-unread-article t]
+       ["Raise thread" grouplens-score-thread t]
+       ["Report bugs" gnus-gl-submit-bug-report t]))))
+
+(defun gnus-grouplens-mode (&optional arg)
+  "Minor mode for providing a GroupLens interface in Gnus summary buffers."
+  (interactive "P")
+  (when (and (eq major-mode 'gnus-summary-mode)
+	     (member gnus-newsgroup-name grouplens-newsgroups))
+    (make-local-variable 'gnus-grouplens-mode)
+    (setq gnus-grouplens-mode
+	  (if (null arg) (not gnus-grouplens-mode)
+	    (> (prefix-numeric-value arg) 0)))
+    (when gnus-grouplens-mode
+      (make-local-hook 'gnus-select-article-hook)
+      (add-hook 'gnus-select-article-hook 'grouplens-do-time nil 'local)
+      (make-local-hook 'gnus-exit-group-hook)
+      (add-hook 'gnus-exit-group-hook 'bbb-exit-group nil 'local)
+      (make-local-variable 'gnus-score-find-score-files-function)
+
+      (cond
+       ((eq gnus-grouplens-override-scoring 'combine)
+	;; either add bbb-buld-mid-scores-alist to a list
+	;; or make a list
+	(if (listp gnus-score-find-score-files-function)
+	    (setq gnus-score-find-score-files-function
+		  (append 'bbb-build-mid-scores-alist
+			  gnus-score-find-score-files-function))
+	  (setq gnus-score-find-score-files-function
+		(list gnus-score-find-score-files-function
+		      'bbb-build-mid-scores-alist))))
+       ;; leave the gnus-score-find-score-files variable alone
+       ((eq gnus-grouplens-override-scoring 'separate)
+	(add-hook 'gnus-select-group-hook
+		  (lambda ()
+		    (bbb-get-predictions (bbb-get-all-mids)
+					 gnus-newsgroup-name))))
+       ;; default is to override
+       (t
+	(setq gnus-score-find-score-files-function
+	      'bbb-build-mid-scores-alist)))
+
+      ;; Change how summary lines look
+      (make-local-variable 'gnus-summary-line-format)
+      (make-local-variable 'gnus-summary-line-format-spec)
+      (setq gnus-summary-line-format gnus-summary-grouplens-line-format)
+      (setq gnus-summary-line-format-spec nil)
+      (gnus-update-format-specifications nil 'summary)
+      (gnus-update-summary-mark-positions)
+
+      ;; Set up the menu.
+      (when (and menu-bar-mode
+		 (gnus-visual-p 'grouplens-menu 'menu))
+	(gnus-grouplens-make-menu-bar))
+      (unless (assq 'gnus-grouplens-mode minor-mode-alist)
+	(push '(gnus-grouplens-mode " GroupLens") minor-mode-alist))
+      (unless (assq 'gnus-grouplens-mode minor-mode-map-alist)
+	(push (cons 'gnus-grouplens-mode gnus-grouplens-mode-map)
+	      minor-mode-map-alist))
+      (run-hooks 'gnus-grouplens-mode-hook))))
+
+(provide 'gnus-gl)
+
+;;; gnus-gl.el ends here

lisp/gnus/gnus-int.el

@@ -0,0 +1,438 @@
+;;; gnus-int.el --- backend interface functions for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+
+(defcustom gnus-open-server-hook nil
+  "Hook called just before opening connection to the news server."
+  :group 'gnus-start
+  :type 'hook)
+
+;;;
+;;; Server Communication
+;;;
+
+(defun gnus-start-news-server (&optional confirm)
+  "Open a method for getting news.
+If CONFIRM is non-nil, the user will be asked for an NNTP server."
+  (let (how)
+    (if gnus-current-select-method
+	;; Stream is already opened.
+	nil
+      ;; Open NNTP server.
+      (unless gnus-nntp-service
+	(setq gnus-nntp-server nil))
+      (when confirm
+	;; Read server name with completion.
+	(setq gnus-nntp-server
+	      (completing-read "NNTP server: "
+			       (mapcar (lambda (server) (list server))
+				       (cons (list gnus-nntp-server)
+					     gnus-secondary-servers))
+			       nil nil gnus-nntp-server)))
+
+      (when (and gnus-nntp-server
+		 (stringp gnus-nntp-server)
+		 (not (string= gnus-nntp-server "")))
+	(setq gnus-select-method
+	      (cond ((or (string= gnus-nntp-server "")
+			 (string= gnus-nntp-server "::"))
+		     (list 'nnspool (system-name)))
+		    ((string-match "^:" gnus-nntp-server)
+		     (list 'nnmh gnus-nntp-server
+			   (list 'nnmh-directory
+				 (file-name-as-directory
+				  (expand-file-name
+				   (concat "~/" (substring
+						 gnus-nntp-server 1)))))
+			   (list 'nnmh-get-new-mail nil)))
+		    (t
+		     (list 'nntp gnus-nntp-server)))))
+
+      (setq how (car gnus-select-method))
+      (cond
+       ((eq how 'nnspool)
+	(require 'nnspool)
+	(gnus-message 5 "Looking up local news spool..."))
+       ((eq how 'nnmh)
+	(require 'nnmh)
+	(gnus-message 5 "Looking up mh spool..."))
+       (t
+	(require 'nntp)))
+      (setq gnus-current-select-method gnus-select-method)
+      (run-hooks 'gnus-open-server-hook)
+      (or
+       ;; gnus-open-server-hook might have opened it
+       (gnus-server-opened gnus-select-method)
+       (gnus-open-server gnus-select-method)
+       (gnus-y-or-n-p
+	(format
+	 "%s (%s) open error: '%s'.  Continue? "
+	 (car gnus-select-method) (cadr gnus-select-method)
+	 (gnus-status-message gnus-select-method)))
+       (gnus-error 1 "Couldn't open server on %s"
+		   (nth 1 gnus-select-method))))))
+
+(defun gnus-check-group (group)
+  "Try to make sure that the server where GROUP exists is alive."
+  (let ((method (gnus-find-method-for-group group)))
+    (or (gnus-server-opened method)
+	(gnus-open-server method))))
+
+(defun gnus-check-server (&optional method silent)
+  "Check whether the connection to METHOD is down.
+If METHOD is nil, use `gnus-select-method'.
+If it is down, start it up (again)."
+  (let ((method (or method gnus-select-method)))
+    ;; Transform virtual server names into select methods.
+    (when (stringp method)
+      (setq method (gnus-server-to-method method)))
+    (if (gnus-server-opened method)
+	;; The stream is already opened.
+	t
+      ;; Open the server.
+      (unless silent
+	(gnus-message 5 "Opening %s server%s..." (car method)
+		      (if (equal (nth 1 method) "") ""
+			(format " on %s" (nth 1 method)))))
+      (run-hooks 'gnus-open-server-hook)
+      (prog1
+	  (gnus-open-server method)
+	(unless silent
+	  (message ""))))))
+
+(defun gnus-get-function (method function &optional noerror)
+  "Return a function symbol based on METHOD and FUNCTION."
+  ;; Translate server names into methods.
+  (unless method
+    (error "Attempted use of a nil select method"))
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (let ((func (intern (format "%s-%s" (car method) function))))
+    ;; If the functions isn't bound, we require the backend in
+    ;; question.
+    (unless (fboundp func)
+      (require (car method))
+      (when (and (not (fboundp func))
+		 (not noerror))
+	;; This backend doesn't implement this function.
+	(error "No such function: %s" func)))
+    func))
+
+
+;;;
+;;; Interface functions to the backends.
+;;;
+
+(defun gnus-open-server (method)
+  "Open a connection to METHOD."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (let ((elem (assoc method gnus-opened-servers)))
+    ;; If this method was previously denied, we just return nil.
+    (if (eq (nth 1 elem) 'denied)
+	(progn
+	  (gnus-message 1 "Denied server")
+	  nil)
+      ;; Open the server.
+      (let ((result
+	     (funcall (gnus-get-function method 'open-server)
+		      (nth 1 method) (nthcdr 2 method))))
+	;; If this hasn't been opened before, we add it to the list.
+	(unless elem
+	  (setq elem (list method nil)
+		gnus-opened-servers (cons elem gnus-opened-servers)))
+	;; Set the status of this server.
+	(setcar (cdr elem) (if result 'ok 'denied))
+	;; Return the result from the "open" call.
+	result))))
+
+(defun gnus-close-server (method)
+  "Close the connection to METHOD."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (funcall (gnus-get-function method 'close-server) (nth 1 method)))
+
+(defun gnus-request-list (method)
+  "Request the active file from METHOD."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (funcall (gnus-get-function method 'request-list) (nth 1 method)))
+
+(defun gnus-request-list-newsgroups (method)
+  "Request the newsgroups file from METHOD."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method)))
+
+(defun gnus-request-newgroups (date method)
+  "Request all new groups since DATE from METHOD."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (let ((func (gnus-get-function method 'request-newgroups t)))
+    (when func
+      (funcall func date (nth 1 method)))))
+
+(defun gnus-server-opened (method)
+  "Check whether a connection to METHOD has been opened."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (funcall (inline (gnus-get-function method 'server-opened)) (nth 1 method)))
+
+(defun gnus-status-message (method)
+  "Return the status message from METHOD.
+If METHOD is a string, it is interpreted as a group name.   The method
+this group uses will be queried."
+  (let ((method (if (stringp method) (gnus-find-method-for-group method)
+		  method)))
+    (funcall (gnus-get-function method 'status-message) (nth 1 method))))
+
+(defun gnus-request-regenerate (method)
+  "Request a data generation from METHOD."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (funcall (gnus-get-function method 'request-regenerate) (nth 1 method)))
+
+(defun gnus-request-group (group &optional dont-check method)
+  "Request GROUP.  If DONT-CHECK, no information is required."
+  (let ((method (or method (inline (gnus-find-method-for-group group)))))
+    (when (stringp method)
+      (setq method (inline (gnus-server-to-method method))))
+    (funcall (inline (gnus-get-function method 'request-group))
+	     (gnus-group-real-name group) (nth 1 method) dont-check)))
+
+(defun gnus-list-active-group (group)
+  "Request active information on GROUP."
+  (let ((method (gnus-find-method-for-group group))
+	(func 'list-active-group))
+    (when (gnus-check-backend-function func group)
+      (funcall (gnus-get-function method func)
+	       (gnus-group-real-name group) (nth 1 method)))))
+
+(defun gnus-request-group-description (group)
+  "Request a description of GROUP."
+  (let ((method (gnus-find-method-for-group group))
+	(func 'request-group-description))
+    (when (gnus-check-backend-function func group)
+      (funcall (gnus-get-function method func)
+	       (gnus-group-real-name group) (nth 1 method)))))
+
+(defun gnus-close-group (group)
+  "Request the GROUP be closed."
+  (let ((method (inline (gnus-find-method-for-group group))))
+    (funcall (gnus-get-function method 'close-group)
+	     (gnus-group-real-name group) (nth 1 method))))
+
+(defun gnus-retrieve-headers (articles group &optional fetch-old)
+  "Request headers for ARTICLES in GROUP.
+If FETCH-OLD, retrieve all headers (or some subset thereof) in the group."
+  (let ((method (gnus-find-method-for-group group)))
+    (if (and gnus-use-cache (numberp (car articles)))
+	(gnus-cache-retrieve-headers articles group fetch-old)
+      (funcall (gnus-get-function method 'retrieve-headers)
+	       articles (gnus-group-real-name group) (nth 1 method)
+	       fetch-old))))
+
+(defun gnus-retrieve-groups (groups method)
+  "Request active information on GROUPS from METHOD."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method)))
+
+(defun gnus-request-type (group &optional article)
+  "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
+  (let ((method (gnus-find-method-for-group group)))
+    (if (not (gnus-check-backend-function 'request-type (car method)))
+	'unknown
+      (funcall (gnus-get-function method 'request-type)
+	       (gnus-group-real-name group) article))))
+
+(defun gnus-request-update-mark (group article mark)
+  "Return the type (`post' or `mail') of GROUP (and ARTICLE)."
+  (let ((method (gnus-find-method-for-group group)))
+    (if (not (gnus-check-backend-function 'request-update-mark (car method)))
+	mark
+      (funcall (gnus-get-function method 'request-update-mark)
+	       (gnus-group-real-name group) article mark))))
+
+(defun gnus-request-article (article group &optional buffer)
+  "Request the ARTICLE in GROUP.
+ARTICLE can either be an article number or an article Message-ID.
+If BUFFER, insert the article in that group."
+  (let ((method (gnus-find-method-for-group group)))
+    (funcall (gnus-get-function method 'request-article)
+	     article (gnus-group-real-name group) (nth 1 method) buffer)))
+
+(defun gnus-request-head (article group)
+  "Request the head of ARTICLE in GROUP."
+  (let* ((method (gnus-find-method-for-group group))
+	 (head (gnus-get-function method 'request-head t))
+	 res clean-up)
+    (cond
+     ;; Check the cache.
+     ((and gnus-use-cache
+	   (numberp article)
+	   (gnus-cache-request-article article group))
+      (setq res (cons group article)
+	    clean-up t))
+     ;; Use `head' function.
+     ((fboundp head)
+      (setq res (funcall head article (gnus-group-real-name group)
+			 (nth 1 method))))
+     ;; Use `article' function.
+     (t
+      (setq res (gnus-request-article article group)
+	    clean-up t)))
+    (when clean-up
+      (save-excursion
+	(set-buffer nntp-server-buffer)
+	(goto-char (point-min))
+	(when (search-forward "\n\n" nil t)
+	  (delete-region (1- (point)) (point-max)))
+	(nnheader-fold-continuation-lines)))
+    res))
+
+(defun gnus-request-body (article group)
+  "Request the body of ARTICLE in GROUP."
+  (let ((method (gnus-find-method-for-group group)))
+    (funcall (gnus-get-function method 'request-body)
+	     article (gnus-group-real-name group) (nth 1 method))))
+
+(defun gnus-request-post (method)
+  "Post the current buffer using METHOD."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (funcall (gnus-get-function method 'request-post) (nth 1 method)))
+
+(defun gnus-request-scan (group method)
+  "Request a SCAN being performed in GROUP from METHOD.
+If GROUP is nil, all groups on METHOD are scanned."
+  (let ((method (if group (gnus-find-method-for-group group) method))
+	(gnus-inhibit-demon t))
+    (funcall (gnus-get-function method 'request-scan)
+	     (and group (gnus-group-real-name group)) (nth 1 method))))
+
+(defsubst gnus-request-update-info (info method)
+  "Request that METHOD update INFO."
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (when (gnus-check-backend-function 'request-update-info (car method))
+    (funcall (gnus-get-function method 'request-update-info)
+	     (gnus-group-real-name (gnus-info-group info))
+	     info (nth 1 method))))
+
+(defun gnus-request-expire-articles (articles group &optional force)
+  (let ((method (gnus-find-method-for-group group)))
+    (funcall (gnus-get-function method 'request-expire-articles)
+	     articles (gnus-group-real-name group) (nth 1 method)
+	     force)))
+
+(defun gnus-request-move-article
+  (article group server accept-function &optional last)
+  (let ((method (gnus-find-method-for-group group)))
+    (funcall (gnus-get-function method 'request-move-article)
+	     article (gnus-group-real-name group)
+	     (nth 1 method) accept-function last)))
+
+(defun gnus-request-accept-article (group method &optional last)
+  ;; Make sure there's a newline at the end of the article.
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (when (and (not method)
+	     (stringp group))
+    (setq method (gnus-group-name-to-method group)))
+  (goto-char (point-max))
+  (unless (bolp)
+    (insert "\n"))
+  (let ((func (car (or method (gnus-find-method-for-group group)))))
+    (funcall (intern (format "%s-request-accept-article" func))
+	     (if (stringp group) (gnus-group-real-name group) group)
+	     (cadr method)
+	     last)))
+
+(defun gnus-request-replace-article (article group buffer)
+  (let ((func (car (gnus-find-method-for-group group))))
+    (funcall (intern (format "%s-request-replace-article" func))
+	     article (gnus-group-real-name group) buffer)))
+
+(defun gnus-request-associate-buffer (group)
+  (let ((method (gnus-find-method-for-group group)))
+    (funcall (gnus-get-function method 'request-associate-buffer)
+	     (gnus-group-real-name group))))
+
+(defun gnus-request-restore-buffer (article group)
+  "Request a new buffer restored to the state of ARTICLE."
+  (let ((method (gnus-find-method-for-group group)))
+    (funcall (gnus-get-function method 'request-restore-buffer)
+	     article (gnus-group-real-name group) (nth 1 method))))
+
+(defun gnus-request-create-group (group &optional method args)
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (let ((method (or method (gnus-find-method-for-group group))))
+    (funcall (gnus-get-function method 'request-create-group)
+	     (gnus-group-real-name group) (nth 1 method) args)))
+
+(defun gnus-request-delete-group (group &optional force)
+  (let ((method (gnus-find-method-for-group group)))
+    (funcall (gnus-get-function method 'request-delete-group)
+	     (gnus-group-real-name group) force (nth 1 method))))
+
+(defun gnus-request-rename-group (group new-name)
+  (let ((method (gnus-find-method-for-group group)))
+    (funcall (gnus-get-function method 'request-rename-group)
+	     (gnus-group-real-name group)
+	     (gnus-group-real-name new-name) (nth 1 method))))
+
+(defun gnus-close-backends ()
+  ;; Send a close request to all backends that support such a request.
+  (let ((methods gnus-valid-select-methods)
+	(gnus-inhibit-demon t)
+	func method)
+    (while (setq method (pop methods))
+      (when (fboundp (setq func (intern
+				 (concat (car method) "-request-close"))))
+	(funcall func)))))
+
+(defun gnus-asynchronous-p (method)
+  (let ((func (gnus-get-function method 'asynchronous-p t)))
+    (when (fboundp func)
+      (funcall func))))
+
+(defun gnus-remove-denial (method)
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (let* ((elem (assoc method gnus-opened-servers))
+	 (status (cadr elem)))
+    ;; If this hasn't been opened before, we add it to the list.
+    (when (eq status 'denied)
+      ;; Set the status of this server.
+      (setcar (cdr elem) 'closed))))
+
+(provide 'gnus-int)
+
+;;; gnus-int.el ends here

lisp/gnus/gnus-kill.el

@@ -0,0 +1,717 @@
+;;; gnus-kill.el --- kill commands for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;;	Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-art)
+(require 'gnus-range)
+
+(defcustom gnus-kill-file-mode-hook nil
+  "Hook for Gnus kill file mode."
+  :group 'gnus-score-kill
+  :type 'hook)
+
+(defcustom gnus-kill-expiry-days 7
+  "*Number of days before expiring unused kill file entries."
+  :group 'gnus-score-kill
+  :group 'gnus-score-expire
+  :type 'integer)
+
+(defcustom gnus-kill-save-kill-file nil
+  "*If non-nil, will save kill files after processing them."
+  :group 'gnus-score-kill
+  :type 'boolean)
+
+(defcustom gnus-winconf-kill-file nil
+  "What does this do, Lars?"
+  :group 'gnus-score-kill
+  :type 'sexp)
+
+(defcustom gnus-kill-killed t
+  "*If non-nil, Gnus will apply kill files to already killed articles.
+If it is nil, Gnus will never apply kill files to articles that have
+already been through the scoring process, which might very well save lots
+of time."
+  :group 'gnus-score-kill
+  :type 'boolean)
+
+
+
+(defmacro gnus-raise (field expression level)
+  `(gnus-kill ,field ,expression
+	      (function (gnus-summary-raise-score ,level)) t))
+
+(defmacro gnus-lower (field expression level)
+  `(gnus-kill ,field ,expression
+	      (function (gnus-summary-raise-score (- ,level))) t))
+
+;;;
+;;; Gnus Kill File Mode
+;;;
+
+(defvar gnus-kill-file-mode-map nil)
+
+(unless gnus-kill-file-mode-map
+  (gnus-define-keymap (setq gnus-kill-file-mode-map
+			    (copy-keymap emacs-lisp-mode-map))
+    "\C-c\C-k\C-s" gnus-kill-file-kill-by-subject
+    "\C-c\C-k\C-a" gnus-kill-file-kill-by-author
+    "\C-c\C-k\C-t" gnus-kill-file-kill-by-thread
+    "\C-c\C-k\C-x" gnus-kill-file-kill-by-xref
+    "\C-c\C-a" gnus-kill-file-apply-buffer
+    "\C-c\C-e" gnus-kill-file-apply-last-sexp
+    "\C-c\C-c" gnus-kill-file-exit))
+
+(defun gnus-kill-file-mode ()
+  "Major mode for editing kill files.
+
+If you are using this mode - you probably shouldn't.  Kill files
+perform badly and paint with a pretty broad brush.  Score files, on
+the other hand, are vastly faster (40x speedup) and give you more
+control over what to do.
+
+In addition to Emacs-Lisp Mode, the following commands are available:
+
+\\{gnus-kill-file-mode-map}
+
+  A kill file contains Lisp expressions to be applied to a selected
+newsgroup.  The purpose is to mark articles as read on the basis of
+some set of regexps.  A global kill file is applied to every newsgroup,
+and a local kill file is applied to a specified newsgroup.  Since a
+global kill file is applied to every newsgroup, for better performance
+use a local one.
+
+  A kill file can contain any kind of Emacs Lisp expressions expected
+to be evaluated in the Summary buffer.  Writing Lisp programs for this
+purpose is not so easy because the internal working of Gnus must be
+well-known.  For this reason, Gnus provides a general function which
+does this easily for non-Lisp programmers.
+
+  The `gnus-kill' function executes commands available in Summary Mode
+by their key sequences.  `gnus-kill' should be called with FIELD,
+REGEXP and optional COMMAND and ALL.  FIELD is a string representing
+the header field or an empty string.  If FIELD is an empty string, the
+entire article body is searched for.  REGEXP is a string which is
+compared with FIELD value.  COMMAND is a string representing a valid
+key sequence in Summary mode or Lisp expression.  COMMAND defaults to
+'(gnus-summary-mark-as-read nil \"X\").  Make sure that COMMAND is
+executed in the Summary buffer.  If the second optional argument ALL
+is non-nil, the COMMAND is applied to articles which are already
+marked as read or unread.  Articles which are marked are skipped over
+by default.
+
+  For example, if you want to mark articles of which subjects contain
+the string `AI' as read, a possible kill file may look like:
+
+	(gnus-kill \"Subject\" \"AI\")
+
+  If you want to mark articles with `D' instead of `X', you can use
+the following expression:
+
+	(gnus-kill \"Subject\" \"AI\" \"d\")
+
+In this example it is assumed that the command
+`gnus-summary-mark-as-read-forward' is assigned to `d' in Summary Mode.
+
+  It is possible to delete unnecessary headers which are marked with
+`X' in a kill file as follows:
+
+	(gnus-expunge \"X\")
+
+  If the Summary buffer is empty after applying kill files, Gnus will
+exit the selected newsgroup normally.  If headers which are marked
+with `D' are deleted in a kill file, it is impossible to read articles
+which are marked as read in the previous Gnus sessions.  Marks other
+than `D' should be used for articles which should really be deleted.
+
+Entry to this mode calls emacs-lisp-mode-hook and
+gnus-kill-file-mode-hook with no arguments, if that value is non-nil."
+  (interactive)
+  (kill-all-local-variables)
+  (use-local-map gnus-kill-file-mode-map)
+  (set-syntax-table emacs-lisp-mode-syntax-table)
+  (setq major-mode 'gnus-kill-file-mode)
+  (setq mode-name "Kill")
+  (lisp-mode-variables nil)
+  (run-hooks 'emacs-lisp-mode-hook 'gnus-kill-file-mode-hook))
+
+(defun gnus-kill-file-edit-file (newsgroup)
+  "Begin editing a kill file for NEWSGROUP.
+If NEWSGROUP is nil, the global kill file is selected."
+  (interactive "sNewsgroup: ")
+  (let ((file (gnus-newsgroup-kill-file newsgroup)))
+    (gnus-make-directory (file-name-directory file))
+    ;; Save current window configuration if this is first invocation.
+    (or (and (get-file-buffer file)
+	     (get-buffer-window (get-file-buffer file)))
+	(setq gnus-winconf-kill-file (current-window-configuration)))
+    ;; Hack windows.
+    (let ((buffer (find-file-noselect file)))
+      (cond ((get-buffer-window buffer)
+	     (pop-to-buffer buffer))
+	    ((eq major-mode 'gnus-group-mode)
+	     (gnus-configure-windows 'group) ;Take all windows.
+	     (pop-to-buffer buffer))
+	    ((eq major-mode 'gnus-summary-mode)
+	     (gnus-configure-windows 'article)
+	     (pop-to-buffer gnus-article-buffer)
+	     (bury-buffer gnus-article-buffer)
+	     (switch-to-buffer buffer))
+	    (t				;No good rules.
+	     (find-file-other-window file))))
+    (gnus-kill-file-mode)))
+
+;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
+(defun gnus-kill-set-kill-buffer ()
+  (let* ((file (gnus-newsgroup-kill-file gnus-newsgroup-name))
+	 (buffer (find-file-noselect file)))
+    (set-buffer buffer)
+    (gnus-kill-file-mode)
+    (bury-buffer buffer)))
+
+(defun gnus-kill-file-enter-kill (field regexp &optional dont-move)
+  ;; Enter kill file entry.
+  ;; FIELD: String containing the name of the header field to kill.
+  ;; REGEXP: The string to kill.
+  (save-excursion
+    (let (string)
+      (unless (eq major-mode 'gnus-kill-file-mode)
+	(gnus-kill-set-kill-buffer))
+      (unless dont-move
+	(goto-char (point-max)))
+      (insert (setq string (format "(gnus-kill %S %S)\n" field regexp)))
+      (gnus-kill-file-apply-string string))))
+
+(defun gnus-kill-file-kill-by-subject ()
+  "Kill by subject."
+  (interactive)
+  (gnus-kill-file-enter-kill
+   "Subject"
+   (if (vectorp gnus-current-headers)
+       (regexp-quote
+	(gnus-simplify-subject (mail-header-subject gnus-current-headers)))
+     "")
+   t))
+
+(defun gnus-kill-file-kill-by-author ()
+  "Kill by author."
+  (interactive)
+  (gnus-kill-file-enter-kill
+   "From"
+   (if (vectorp gnus-current-headers)
+       (regexp-quote (mail-header-from gnus-current-headers))
+     "") t))
+
+(defun gnus-kill-file-kill-by-thread ()
+  "Kill by author."
+  (interactive)
+  (gnus-kill-file-enter-kill
+   "References"
+   (if (vectorp gnus-current-headers)
+       (regexp-quote (mail-header-id gnus-current-headers))
+     "")))
+
+(defun gnus-kill-file-kill-by-xref ()
+  "Kill by Xref."
+  (interactive)
+  (let ((xref (and (vectorp gnus-current-headers)
+		   (mail-header-xref gnus-current-headers)))
+	(start 0)
+	group)
+    (if xref
+	(while (string-match " \\([^ \t]+\\):" xref start)
+	  (setq start (match-end 0))
+	  (when (not (string=
+		      (setq group
+			    (substring xref (match-beginning 1) (match-end 1)))
+		      gnus-newsgroup-name))
+	    (gnus-kill-file-enter-kill
+	     "Xref" (concat " " (regexp-quote group) ":") t)))
+      (gnus-kill-file-enter-kill "Xref" "" t))))
+
+(defun gnus-kill-file-raise-followups-to-author (level)
+  "Raise score for all followups to the current author."
+  (interactive "p")
+  (let ((name (mail-header-from gnus-current-headers))
+	string)
+    (save-excursion
+      (gnus-kill-set-kill-buffer)
+      (goto-char (point-min))
+      (setq name (read-string (concat "Add " level
+				      " to followup articles to: ")
+			      (regexp-quote name)))
+      (setq
+       string
+       (format
+	"(gnus-kill %S %S '(gnus-summary-temporarily-raise-by-thread %S))\n"
+	"From" name level))
+      (insert string)
+      (gnus-kill-file-apply-string string))
+    (gnus-message
+     6 "Added temporary score file entry for followups to %s." name)))
+
+(defun gnus-kill-file-apply-buffer ()
+  "Apply current buffer to current newsgroup."
+  (interactive)
+  (if (and gnus-current-kill-article
+	   (get-buffer gnus-summary-buffer))
+      ;; Assume newsgroup is selected.
+      (gnus-kill-file-apply-string (buffer-string))
+    (ding) (gnus-message 2 "No newsgroup is selected.")))
+
+(defun gnus-kill-file-apply-string (string)
+  "Apply STRING to current newsgroup."
+  (interactive)
+  (let ((string (concat "(progn \n" string "\n)")))
+    (save-excursion
+      (save-window-excursion
+	(pop-to-buffer gnus-summary-buffer)
+	(eval (car (read-from-string string)))))))
+
+(defun gnus-kill-file-apply-last-sexp ()
+  "Apply sexp before point in current buffer to current newsgroup."
+  (interactive)
+  (if (and gnus-current-kill-article
+	   (get-buffer gnus-summary-buffer))
+      ;; Assume newsgroup is selected.
+      (let ((string
+	     (buffer-substring
+	      (save-excursion (forward-sexp -1) (point)) (point))))
+	(save-excursion
+	  (save-window-excursion
+	    (pop-to-buffer gnus-summary-buffer)
+	    (eval (car (read-from-string string))))))
+    (ding) (gnus-message 2 "No newsgroup is selected.")))
+
+(defun gnus-kill-file-exit ()
+  "Save a kill file, then return to the previous buffer."
+  (interactive)
+  (save-buffer)
+  (let ((killbuf (current-buffer)))
+    ;; We don't want to return to article buffer.
+    (when (get-buffer gnus-article-buffer)
+      (bury-buffer gnus-article-buffer))
+    ;; Delete the KILL file windows.
+    (delete-windows-on killbuf)
+    ;; Restore last window configuration if available.
+    (when gnus-winconf-kill-file
+      (set-window-configuration gnus-winconf-kill-file))
+    (setq gnus-winconf-kill-file nil)
+    ;; Kill the KILL file buffer.  Suggested by tale@pawl.rpi.edu.
+    (kill-buffer killbuf)))
+
+;; For kill files
+
+(defun gnus-Newsgroup-kill-file (newsgroup)
+  "Return the name of a kill file for NEWSGROUP.
+If NEWSGROUP is nil, return the global kill file instead."
+  (cond ((or (null newsgroup)
+	     (string-equal newsgroup ""))
+	 ;; The global kill file is placed at top of the directory.
+	 (expand-file-name gnus-kill-file-name gnus-kill-files-directory))
+	(gnus-use-long-file-name
+	 ;; Append ".KILL" to capitalized newsgroup name.
+	 (expand-file-name (concat (gnus-capitalize-newsgroup newsgroup)
+				   "." gnus-kill-file-name)
+			   gnus-kill-files-directory))
+	(t
+	 ;; Place "KILL" under the hierarchical directory.
+	 (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
+				   "/" gnus-kill-file-name)
+			   gnus-kill-files-directory))))
+
+(defun gnus-expunge (marks)
+  "Remove lines marked with MARKS."
+  (save-excursion
+    (set-buffer gnus-summary-buffer)
+    (gnus-summary-limit-to-marks marks 'reverse)))
+
+(defun gnus-apply-kill-file-unless-scored ()
+  "Apply .KILL file, unless a .SCORE file for the same newsgroup exists."
+  (cond ((file-exists-p (gnus-score-file-name gnus-newsgroup-name))
+         ;; Ignores global KILL.
+         (when (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name))
+	   (gnus-message 3 "Note: Ignoring %s.KILL; preferring .SCORE"
+			 gnus-newsgroup-name))
+         0)
+        ((or (file-exists-p (gnus-newsgroup-kill-file nil))
+             (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
+         (gnus-apply-kill-file-internal))
+        (t
+         0)))
+
+(defun gnus-apply-kill-file-internal ()
+  "Apply a kill file to the current newsgroup.
+Returns the number of articles marked as read."
+  (let* ((kill-files (list (gnus-newsgroup-kill-file nil)
+			   (gnus-newsgroup-kill-file gnus-newsgroup-name)))
+	 (unreads (length gnus-newsgroup-unreads))
+	 (gnus-summary-inhibit-highlight t)
+	 beg)
+    (setq gnus-newsgroup-kill-headers nil)
+    ;; If there are any previously scored articles, we remove these
+    ;; from the `gnus-newsgroup-headers' list that the score functions
+    ;; will see.  This is probably pretty wasteful when it comes to
+    ;; conses, but is, I think, faster than having to assq in every
+    ;; single score function.
+    (let ((files kill-files))
+      (while files
+	(if (file-exists-p (car files))
+	    (let ((headers gnus-newsgroup-headers))
+	      (if gnus-kill-killed
+		  (setq gnus-newsgroup-kill-headers
+			(mapcar (lambda (header) (mail-header-number header))
+				headers))
+		(while headers
+		  (unless (gnus-member-of-range
+			   (mail-header-number (car headers))
+			   gnus-newsgroup-killed)
+		    (push (mail-header-number (car headers))
+			  gnus-newsgroup-kill-headers))
+		  (setq headers (cdr headers))))
+	      (setq files nil))
+ 	  (setq files (cdr files)))))
+    (if (not gnus-newsgroup-kill-headers)
+	()
+      (save-window-excursion
+	(save-excursion
+	  (while kill-files
+	    (if (not (file-exists-p (car kill-files)))
+		()
+	      (gnus-message 6 "Processing kill file %s..." (car kill-files))
+	      (find-file (car kill-files))
+	      (gnus-add-current-to-buffer-list)
+	      (goto-char (point-min))
+
+	      (if (consp (ignore-errors (read (current-buffer))))
+		  (gnus-kill-parse-gnus-kill-file)
+		(gnus-kill-parse-rn-kill-file))
+
+	      (gnus-message
+	       6 "Processing kill file %s...done" (car kill-files)))
+	    (setq kill-files (cdr kill-files)))))
+
+      (gnus-set-mode-line 'summary)
+
+      (if beg
+	  (let ((nunreads (- unreads (length gnus-newsgroup-unreads))))
+	    (or (eq nunreads 0)
+		(gnus-message 6 "Marked %d articles as read" nunreads))
+	    nunreads)
+	0))))
+
+;; Parse a Gnus killfile.
+(defun gnus-score-insert-help (string alist idx)
+  (save-excursion
+    (pop-to-buffer "*Score Help*")
+    (buffer-disable-undo (current-buffer))
+    (erase-buffer)
+    (insert string ":\n\n")
+    (while alist
+      (insert (format " %c: %s\n" (caar alist) (nth idx (car alist))))
+      (setq alist (cdr alist)))))
+
+(defun gnus-kill-parse-gnus-kill-file ()
+  (goto-char (point-min))
+  (gnus-kill-file-mode)
+  (let (beg form)
+    (while (progn
+	     (setq beg (point))
+	     (setq form (ignore-errors (read (current-buffer)))))
+      (unless (listp form)
+	(error "Illegal kill entry (possibly rn kill file?): %s" form))
+      (if (or (eq (car form) 'gnus-kill)
+	      (eq (car form) 'gnus-raise)
+	      (eq (car form) 'gnus-lower))
+	  (progn
+	    (delete-region beg (point))
+	    (insert (or (eval form) "")))
+	(save-excursion
+	  (set-buffer gnus-summary-buffer)
+	  (ignore-errors (eval form)))))
+    (and (buffer-modified-p)
+	 gnus-kill-save-kill-file
+	 (save-buffer))
+    (set-buffer-modified-p nil)))
+
+;; Parse an rn killfile.
+(defun gnus-kill-parse-rn-kill-file ()
+  (goto-char (point-min))
+  (gnus-kill-file-mode)
+  (let ((mod-to-header
+	 '((?a . "")
+	   (?h . "")
+	   (?f . "from")
+	   (?: . "subject")))
+	(com-to-com
+	 '((?m . " ")
+	   (?j . "X")))
+	pattern modifier commands)
+    (while (not (eobp))
+      (if (not (looking-at "[ \t]*/\\([^/]*\\)/\\([ahfcH]\\)?:\\([a-z=:]*\\)"))
+	  ()
+	(setq pattern (buffer-substring (match-beginning 1) (match-end 1)))
+	(setq modifier (if (match-beginning 2) (char-after (match-beginning 2))
+			 ?s))
+	(setq commands (buffer-substring (match-beginning 3) (match-end 3)))
+
+	;; The "f:+" command marks everything *but* the matches as read,
+	;; so we simply first match everything as read, and then unmark
+	;; PATTERN later.
+	(when (string-match "\\+" commands)
+	  (gnus-kill "from" ".")
+	  (setq commands "m"))
+
+	(gnus-kill
+	 (or (cdr (assq modifier mod-to-header)) "subject")
+	 pattern
+	 (if (string-match "m" commands)
+	     '(gnus-summary-mark-as-unread nil " ")
+	   '(gnus-summary-mark-as-read nil "X"))
+	 nil t))
+      (forward-line 1))))
+
+;; Kill changes and new format by suggested by JWZ and Sudish Joseph
+;; <joseph@cis.ohio-state.edu>.
+(defun gnus-kill (field regexp &optional exe-command all silent)
+  "If FIELD of an article matches REGEXP, execute COMMAND.
+Optional 1st argument COMMAND is default to
+	(gnus-summary-mark-as-read nil \"X\").
+If optional 2nd argument ALL is non-nil, articles marked are also applied to.
+If FIELD is an empty string (or nil), entire article body is searched for.
+COMMAND must be a lisp expression or a string representing a key sequence."
+  ;; We don't want to change current point nor window configuration.
+  (let ((old-buffer (current-buffer)))
+    (save-excursion
+      (save-window-excursion
+	;; Selected window must be summary buffer to execute keyboard
+	;; macros correctly.  See command_loop_1.
+	(switch-to-buffer gnus-summary-buffer 'norecord)
+	(goto-char (point-min))		;From the beginning.
+	(let ((kill-list regexp)
+	      (date (current-time-string))
+	      (command (or exe-command '(gnus-summary-mark-as-read
+					 nil gnus-kill-file-mark)))
+	      kill kdate prev)
+	  (if (listp kill-list)
+	      ;; It is a list.
+	      (if (not (consp (cdr kill-list)))
+		  ;; It's on the form (regexp . date).
+		  (if (zerop (gnus-execute field (car kill-list)
+					   command nil (not all)))
+		      (when (> (gnus-days-between date (cdr kill-list))
+			       gnus-kill-expiry-days)
+			(setq regexp nil))
+		    (setcdr kill-list date))
+		(while (setq kill (car kill-list))
+		  (if (consp kill)
+		      ;; It's a temporary kill.
+		      (progn
+			(setq kdate (cdr kill))
+			(if (zerop (gnus-execute
+				    field (car kill) command nil (not all)))
+			    (when (> (gnus-days-between date kdate)
+				     gnus-kill-expiry-days)
+			      ;; Time limit has been exceeded, so we
+			      ;; remove the match.
+			      (if prev
+				  (setcdr prev (cdr kill-list))
+				(setq regexp (cdr regexp))))
+			  ;; Successful kill.  Set the date to today.
+			  (setcdr kill date)))
+		    ;; It's a permanent kill.
+		    (gnus-execute field kill command nil (not all)))
+		  (setq prev kill-list)
+		  (setq kill-list (cdr kill-list))))
+	    (gnus-execute field kill-list command nil (not all))))))
+    (switch-to-buffer old-buffer)
+    (when (and (eq major-mode 'gnus-kill-file-mode) regexp (not silent))
+      (gnus-pp-gnus-kill
+       (nconc (list 'gnus-kill field
+		    (if (consp regexp) (list 'quote regexp) regexp))
+	      (when (or exe-command all)
+		(list (list 'quote exe-command)))
+	      (if all (list t) nil))))))
+
+(defun gnus-pp-gnus-kill (object)
+  (if (or (not (consp (nth 2 object)))
+	  (not (consp (cdr (nth 2 object))))
+	  (and (eq 'quote (car (nth 2 object)))
+	       (not (consp (cdadr (nth 2 object))))))
+      (concat "\n" (gnus-prin1-to-string object))
+    (save-excursion
+      (set-buffer (get-buffer-create "*Gnus PP*"))
+      (buffer-disable-undo (current-buffer))
+      (erase-buffer)
+      (insert (format "\n(%S %S\n  '(" (nth 0 object) (nth 1 object)))
+      (let ((klist (cadr (nth 2 object)))
+	    (first t))
+	(while klist
+	  (insert (if first (progn (setq first nil) "")  "\n    ")
+		  (gnus-prin1-to-string (car klist)))
+	  (setq klist (cdr klist))))
+      (insert ")")
+      (and (nth 3 object)
+	   (insert "\n  "
+		   (if (and (consp (nth 3 object))
+			    (not (eq 'quote (car (nth 3 object)))))
+		       "'" "")
+		   (gnus-prin1-to-string (nth 3 object))))
+      (when (nth 4 object)
+	(insert "\n  t"))
+      (insert ")")
+      (prog1
+	  (buffer-substring (point-min) (point-max))
+	(kill-buffer (current-buffer))))))
+
+(defun gnus-execute-1 (function regexp form header)
+  (save-excursion
+    (let (did-kill)
+      (if (null header)
+	  nil				;Nothing to do.
+	(if function
+	    ;; Compare with header field.
+	    (let (value)
+	      (and header
+		   (progn
+		     (setq value (funcall function header))
+		     ;; Number (Lines:) or symbol must be converted to string.
+		     (unless (stringp value)
+		       (setq value (gnus-prin1-to-string value)))
+		     (setq did-kill (string-match regexp value)))
+		   (cond ((stringp form) ;Keyboard macro.
+			  (execute-kbd-macro form))
+			 ((gnus-functionp form)
+			  (funcall form))
+			 (t
+			  (eval form)))))
+	  ;; Search article body.
+	  (let ((gnus-current-article nil) ;Save article pointer.
+		(gnus-last-article nil)
+		(gnus-break-pages nil)	;No need to break pages.
+		(gnus-mark-article-hook nil)) ;Inhibit marking as read.
+	    (gnus-message
+	     6 "Searching for article: %d..." (mail-header-number header))
+	    (gnus-article-setup-buffer)
+	    (gnus-article-prepare (mail-header-number header) t)
+	    (when (save-excursion
+		    (set-buffer gnus-article-buffer)
+		    (goto-char (point-min))
+		    (setq did-kill (re-search-forward regexp nil t)))
+	      (cond ((stringp form)	;Keyboard macro.
+		     (execute-kbd-macro form))
+		    ((gnus-functionp form)
+		     (funcall form))
+		    (t
+		     (eval form)))))))
+      did-kill)))
+
+(defun gnus-execute (field regexp form &optional backward unread)
+  "If FIELD of article header matches REGEXP, execute lisp FORM (or a string).
+If FIELD is an empty string (or nil), entire article body is searched for.
+If optional 1st argument BACKWARD is non-nil, do backward instead.
+If optional 2nd argument UNREAD is non-nil, articles which are
+marked as read or ticked are ignored."
+  (save-excursion
+    (let ((killed-no 0)
+	  function article header)
+      (cond
+       ;; Search body.
+       ((or (null field)
+	    (string-equal field ""))
+	(setq function nil))
+       ;; Get access function of header field.
+       ((fboundp
+	 (setq function
+	       (intern-soft
+		(concat "mail-header-" (downcase field)))))
+	(setq function `(lambda (h) (,function h))))
+       ;; Signal error.
+       (t
+	(error "Unknown header field: \"%s\"" field)))
+      ;; Starting from the current article.
+      (while (or
+	      ;; First article.
+	      (and (not article)
+		   (setq article (gnus-summary-article-number)))
+	      ;; Find later articles.
+	      (setq article
+		    (gnus-summary-search-forward unread nil backward)))
+	(and (or (null gnus-newsgroup-kill-headers)
+		 (memq article gnus-newsgroup-kill-headers))
+	     (vectorp (setq header (gnus-summary-article-header article)))
+	     (gnus-execute-1 function regexp form header)
+	     (setq killed-no (1+ killed-no))))
+      ;; Return the number of killed articles.
+      killed-no)))
+
+;;;###autoload
+(defalias 'gnus-batch-kill 'gnus-batch-score)
+;;;###autoload
+(defun gnus-batch-score ()
+  "Run batched scoring.
+Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ...
+Newsgroups is a list of strings in Bnews format.  If you want to score
+the comp hierarchy, you'd say \"comp.all\".  If you would not like to
+score the alt hierarchy, you'd say \"!alt.all\"."
+  (interactive)
+  (let* ((gnus-newsrc-options-n
+	  (gnus-newsrc-parse-options
+	   (concat "options -n "
+		   (mapconcat 'identity command-line-args-left " "))))
+	 (gnus-expert-user t)
+	 (nnmail-spool-file nil)
+	 (gnus-use-dribble-file nil)
+	 (gnus-batch-mode t)
+	 group newsrc entry
+	 ;; Disable verbose message.
+	 gnus-novice-user gnus-large-newsgroup
+	 gnus-options-subscribe gnus-auto-subscribed-groups
+	 gnus-options-not-subscribe)
+    ;; Eat all arguments.
+    (setq command-line-args-left nil)
+    (gnus-slave)
+    ;; Apply kills to specified newsgroups in command line arguments.
+    (setq newsrc (cdr gnus-newsrc-alist))
+    (while (setq group (car (pop newsrc)))
+      (setq entry (gnus-gethash group gnus-newsrc-hashtb))
+      (when (and (<= (gnus-info-level (car newsrc)) gnus-level-subscribed)
+		 (and (car entry)
+		      (or (eq (car entry) t)
+			  (not (zerop (car entry)))))
+		 ;;(eq (gnus-matches-options-n group) 'subscribe)
+		 )
+	(gnus-summary-read-group group nil t nil t)
+	(when (eq (current-buffer) (get-buffer gnus-summary-buffer))
+	  (gnus-summary-exit))))
+    ;; Exit Emacs.
+    (switch-to-buffer gnus-group-buffer)
+    (gnus-group-save-newsrc)))
+
+(provide 'gnus-kill)
+
+;;; gnus-kill.el ends here

lisp/gnus/gnus-load.el

@@ -0,0 +1,103 @@
+;;; gnus-load.el --- automatically extracted custom dependencies
+;;
+;;; Code:
+
+(put 'nnmail 'custom-loads '("nnmail"))
+(put 'gnus-article-emphasis 'custom-loads '("gnus-art"))
+(put 'gnus-article-headers 'custom-loads '("gnus-sum" "gnus-art"))
+(put 'nnmail-procmail 'custom-loads '("nnmail"))
+(put 'gnus-score-kill 'custom-loads '("gnus-kill"))
+(put 'gnus-visual 'custom-loads '("smiley" "gnus" "gnus-picon" "gnus-art" "earcon"))
+(put 'gnus-score-expire 'custom-loads '("gnus-score" "gnus-kill"))
+(put 'gnus-summary-maneuvering 'custom-loads '("gnus-sum"))
+(put 'gnus-start 'custom-loads '("gnus" "gnus-util" "gnus-start" "gnus-int" "gnus-group"))
+(put 'gnus-extract-view 'custom-loads '("gnus-uu" "gnus-sum"))
+(put 'gnus-various 'custom-loads '("gnus-sum"))
+(put 'gnus-article-washing 'custom-loads '("gnus-art"))
+(put 'gnus-score-files 'custom-loads '("gnus-score"))
+(put 'message-news 'custom-loads '("message"))
+(put 'gnus-thread 'custom-loads '("gnus-sum"))
+(put 'languages 'custom-loads '("cus-edit"))
+(put 'development 'custom-loads '("cus-edit"))
+(put 'gnus-treading 'custom-loads '("gnus-sum"))
+(put 'nnmail-various 'custom-loads '("nnmail"))
+(put 'extensions 'custom-loads '("wid-edit"))
+(put 'message-various 'custom-loads '("message"))
+(put 'gnus-summary-exit 'custom-loads '("gnus-sum"))
+(put 'news 'custom-loads '("message" "gnus"))
+(put 'gnus 'custom-loads '("nnmail" "gnus" "gnus-win" "gnus-uu" "gnus-eform" "gnus-dup" "gnus-demon" "gnus-cache" "gnus-async" "gnus-art"))
+(put 'gnus-summary-visual 'custom-loads '("gnus-sum"))
+(put 'gnus-group-listing 'custom-loads '("gnus-group"))
+(put 'gnus-score 'custom-loads '("gnus" "gnus-nocem"))
+(put 'gnus-group-select 'custom-loads '("gnus-sum"))
+(put 'message-buffers 'custom-loads '("message"))
+(put 'gnus-threading 'custom-loads '("gnus-sum"))
+(put 'gnus-score-decay 'custom-loads '("gnus-score"))
+(put 'help 'custom-loads '("cus-edit"))
+(put 'gnus-nocem 'custom-loads '("gnus-nocem"))
+(put 'gnus-cite 'custom-loads '("gnus-cite"))
+(put 'gnus-demon 'custom-loads '("gnus-demon"))
+(put 'gnus-message 'custom-loads '("message"))
+(put 'gnus-score-default 'custom-loads '("gnus-sum" "gnus-score"))
+(put 'nnmail-duplicate 'custom-loads '("nnmail"))
+(put 'message-interface 'custom-loads '("message"))
+(put 'nnmail-files 'custom-loads '("nnmail"))
+(put 'gnus-edit-form 'custom-loads '("gnus-eform"))
+(put 'emacs 'custom-loads '("cus-edit"))
+(put 'gnus-summary-mail 'custom-loads '("gnus-sum"))
+(put 'gnus-topic 'custom-loads '("gnus-topic"))
+(put 'wp 'custom-loads '("cus-edit"))
+(put 'gnus-summary-choose 'custom-loads '("gnus-sum"))
+(put 'widget-browse 'custom-loads '("wid-browse"))
+(put 'external 'custom-loads '("cus-edit"))
+(put 'message-headers 'custom-loads '("message"))
+(put 'message-forwarding 'custom-loads '("message"))
+(put 'message-faces 'custom-loads '("message"))
+(put 'environment 'custom-loads '("cus-edit"))
+(put 'gnus-article-mime 'custom-loads '("gnus-sum" "gnus-art"))
+(put 'gnus-duplicate 'custom-loads '("gnus-dup"))
+(put 'nnmail-retrieve 'custom-loads '("nnmail"))
+(put 'widgets 'custom-loads '("wid-edit" "wid-browse"))
+(put 'earcon 'custom-loads '("earcon"))
+(put 'hypermedia 'custom-loads '("wid-edit"))
+(put 'gnus-group-levels 'custom-loads '("gnus-group"))
+(put 'gnus-summary-format 'custom-loads '("gnus-sum"))
+(put 'gnus-files 'custom-loads '("nnmail" "gnus"))
+(put 'gnus-windows 'custom-loads '("gnus-win"))
+(put 'gnus-article-buttons 'custom-loads '("gnus-art"))
+(put 'gnus-summary 'custom-loads '("gnus" "gnus-sum"))
+(put 'gnus-article-hiding 'custom-loads '("gnus-sum" "gnus-art"))
+(put 'gnus-group 'custom-loads '("gnus" "gnus-topic"))
+(put 'gnus-article-various 'custom-loads '("gnus-sum" "gnus-art"))
+(put 'gnus-summary-marks 'custom-loads '("gnus-sum"))
+(put 'gnus-article-saving 'custom-loads '("gnus-art"))
+(put 'nnmail-expire 'custom-loads '("nnmail"))
+(put 'message-mail 'custom-loads '("message"))
+(put 'faces 'custom-loads '("wid-edit" "cus-edit" "message" "gnus"))
+(put 'gnus-summary-various 'custom-loads '("gnus-sum"))
+(put 'applications 'custom-loads '("cus-edit"))
+(put 'gnus-extract-archive 'custom-loads '("gnus-uu"))
+(put 'message 'custom-loads '("message"))
+(put 'message-sending 'custom-loads '("message"))
+(put 'editing 'custom-loads '("cus-edit"))
+(put 'gnus-score-adapt 'custom-loads '("gnus-score"))
+(put 'message-insertion 'custom-loads '("message"))
+(put 'gnus-extract-post 'custom-loads '("gnus-uu"))
+(put 'mail 'custom-loads '("message" "gnus"))
+(put 'gnus-summary-sort 'custom-loads '("gnus-sum"))
+(put 'customize 'custom-loads '("wid-edit" "custom" "cus-face" "cus-edit"))
+(put 'nnmail-split 'custom-loads '("nnmail"))
+(put 'gnus-asynchronous 'custom-loads '("gnus-async"))
+(put 'gnus-article-highlight 'custom-loads '("gnus-art"))
+(put 'gnus-extract 'custom-loads '("gnus-uu"))
+(put 'gnus-article 'custom-loads '("gnus-cite" "gnus-art"))
+(put 'gnus-group-foreign 'custom-loads '("gnus-group"))
+(put 'programming 'custom-loads '("cus-edit"))
+(put 'nnmail-prepare 'custom-loads '("nnmail"))
+(put 'picons 'custom-loads '("gnus-picon"))
+(put 'gnus-article-signature 'custom-loads '("gnus-art"))
+(put 'gnus-group-various 'custom-loads '("gnus-group"))
+
+(provide 'gnus-load)
+
+;;; gnus-load.el ends here

lisp/gnus/gnus-logic.el

@@ -0,0 +1,227 @@
+;;; gnus-logic.el --- advanced scoring code for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-score)
+(require 'gnus-util)
+
+;;; Internal variables.
+
+(defvar gnus-advanced-headers nil)
+
+;; To avoid having 8-bit characters in the source file.
+(defvar gnus-advanced-not (intern (format "%c" 172)))
+
+(defconst gnus-advanced-index
+  ;; Name to index alist.
+  '(("number" 0 gnus-advanced-integer)
+    ("subject" 1 gnus-advanced-string)
+    ("from" 2 gnus-advanced-string)
+    ("date" 3 gnus-advanced-date)
+    ("message-id" 4 gnus-advanced-string)
+    ("references" 5 gnus-advanced-string)
+    ("chars" 6 gnus-advanced-integer)
+    ("lines" 7 gnus-advanced-integer)
+    ("xref" 8 gnus-advanced-string)
+    ("head" nil gnus-advanced-body)
+    ("body" nil gnus-advanced-body)
+    ("all" nil gnus-advanced-body)))
+
+(eval-and-compile
+  (autoload 'parse-time-string "parse-time"))
+
+(defun gnus-score-advanced (rule &optional trace)
+  "Apply advanced scoring RULE to all the articles in the current group."
+  (let ((headers gnus-newsgroup-headers)
+	gnus-advanced-headers score)
+    (while (setq gnus-advanced-headers (pop headers))
+      (when (gnus-advanced-score-rule (car rule))
+	;; This rule was successful, so we add the score to
+	;; this article.
+	(if (setq score (assq (mail-header-number gnus-advanced-headers)
+			      gnus-newsgroup-scored))
+	    (setcdr score
+		    (+ (cdr score)
+		       (or (nth 1 rule)
+			   gnus-score-interactive-default-score)))
+	  (push (cons (mail-header-number gnus-advanced-headers)
+		      (or (nth 1 rule)
+			  gnus-score-interactive-default-score))
+		gnus-newsgroup-scored)
+	  (when trace
+	    (push (cons "A file" rule)
+		  gnus-score-trace)))))))
+
+(defun gnus-advanced-score-rule (rule)
+  "Apply RULE to `gnus-advanced-headers'."
+  (let ((type (car rule)))
+    (cond
+     ;; "And" rule.
+     ((or (eq type '&) (eq type 'and))
+      (pop rule)
+      (if (not rule)
+	  t				; Empty rule is true.
+	(while (and rule
+		    (gnus-advanced-score-rule (car rule)))
+	  (pop rule))
+	;; If all the rules were true, then `rule' should be nil.
+	(not rule)))
+     ;; "Or" rule.
+     ((or (eq type '|) (eq type 'or))
+      (pop rule)
+      (if (not rule)
+	  nil
+	(while (and rule
+		    (not (gnus-advanced-score-rule (car rule))))
+	  (pop rule))
+	;; If one of the rules returned true, then `rule' should be non-nil.
+	rule))
+     ;; "Not" rule.
+     ((or (eq type '!) (eq type 'not) (eq type gnus-advanced-not))
+      (not (gnus-advanced-score-rule (nth 1 rule))))
+     ;; This is a `1-'-type redirection rule.
+     ((and (symbolp type)
+	   (string-match "^[0-9]+-$\\|^\\^+$" (symbol-name type)))
+      (let ((gnus-advanced-headers
+	     (gnus-parent-headers
+	      gnus-advanced-headers
+	      (if (string-match "^\\([0-9]+\\)-$" (symbol-name type))
+		  ;; 1- type redirection.
+		  (string-to-number
+		   (substring (symbol-name type)
+			      (match-beginning 0) (match-end 0)))
+		;; ^^^ type redirection.
+		(length (symbol-name type))))))
+	(when gnus-advanced-headers
+	  (gnus-advanced-score-rule (nth 1 rule)))))
+     ;; Plain scoring rule.
+     ((stringp type)
+      (gnus-advanced-score-article rule))
+     ;; Bug-out time!
+     (t
+      (error "Unknown advanced score type: %s" rule)))))
+
+(defun gnus-advanced-score-article (rule)
+  ;; `rule' is a semi-normal score rule, so we find out
+  ;; what function that's supposed to do the actual
+  ;; processing.
+  (let* ((header (car rule))
+	 (func (assoc (downcase header) gnus-advanced-index)))
+    (if (not func)
+	(error "No such header: %s" rule)
+      ;; Call the score function.
+      (funcall (caddr func) (or (cadr func) header)
+	       (cadr rule) (caddr rule)))))
+
+(defun gnus-advanced-string (index match type)
+  "See whether string MATCH of TYPE matches `gnus-advanced-headers' in INDEX."
+  (let* ((type (or type 's))
+	 (case-fold-search (not (eq (downcase (symbol-name type))
+				    (symbol-name type))))
+	 (header (aref gnus-advanced-headers index)))
+    (cond
+     ((memq type '(r R regexp Regexp))
+      (string-match match header))
+     ((memq type '(s S string String))
+      (string-match (regexp-quote match) header))
+     ((memq type '(e E exact Exact))
+      (string= match header))
+     ((memq type '(f F fuzzy Fuzzy))
+      (string-match (regexp-quote (gnus-simplify-subject-fuzzy match))
+		    header))
+     (t
+      (error "No such string match type: %s" type)))))
+
+(defun gnus-advanced-integer (index match type)
+  (if (not (memq type '(< > <= >= =)))
+      (error "No such integer score type: %s" type)
+    (funcall type match (or (aref gnus-advanced-headers index) 0))))
+
+(defun gnus-advanced-date (index match type)
+  (let ((date (encode-time (parse-time-string
+			    (aref gnus-advanced-headers index))))
+	(match (encode-time (parse-time-string match))))
+    (cond
+     ((eq type 'at)
+      (equal date match))
+     ((eq type 'before)
+      (gnus-time-less match date))
+     ((eq type 'after)
+      (gnus-time-less date match))
+     (t
+      (error "No such date score type: %s" type)))))
+
+(defun gnus-advanced-body (header match type)
+  (when (string= header "all")
+    (setq header "article"))
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (let* ((request-func (cond ((string= "head" header)
+				'gnus-request-head)
+			       ((string= "body" header)
+				'gnus-request-body)
+			       (t 'gnus-request-article)))
+	   ofunc article)
+      ;; Not all backends support partial fetching.  In that case,
+      ;; we just fetch the entire article.
+      (unless (gnus-check-backend-function
+	       (intern (concat "request-" header))
+	       gnus-newsgroup-name)
+	(setq ofunc request-func)
+	(setq request-func 'gnus-request-article))
+      (setq article (mail-header-number gnus-advanced-headers))
+      (gnus-message 7 "Scoring article %s..." article)
+      (when (funcall request-func article gnus-newsgroup-name)
+	(goto-char (point-min))
+	;; If just parts of the article is to be searched and the
+	;; backend didn't support partial fetching, we just narrow
+	;; to the relevant parts.
+	(when ofunc
+	  (if (eq ofunc 'gnus-request-head)
+	      (narrow-to-region
+	       (point)
+	       (or (search-forward "\n\n" nil t) (point-max)))
+	    (narrow-to-region
+	     (or (search-forward "\n\n" nil t) (point))
+	     (point-max))))
+	(let* ((case-fold-search (not (eq (downcase (symbol-name type))
+					  (symbol-name type))))
+	       (search-func
+		(cond ((memq type '(r R regexp Regexp))
+		       're-search-forward)
+		      ((memq type '(s S string String))
+		       'search-forward)
+		      (t
+		       (error "Illegal match type: %s" type)))))
+	  (goto-char (point-min))
+	  (prog1
+	      (funcall search-func match nil t)
+	    (widen)))))))
+
+(provide 'gnus-logic)
+
+;;; gnus-logic.el ends here.

lisp/gnus/gnus-mh.el

@@ -0,0 +1,105 @@
+;;; gnus-mh.el --- mh-e interface for Gnus
+;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc.
+
+;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;;	Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Send mail using mh-e.
+
+;; The following mh-e interface is all cooperative works of
+;; tanaka@flab.fujitsu.CO.JP (TANAKA Hiroshi), kawabe@sra.CO.JP
+;; (Yoshikatsu Kawabe), and shingu@casund.cpr.canon.co.jp (Toshiaki
+;; SHINGU).
+
+;;; Code:
+
+(require 'gnus)
+(require 'mh-e)
+(require 'mh-comp)
+(require 'gnus-msg)
+(require 'gnus-sum)
+
+(defun gnus-summary-save-article-folder (&optional arg)
+  "Append the current article to an mh folder.
+If N is a positive number, save the N next articles.
+If N is a negative number, save the N previous articles.
+If N is nil and any articles have been marked with the process mark,
+save those articles instead."
+  (interactive "P")
+  (let ((gnus-default-article-saver 'gnus-summary-save-in-folder))
+    (gnus-summary-save-article arg)))
+
+(defun gnus-summary-save-in-folder (&optional folder)
+  "Save this article to MH folder (using `rcvstore' in MH library).
+Optional argument FOLDER specifies folder name."
+  ;; Thanks to yuki@flab.Fujitsu.JUNET and ohm@kaba.junet.
+  (mh-find-path)
+  (let ((folder
+	 (cond ((and (eq folder 'default)
+		     gnus-newsgroup-last-folder)
+		gnus-newsgroup-last-folder)
+	       (folder folder)
+	       (t (mh-prompt-for-folder
+		   "Save article in"
+		   (funcall gnus-folder-save-name gnus-newsgroup-name
+			    gnus-current-headers gnus-newsgroup-last-folder)
+		   t))))
+	(errbuf (get-buffer-create " *Gnus rcvstore*"))
+	;; Find the rcvstore program.
+	(exec-path (if mh-lib (cons mh-lib exec-path) exec-path)))
+    (gnus-eval-in-buffer-window gnus-original-article-buffer
+      (save-restriction
+	(widen)
+	(unwind-protect
+	    (call-process-region
+	     (point-min) (point-max) "rcvstore" nil errbuf nil folder)
+	  (set-buffer errbuf)
+	  (if (zerop (buffer-size))
+	      (message "Article saved in folder: %s" folder)
+	    (message "%s" (buffer-string)))
+	  (kill-buffer errbuf))))
+    (setq gnus-newsgroup-last-folder folder)))
+
+(defun gnus-Folder-save-name (newsgroup headers &optional last-folder)
+  "Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER.
+If variable `gnus-use-long-file-name' is nil, it is +News.group.
+Otherwise, it is like +news/group."
+  (or last-folder
+      (concat "+"
+	      (if gnus-use-long-file-name
+		  (gnus-capitalize-newsgroup newsgroup)
+		(gnus-newsgroup-directory-form newsgroup)))))
+
+(defun gnus-folder-save-name (newsgroup headers &optional last-folder)
+  "Generate folder name from NEWSGROUP, HEADERS, and optional LAST-FOLDER.
+If variable `gnus-use-long-file-name' is nil, it is +news.group.
+Otherwise, it is like +news/group."
+  (or last-folder
+      (concat "+"
+	      (if gnus-use-long-file-name
+		  newsgroup
+		(gnus-newsgroup-directory-form newsgroup)))))
+
+(provide 'gnus-mh)
+
+;;; gnus-mh.el ends here

lisp/gnus/gnus-move.el

@@ -0,0 +1,172 @@
+;;; gnus-move.el --- commands for moving Gnus from one server to another
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-start)
+(require 'gnus-int)
+(require 'gnus-range)
+
+;;;
+;;; Moving by comparing Message-ID's.
+;;;
+
+;;;###autoload
+(defun gnus-change-server (from-server to-server)
+  "Move from FROM-SERVER to TO-SERVER.
+Update the .newsrc.eld file to reflect the change of nntp server."
+  (interactive
+   (list gnus-select-method (gnus-read-method "Move to method: ")))
+
+  ;; First start Gnus.
+  (let ((gnus-activate-level 0)
+	(nnmail-spool-file nil))
+    (gnus))
+
+  (save-excursion
+    ;; Go through all groups and translate.
+    (let ((newsrc gnus-newsrc-alist)
+	  (nntp-nov-gap nil)
+	  info)
+      (while (setq info (pop newsrc))
+	(when (gnus-group-native-p (gnus-info-group info))
+	  (gnus-move-group-to-server info from-server to-server))))))
+
+(defun gnus-move-group-to-server (info from-server to-server)
+  "Move group INFO from FROM-SERVER to TO-SERVER."
+  (let ((group (gnus-info-group info))
+	to-active hashtb type mark marks
+	to-article to-reads to-marks article)
+    (gnus-message 7 "Translating %s..." group)
+    (when (gnus-request-group group nil to-server)
+      (setq to-active (gnus-parse-active)
+	    hashtb (gnus-make-hashtable 1024))
+      ;; Fetch the headers from the `to-server'.
+      (when (and to-active
+		 (setq type (gnus-retrieve-headers
+			     (gnus-uncompress-range to-active)
+			     group to-server)))
+	;; Convert HEAD headers.  I don't care.
+	(when (eq type 'headers)
+	  (nnvirtual-convert-headers))
+	;; Create a mapping from Message-ID to article number.
+	(set-buffer nntp-server-buffer)
+	(goto-char (point-min))
+	(while (looking-at
+		"^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t")
+	  (gnus-sethash
+	   (buffer-substring (match-beginning 1) (match-end 1))
+	   (read (current-buffer))
+	   hashtb)
+	  (forward-line 1))
+	;; Then we read the headers from the `from-server'.
+	(when (and (gnus-request-group group nil from-server)
+		   (gnus-active group)
+		   (setq type (gnus-retrieve-headers
+			       (gnus-uncompress-range
+				(gnus-active group))
+			       group from-server)))
+	  ;; Make it easier to map marks.
+	  (let ((mark-lists (gnus-info-marks info))
+		ms type m)
+	    (while mark-lists
+	      (setq type (caar mark-lists)
+		    ms (gnus-uncompress-range (cdr (pop mark-lists))))
+	      (while ms
+		(if (setq m (assq (car ms) marks))
+		    (setcdr m (cons type (cdr m)))
+		  (push (list (car ms) type) marks))
+		(pop ms))))
+	  ;; Convert.
+	  (when (eq type 'headers)
+	    (nnvirtual-convert-headers))
+	  ;; Go through the headers and map away.
+	  (set-buffer nntp-server-buffer)
+	  (goto-char (point-min))
+	  (while (looking-at
+		  "^[0-9]+\t[^\t]*\t[^\t]*\t[^\t]*\t\\([^\t]*\\)\t")
+	    (setq to-article
+		  (gnus-gethash
+		   (buffer-substring (match-beginning 1) (match-end 1))
+		   hashtb))
+	    ;; Add this article to the list of read articles.
+	    (push to-article to-reads)
+	    ;; See if there are any marks and then add them.
+	    (when (setq mark (assq (read (current-buffer)) marks))
+	      (setq marks (delq mark marks))
+	      (setcar mark to-article)
+	      (push mark to-marks))
+	    (forward-line 1))
+	  ;; Now we know what the read articles are and what the
+	  ;; article marks are.  We transform the information
+	  ;; into the Gnus info format.
+	  (setq to-reads
+		(gnus-range-add
+		 (gnus-compress-sequence (sort to-reads '<) t)
+		 (cons 1 (1- (car to-active)))))
+	  (gnus-info-set-read info to-reads)
+	  ;; Do the marks.  I'm sure y'all understand what's
+	  ;; going on down below, so I won't bother with any
+	  ;; further comments.  <duck>
+	  (let ((mlists gnus-article-mark-lists)
+		lists ms a)
+	    (while mlists
+	      (push (list (cdr (pop mlists))) lists))
+	    (while (setq ms (pop marks))
+	      (setq article (pop ms))
+	      (while ms
+		(setcdr (setq a (assq (pop ms) lists))
+			(cons article (cdr a)))))
+	    (setq a lists)
+	    (while a
+	      (setcdr (car a) (gnus-compress-sequence (sort (cdar a) '<)))
+	      (pop a))
+	    (gnus-info-set-marks info lists t)))))
+    (gnus-message 7 "Translating %s...done" group)))
+
+(defun gnus-group-move-group-to-server (info from-server to-server)
+  "Move the group on the current line from FROM-SERVER to TO-SERVER."
+  (interactive
+   (let ((info (gnus-get-info (gnus-group-group-name))))
+     (list info (gnus-find-method-for-group (gnus-info-group info))
+	   (gnus-read-method (format "Move group %s to method: "
+				     (gnus-info-group info))))))
+  (save-excursion
+    (gnus-move-group-to-server info from-server to-server)
+    ;; We have to update the group info to point use the right server.
+    (gnus-info-set-method info to-server t)
+    ;; We also have to change the name of the group and stuff.
+    (let* ((group (gnus-info-group info))
+	   (new-name (gnus-group-prefixed-name
+		      (gnus-group-real-name group) to-server)))
+      (gnus-info-set-group info new-name)
+      (gnus-sethash new-name (gnus-gethash group gnus-newsrc-hashtb)
+		    gnus-newsrc-hashtb)
+      (gnus-sethash group nil gnus-newsrc-hashtb))))
+
+(provide 'gnus-move)
+
+;;; gnus-move.el ends here

lisp/gnus/gnus-nocem.el

@@ -0,0 +1,303 @@
+;;; gnus-nocem.el --- NoCeM pseudo-cancellation treatment
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'nnmail)
+(require 'gnus-art)
+(require 'gnus-sum)
+(require 'gnus-range)
+
+(defgroup gnus-nocem nil
+  "NoCeM pseudo-cancellation treatment"
+  :group 'gnus-score)
+
+(defcustom gnus-nocem-groups
+  '("news.lists.filters" "news.admin.net-abuse.bulletins"
+    "alt.nocem.misc" "news.admin.net-abuse.announce")
+  "List of groups that will be searched for NoCeM messages."
+  :group 'gnus-nocem
+  :type '(repeat (string :tag "Group")))
+
+(defcustom gnus-nocem-issuers
+ '("AutoMoose-1" "Automoose-1"   ; CancelMoose[tm]
+   "rbraver@ohww.norman.ok.us"   ; Robert Braver
+   "clewis@ferret.ocunix.on.ca;" ; Chris Lewis
+   "jem@xpat.com;"		 ; Despammer from Korea
+   "snowhare@xmission.com"       ; Benjamin "Snowhare" Franz
+   "red@redpoll.mrfs.oh.us (Richard E. Depew)" ; ARMM! ARMM!
+   )
+  "List of NoCeM issuers to pay attention to."
+  :group 'gnus-nocem
+  :type '(repeat string))
+
+(defcustom gnus-nocem-directory
+  (nnheader-concat gnus-article-save-directory "NoCeM/")
+  "*Directory where NoCeM files will be stored."
+  :group 'gnus-nocem
+  :type 'directory)
+
+(defcustom gnus-nocem-expiry-wait 15
+  "*Number of days to keep NoCeM headers in the cache."
+  :group 'gnus-nocem
+  :type 'integer)
+
+(defcustom gnus-nocem-verifyer 'mc-verify
+  "*Function called to verify that the NoCeM message is valid.
+One likely value is `mc-verify'.  If the function in this variable
+isn't bound, the message will be used unconditionally."
+  :group 'gnus-nocem
+  :type '(radio (function-item mc-verify)
+		(function :tag "other")))
+
+(defcustom gnus-nocem-liberal-fetch nil
+  "*If t try to fetch all messages which have @@NCM in the subject.
+Otherwise don't fetch messages which have references or whose message-id
+matches an previously scanned and verified nocem message."
+  :group 'gnus-nocem
+  :type 'boolean)
+
+;;; Internal variables
+
+(defvar gnus-nocem-active nil)
+(defvar gnus-nocem-alist nil)
+(defvar gnus-nocem-touched-alist nil)
+(defvar gnus-nocem-hashtb nil)
+(defvar gnus-nocem-seen-message-ids nil)
+
+;;; Functions
+
+(defun gnus-nocem-active-file ()
+  (concat (file-name-as-directory gnus-nocem-directory) "active"))
+
+(defun gnus-nocem-cache-file ()
+  (concat (file-name-as-directory gnus-nocem-directory) "cache"))
+
+(defun gnus-nocem-scan-groups ()
+  "Scan all NoCeM groups for new NoCeM messages."
+  (interactive)
+  (let ((groups gnus-nocem-groups)
+	(gnus-inhibit-demon t)
+	group active gactive articles)
+    (gnus-make-directory gnus-nocem-directory)
+    ;; Load any previous NoCeM headers.
+    (gnus-nocem-load-cache)
+    ;; Read the active file if it hasn't been read yet.
+    (and (file-exists-p (gnus-nocem-active-file))
+	 (not gnus-nocem-active)
+	 (ignore-errors
+	   (load (gnus-nocem-active-file) t t t)))
+    ;; Go through all groups and see whether new articles have
+    ;; arrived.
+    (while (setq group (pop groups))
+      (if (not (setq gactive (gnus-activate-group group)))
+	  ()				; This group doesn't exist.
+	(setq active (nth 1 (assoc group gnus-nocem-active)))
+	(when (and (not (< (cdr gactive) (car gactive))) ; Empty group.
+		   (or (not active)
+		       (< (cdr active) (cdr gactive))))
+	  ;; Ok, there are new articles in this group, se we fetch the
+	  ;; headers.
+	  (save-excursion
+	    (let ((dependencies (make-vector 10 nil))
+		  headers header)
+	      (nnheader-temp-write nil
+		(setq headers
+		      (if (eq 'nov
+			      (gnus-retrieve-headers
+			       (setq articles
+				     (gnus-uncompress-range
+				      (cons
+				       (if active (1+ (cdr active))
+					 (car gactive))
+				       (cdr gactive))))
+			       group))
+			  (gnus-get-newsgroup-headers-xover
+			   articles nil dependencies)
+			(gnus-get-newsgroup-headers dependencies)))
+		(while (setq header (pop headers))
+		  ;; We take a closer look on all articles that have
+		  ;; "@@NCM" in the subject.  Unless we already read
+		  ;; this cross posted message.  Nocem messages
+		  ;; are not allowed to have references, so we can
+		  ;; ignore scanning followups.
+		  (and (string-match "@@NCM" (mail-header-subject header))
+		       (or gnus-nocem-liberal-fetch
+			   (and (or (string= "" (mail-header-references
+						 header))
+				    (null (mail-header-references header)))
+				(not (member (mail-header-message-id header)
+					     gnus-nocem-seen-message-ids))))
+		       (gnus-nocem-check-article group header)))))))
+	(setq gnus-nocem-active
+	      (cons (list group gactive)
+		    (delq (assoc group gnus-nocem-active)
+			  gnus-nocem-active)))))
+    ;; Save the results, if any.
+    (gnus-nocem-save-cache)
+    (gnus-nocem-save-active)))
+
+(defun gnus-nocem-check-article (group header)
+  "Check whether the current article is an NCM article and that we want it."
+  ;; Get the article.
+  (gnus-message 7 "Checking article %d in %s for NoCeM..."
+		(mail-header-number header) group)
+  (let ((date (mail-header-date header))
+	issuer b e)
+    (when (or (not date)
+	      (nnmail-time-less
+	       (nnmail-time-since (nnmail-date-to-time date))
+	       (nnmail-days-to-time gnus-nocem-expiry-wait)))
+      (gnus-request-article-this-buffer (mail-header-number header) group)
+      (goto-char (point-min))
+      (when (re-search-forward "-----BEGIN PGP MESSAGE-----" nil t)
+	(delete-region (point-min) (match-beginning 0)))
+      (when (re-search-forward "-----END PGP MESSAGE-----\n?" nil t)
+	(delete-region (match-end 0) (point-max)))
+      (goto-char (point-min))
+      ;; The article has to have proper NoCeM headers.
+      (when (and (setq b (search-forward "\n@@BEGIN NCM HEADERS\n" nil t))
+		 (setq e (search-forward "\n@@BEGIN NCM BODY\n" nil t)))
+	;; We get the name of the issuer.
+	(narrow-to-region b e)
+	(setq issuer (mail-fetch-field "issuer"))
+	(widen)
+	(and (member issuer gnus-nocem-issuers) ; We like her....
+	     (gnus-nocem-verify-issuer issuer) ; She is who she says she is...
+	     (gnus-nocem-enter-article)	; We gobble the message..
+	     (push (mail-header-message-id header) ; But don't come back for
+		   gnus-nocem-seen-message-ids)))))) ; second helpings.
+
+(defun gnus-nocem-verify-issuer (person)
+  "Verify using PGP that the canceler is who she says she is."
+  (if (fboundp gnus-nocem-verifyer)
+      (funcall gnus-nocem-verifyer)
+    ;; If we don't have Mailcrypt, then we use the message anyway.
+    t))
+
+(defun gnus-nocem-enter-article ()
+  "Enter the current article into the NoCeM cache."
+  (goto-char (point-min))
+  (let ((b (search-forward "\n@@BEGIN NCM BODY\n" nil t))
+	(e (search-forward "\n@@END NCM BODY\n" nil t))
+	(buf (current-buffer))
+	ncm id group)
+    (when (and b e)
+      (narrow-to-region b (1+ (match-beginning 0)))
+      (goto-char (point-min))
+      (while (search-forward "\t" nil t)
+	(cond
+	 ((not (ignore-errors
+		 (setq group (let ((obarray gnus-active-hashtb)) (read buf)))))
+	  ;; An error.
+	  )
+	 ((not (symbolp group))
+	  ;; Ignore invalid entries.
+	  )
+	 ((not (boundp group))
+	  ;; Make sure all entries in the hashtb are bound.
+	  (set group nil))
+	 (t
+	  (when (gnus-gethash (symbol-name group) gnus-newsrc-hashtb)
+	    ;; Valid group.
+	    (beginning-of-line)
+	    (while (= (following-char) ?\t)
+	      (forward-line -1))
+	    (setq id (buffer-substring (point) (1- (search-forward "\t"))))
+	    (unless (gnus-gethash id gnus-nocem-hashtb)
+	      ;; only store if not already present
+	      (gnus-sethash id t gnus-nocem-hashtb)
+	      (push id ncm))
+	    (forward-line 1)
+	    (while (= (following-char) ?\t)
+	      (forward-line 1))))))
+      (when ncm
+	(setq gnus-nocem-touched-alist t)
+	(push (cons (let ((time (current-time))) (setcdr (cdr time) nil) time)
+		    ncm)
+	      gnus-nocem-alist))
+      t)))
+
+(defun gnus-nocem-load-cache ()
+  "Load the NoCeM cache."
+  (interactive)
+  (unless gnus-nocem-alist
+    ;; The buffer doesn't exist, so we create it and load the NoCeM
+    ;; cache.
+    (when (file-exists-p (gnus-nocem-cache-file))
+      (load (gnus-nocem-cache-file) t t t)
+      (gnus-nocem-alist-to-hashtb))))
+
+(defun gnus-nocem-save-cache ()
+  "Save the NoCeM cache."
+  (when (and gnus-nocem-alist
+	     gnus-nocem-touched-alist)
+    (nnheader-temp-write (gnus-nocem-cache-file)
+      (gnus-prin1 `(setq gnus-nocem-alist ',gnus-nocem-alist)))
+    (setq gnus-nocem-touched-alist nil)))
+
+(defun gnus-nocem-save-active ()
+  "Save the NoCeM active file."
+  (nnheader-temp-write (gnus-nocem-active-file)
+    (gnus-prin1 `(setq gnus-nocem-active ',gnus-nocem-active))))
+
+(defun gnus-nocem-alist-to-hashtb ()
+  "Create a hashtable from the Message-IDs we have."
+  (let* ((alist gnus-nocem-alist)
+	 (pprev (cons nil alist))
+	 (prev pprev)
+	 (expiry (nnmail-days-to-time gnus-nocem-expiry-wait))
+	 entry)
+    (setq gnus-nocem-hashtb (gnus-make-hashtable (* (length alist) 51)))
+    (while (setq entry (car alist))
+      (if (not (nnmail-time-less (nnmail-time-since (car entry)) expiry))
+	  ;; This entry has expired, so we remove it.
+	  (setcdr prev (cdr alist))
+	(setq prev alist)
+	;; This is ok, so we enter it into the hashtable.
+	(setq entry (cdr entry))
+	(while entry
+	  (gnus-sethash (car entry) t gnus-nocem-hashtb)
+	  (setq entry (cdr entry))))
+      (setq alist (cdr alist)))))
+
+(gnus-add-shutdown 'gnus-nocem-close 'gnus)
+
+(defun gnus-nocem-close ()
+  "Clear internal NoCeM variables."
+  (setq gnus-nocem-alist nil
+	gnus-nocem-hashtb nil
+	gnus-nocem-active nil
+	gnus-nocem-touched-alist nil
+	gnus-nocem-seen-message-ids nil))
+
+(defun gnus-nocem-unwanted-article-p (id)
+  "Say whether article ID in the current group is wanted."
+  (gnus-gethash id gnus-nocem-hashtb))
+
+(provide 'gnus-nocem)
+
+;;; gnus-nocem.el ends here

lisp/gnus/gnus-range.el

@@ -0,0 +1,281 @@
+;;; gnus-range.el --- range and sequence functions for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+;;; List and range functions
+
+(defun gnus-last-element (list)
+  "Return last element of LIST."
+  (while (cdr list)
+    (setq list (cdr list)))
+  (car list))
+
+(defun gnus-copy-sequence (list)
+  "Do a complete, total copy of a list."
+  (let (out)
+    (while (consp list)
+      (if (consp (car list))
+	  (push (gnus-copy-sequence (pop list)) out)
+	(push (pop list) out)))
+    (if list
+	(nconc (nreverse out) list)
+      (nreverse out))))
+
+(defun gnus-set-difference (list1 list2)
+  "Return a list of elements of LIST1 that do not appear in LIST2."
+  (let ((list1 (copy-sequence list1)))
+    (while list2
+      (setq list1 (delq (car list2) list1))
+      (setq list2 (cdr list2)))
+    list1))
+
+(defun gnus-sorted-complement (list1 list2)
+  "Return a list of elements of LIST1 that do not appear in LIST2.
+Both lists have to be sorted over <."
+  (let (out)
+    (if (or (null list1) (null list2))
+	(or list1 list2)
+      (while (and list1 list2)
+	(cond ((= (car list1) (car list2))
+	       (setq list1 (cdr list1)
+		     list2 (cdr list2)))
+	      ((< (car list1) (car list2))
+	       (setq out (cons (car list1) out))
+	       (setq list1 (cdr list1)))
+	      (t
+	       (setq out (cons (car list2) out))
+	       (setq list2 (cdr list2)))))
+      (nconc (nreverse out) (or list1 list2)))))
+
+(defun gnus-intersection (list1 list2)
+  (let ((result nil))
+    (while list2
+      (when (memq (car list2) list1)
+	(setq result (cons (car list2) result)))
+      (setq list2 (cdr list2)))
+    result))
+
+(defun gnus-sorted-intersection (list1 list2)
+  ;; LIST1 and LIST2 have to be sorted over <.
+  (let (out)
+    (while (and list1 list2)
+      (cond ((= (car list1) (car list2))
+	     (setq out (cons (car list1) out)
+		   list1 (cdr list1)
+		   list2 (cdr list2)))
+	    ((< (car list1) (car list2))
+	     (setq list1 (cdr list1)))
+	    (t
+	     (setq list2 (cdr list2)))))
+    (nreverse out)))
+
+(defun gnus-set-sorted-intersection (list1 list2)
+  ;; LIST1 and LIST2 have to be sorted over <.
+  ;; This function modifies LIST1.
+  (let* ((top (cons nil list1))
+	 (prev top))
+    (while (and list1 list2)
+      (cond ((= (car list1) (car list2))
+	     (setq prev list1
+		   list1 (cdr list1)
+		   list2 (cdr list2)))
+	    ((< (car list1) (car list2))
+	     (setcdr prev (cdr list1))
+	     (setq list1 (cdr list1)))
+	    (t
+	     (setq list2 (cdr list2)))))
+    (setcdr prev nil)
+    (cdr top)))
+
+(defun gnus-compress-sequence (numbers &optional always-list)
+  "Convert list of numbers to a list of ranges or a single range.
+If ALWAYS-LIST is non-nil, this function will always release a list of
+ranges."
+  (let* ((first (car numbers))
+	 (last (car numbers))
+	 result)
+    (if (null numbers)
+	nil
+      (if (not (listp (cdr numbers)))
+	  numbers
+	(while numbers
+	  (cond ((= last (car numbers)) nil) ;Omit duplicated number
+		((= (1+ last) (car numbers)) ;Still in sequence
+		 (setq last (car numbers)))
+		(t			;End of one sequence
+		 (setq result
+		       (cons (if (= first last) first
+			       (cons first last))
+			     result))
+		 (setq first (car numbers))
+		 (setq last  (car numbers))))
+	  (setq numbers (cdr numbers)))
+	(if (and (not always-list) (null result))
+	    (if (= first last) (list first) (cons first last))
+	  (nreverse (cons (if (= first last) first (cons first last))
+			  result)))))))
+
+(defalias 'gnus-uncompress-sequence 'gnus-uncompress-range)
+(defun gnus-uncompress-range (ranges)
+  "Expand a list of ranges into a list of numbers.
+RANGES is either a single range on the form `(num . num)' or a list of
+these ranges."
+  (let (first last result)
+    (cond
+     ((null ranges)
+      nil)
+     ((not (listp (cdr ranges)))
+      (setq first (car ranges))
+      (setq last (cdr ranges))
+      (while (<= first last)
+	(setq result (cons first result))
+	(setq first (1+ first)))
+      (nreverse result))
+     (t
+      (while ranges
+	(if (atom (car ranges))
+	    (when (numberp (car ranges))
+	      (setq result (cons (car ranges) result)))
+	  (setq first (caar ranges))
+	  (setq last  (cdar ranges))
+	  (while (<= first last)
+	    (setq result (cons first result))
+	    (setq first (1+ first))))
+	(setq ranges (cdr ranges)))
+      (nreverse result)))))
+
+(defun gnus-add-to-range (ranges list)
+  "Return a list of ranges that has all articles from both RANGES and LIST.
+Note: LIST has to be sorted over `<'."
+  (if (not ranges)
+      (gnus-compress-sequence list t)
+    (setq list (copy-sequence list))
+    (unless (listp (cdr ranges))
+      (setq ranges (list ranges)))
+    (let ((out ranges)
+	  ilist lowest highest temp)
+      (while (and ranges list)
+	(setq ilist list)
+	(setq lowest (or (and (atom (car ranges)) (car ranges))
+			 (caar ranges)))
+	(while (and list (cdr list) (< (cadr list) lowest))
+	  (setq list (cdr list)))
+	(when (< (car ilist) lowest)
+	  (setq temp list)
+	  (setq list (cdr list))
+	  (setcdr temp nil)
+	  (setq out (nconc (gnus-compress-sequence ilist t) out)))
+	(setq highest (or (and (atom (car ranges)) (car ranges))
+			  (cdar ranges)))
+	(while (and list (<= (car list) highest))
+	  (setq list (cdr list)))
+	(setq ranges (cdr ranges)))
+      (when list
+	(setq out (nconc (gnus-compress-sequence list t) out)))
+      (setq out (sort out (lambda (r1 r2)
+			    (< (or (and (atom r1) r1) (car r1))
+			       (or (and (atom r2) r2) (car r2))))))
+      (setq ranges out)
+      (while ranges
+	(if (atom (car ranges))
+	    (when (cdr ranges)
+	      (if (atom (cadr ranges))
+		  (when (= (1+ (car ranges)) (cadr ranges))
+		    (setcar ranges (cons (car ranges)
+					 (cadr ranges)))
+		    (setcdr ranges (cddr ranges)))
+		(when (= (1+ (car ranges)) (caadr ranges))
+		  (setcar (cadr ranges) (car ranges))
+		  (setcar ranges (cadr ranges))
+		  (setcdr ranges (cddr ranges)))))
+	  (when (cdr ranges)
+	    (if (atom (cadr ranges))
+		(when (= (1+ (cdar ranges)) (cadr ranges))
+		  (setcdr (car ranges) (cadr ranges))
+		  (setcdr ranges (cddr ranges)))
+	      (when (= (1+ (cdar ranges)) (caadr ranges))
+		(setcdr (car ranges) (cdadr ranges))
+		(setcdr ranges (cddr ranges))))))
+	(setq ranges (cdr ranges)))
+      out)))
+
+(defun gnus-remove-from-range (ranges list)
+  "Return a list of ranges that has all articles from LIST removed from RANGES.
+Note: LIST has to be sorted over `<'."
+  ;; !!! This function shouldn't look like this, but I've got a headache.
+  (gnus-compress-sequence
+   (gnus-sorted-complement
+    (gnus-uncompress-range ranges) list)))
+
+(defun gnus-member-of-range (number ranges)
+  (if (not (listp (cdr ranges)))
+      (and (>= number (car ranges))
+	   (<= number (cdr ranges)))
+    (let ((not-stop t))
+      (while (and ranges
+		  (if (numberp (car ranges))
+		      (>= number (car ranges))
+		    (>= number (caar ranges)))
+		  not-stop)
+	(when (if (numberp (car ranges))
+		  (= number (car ranges))
+		(and (>= number (caar ranges))
+		     (<= number (cdar ranges))))
+	  (setq not-stop nil))
+	(setq ranges (cdr ranges)))
+      (not not-stop))))
+
+(defun gnus-range-length (range)
+  "Return the length RANGE would have if uncompressed."
+  (length (gnus-uncompress-range range)))
+
+(defun gnus-sublist-p (list sublist)
+  "Test whether all elements in SUBLIST are members of LIST."
+  (let ((sublistp t))
+    (while sublist
+      (unless (memq (pop sublist) list)
+	(setq sublistp nil
+	      sublist nil)))
+    sublistp))
+
+(defun gnus-range-add (range1 range2)
+  "Add RANGE2 to RANGE1 destructively."
+  (cond
+   ;; If either are nil, then the job is quite easy.
+   ((or (null range1) (null range2))
+    (or range1 range2))
+   (t
+    ;; I don't like thinking.
+    (gnus-compress-sequence
+     (sort
+      (nconc
+       (gnus-uncompress-range range1)
+       (gnus-uncompress-range range2))
+      '<)))))
+
+(provide 'gnus-range)
+
+;;; gnus-range.el ends here

lisp/gnus/gnus-salt.el

@@ -0,0 +1,991 @@
+;;; gnus-salt.el --- alternate summary mode interfaces for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-sum)
+
+;;;
+;;; gnus-pick-mode
+;;;
+
+(defvar gnus-pick-mode nil
+  "Minor mode for providing a pick-and-read interface in Gnus summary buffers.")
+
+(defvar gnus-pick-display-summary nil
+  "*Display summary while reading.")
+
+(defvar gnus-pick-mode-hook nil
+  "Hook run in summary pick mode buffers.")
+
+(defvar gnus-mark-unpicked-articles-as-read nil
+  "*If non-nil, mark all unpicked articles as read.")
+
+(defvar gnus-pick-elegant-flow t
+  "If non-nil, gnus-pick-start-reading will run gnus-summary-next-group when no articles have been picked.")
+
+(defvar gnus-summary-pick-line-format
+  "%-5P %U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
+  "*The format specification of the lines in pick buffers.
+It accepts the same format specs that `gnus-summary-line-format' does.")
+
+;;; Internal variables.
+
+(defvar gnus-pick-mode-map nil)
+
+(unless gnus-pick-mode-map
+  (setq gnus-pick-mode-map (make-sparse-keymap))
+
+  (gnus-define-keys
+   gnus-pick-mode-map
+   "t" gnus-uu-mark-thread
+   "T" gnus-uu-unmark-thread
+   " " gnus-pick-next-page
+   "u" gnus-summary-unmark-as-processable
+   "U" gnus-summary-unmark-all-processable
+   "v" gnus-uu-mark-over
+   "r" gnus-uu-mark-region
+   "R" gnus-uu-unmark-region
+   "e" gnus-uu-mark-by-regexp
+   "E" gnus-uu-mark-by-regexp
+   "b" gnus-uu-mark-buffer
+   "B" gnus-uu-unmark-buffer
+   "." gnus-pick-article
+   gnus-down-mouse-2 gnus-pick-mouse-pick-region
+   ;;gnus-mouse-2 gnus-pick-mouse-pick
+   "X" gnus-pick-start-reading
+   "\r" gnus-pick-start-reading))
+
+(defun gnus-pick-make-menu-bar ()
+  (unless (boundp 'gnus-pick-menu)
+    (easy-menu-define
+     gnus-pick-menu gnus-pick-mode-map ""
+     '("Pick"
+       ("Pick"
+	["Article" gnus-summary-mark-as-processable t]
+	["Thread" gnus-uu-mark-thread t]
+	["Region" gnus-uu-mark-region t]
+	["Regexp" gnus-uu-mark-regexp t]
+	["Buffer" gnus-uu-mark-buffer t])
+       ("Unpick"
+	["Article" gnus-summary-unmark-as-processable t]
+	["Thread" gnus-uu-unmark-thread t]
+	["Region" gnus-uu-unmark-region t]
+	["Regexp" gnus-uu-unmark-regexp t]
+	["Buffer" gnus-uu-unmark-buffer t])
+       ["Start reading" gnus-pick-start-reading t]
+       ["Switch pick mode off" gnus-pick-mode gnus-pick-mode]))))
+
+(defun gnus-pick-mode (&optional arg)
+  "Minor mode for providing a pick-and-read interface in Gnus summary buffers.
+
+\\{gnus-pick-mode-map}"
+  (interactive "P")
+  (when (eq major-mode 'gnus-summary-mode)
+    (if (not (set (make-local-variable 'gnus-pick-mode)
+		  (if (null arg) (not gnus-pick-mode)
+		    (> (prefix-numeric-value arg) 0))))
+	(remove-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
+      ;; Make sure that we don't select any articles upon group entry.
+      (set (make-local-variable 'gnus-auto-select-first) nil)
+      ;; Change line format.
+      (setq gnus-summary-line-format gnus-summary-pick-line-format)
+      (setq gnus-summary-line-format-spec nil)
+      (gnus-update-format-specifications nil 'summary)
+      (gnus-update-summary-mark-positions)
+      (add-hook 'gnus-message-setup-hook 'gnus-pick-setup-message)
+      (set (make-local-variable 'gnus-summary-goto-unread) 'never)
+      ;; Set up the menu.
+      (when (gnus-visual-p 'pick-menu 'menu)
+	(gnus-pick-make-menu-bar))
+      (unless (assq 'gnus-pick-mode minor-mode-alist)
+	(push '(gnus-pick-mode " Pick") minor-mode-alist))
+      (unless (assq 'gnus-pick-mode minor-mode-map-alist)
+	(push (cons 'gnus-pick-mode gnus-pick-mode-map)
+	      minor-mode-map-alist))
+      (run-hooks 'gnus-pick-mode-hook))))
+
+(defun gnus-pick-setup-message ()
+  "Make Message do the right thing on exit."
+  (when (and (gnus-buffer-live-p gnus-summary-buffer)
+	     (save-excursion
+	       (set-buffer gnus-summary-buffer)
+	       gnus-pick-mode))
+    (message-add-action
+     '(gnus-configure-windows 'pick t) 'send 'exit 'postpone 'kill)))
+
+(defvar gnus-pick-line-number 1)
+(defun gnus-pick-line-number ()
+  "Return the current line number."
+  (if (bobp)
+      (setq gnus-pick-line-number 1)
+    (incf gnus-pick-line-number)))
+
+(defun gnus-pick-start-reading (&optional catch-up)
+  "Start reading the picked articles.
+If given a prefix, mark all unpicked articles as read."
+  (interactive "P")
+  (if gnus-newsgroup-processable
+      (progn
+        (gnus-summary-limit-to-articles nil)
+        (when (or catch-up gnus-mark-unpicked-articles-as-read)
+	  (gnus-summary-limit-mark-excluded-as-read))
+        (gnus-summary-first-article)
+        (gnus-configure-windows
+	 (if gnus-pick-display-summary 'article 'pick) t))
+    (if gnus-pick-elegant-flow
+	(progn
+	  (when (or catch-up gnus-mark-unpicked-articles-as-read)
+	    (gnus-summary-limit-mark-excluded-as-read))
+	  (if (gnus-group-quit-config gnus-newsgroup-name)
+	      (gnus-summary-exit)
+	    (gnus-summary-next-group)))
+      (error "No articles have been picked"))))
+
+(defun gnus-pick-article (&optional arg)
+  "Pick the article on the current line.
+If ARG, pick the article on that line instead."
+  (interactive "P")
+  (when arg
+    (let (pos)
+      (save-excursion
+	(goto-char (point-min))
+	(when (zerop (forward-line (1- (prefix-numeric-value arg))))
+	  (setq pos (point))))
+      (if (not pos)
+	  (gnus-error 2 "No such line: %s" arg)
+	(goto-char pos))))
+  (gnus-summary-mark-as-processable 1))
+
+(defun gnus-pick-mouse-pick (e)
+  (interactive "e")
+  (mouse-set-point e)
+  (save-excursion
+    (gnus-summary-mark-as-processable 1)))
+
+(defun gnus-pick-mouse-pick-region (start-event)
+  "Pick articles that the mouse is dragged over.
+This must be bound to a button-down mouse event."
+  (interactive "e")
+  (mouse-minibuffer-check start-event)
+  (let* ((echo-keystrokes 0)
+	 (start-posn (event-start start-event))
+	 (start-point (posn-point start-posn))
+         (start-line (1+ (count-lines 1 start-point)))
+	 (start-window (posn-window start-posn))
+	 (start-frame (window-frame start-window))
+	 (bounds (window-edges start-window))
+	 (top (nth 1 bounds))
+	 (bottom (if (window-minibuffer-p start-window)
+		     (nth 3 bounds)
+		   ;; Don't count the mode line.
+		   (1- (nth 3 bounds))))
+	 (click-count (1- (event-click-count start-event))))
+    (setq mouse-selection-click-count click-count)
+    (setq mouse-selection-click-count-buffer (current-buffer))
+    (mouse-set-point start-event)
+    ;; In case the down click is in the middle of some intangible text,
+    ;; use the end of that text, and put it in START-POINT.
+    (when (< (point) start-point)
+      (goto-char start-point))
+    (gnus-pick-article)
+    (setq start-point (point))
+    ;; end-of-range is used only in the single-click case.
+    ;; It is the place where the drag has reached so far
+    ;; (but not outside the window where the drag started).
+    (let (event end end-point last-end-point (end-of-range (point)))
+      (track-mouse
+       (while (progn
+		(setq event (read-event))
+		(or (mouse-movement-p event)
+		    (eq (car-safe event) 'switch-frame)))
+	 (if (eq (car-safe event) 'switch-frame)
+	     nil
+	   (setq end (event-end event)
+		 end-point (posn-point end))
+	   (when end-point
+	     (setq last-end-point end-point))
+
+	   (cond
+	    ;; Are we moving within the original window?
+	    ((and (eq (posn-window end) start-window)
+		  (integer-or-marker-p end-point))
+	     ;; Go to START-POINT first, so that when we move to END-POINT,
+	     ;; if it's in the middle of intangible text,
+	     ;; point jumps in the direction away from START-POINT.
+	     (goto-char start-point)
+	     (goto-char end-point)
+	     (gnus-pick-article)
+	     ;; In case the user moved his mouse really fast, pick
+	     ;; articles on the line between this one and the last one.
+	     (let* ((this-line (1+ (count-lines 1 end-point)))
+		    (min-line (min this-line start-line))
+		    (max-line (max this-line start-line)))
+	       (while (< min-line max-line)
+		 (goto-line min-line)
+		 (gnus-pick-article)
+		 (setq min-line (1+ min-line)))
+	       (setq start-line this-line))
+	     (when (zerop (% click-count 3))
+	       (setq end-of-range (point))))
+	    (t
+	     (let ((mouse-row (cdr (cdr (mouse-position)))))
+	       (cond
+		((null mouse-row))
+		((< mouse-row top)
+		 (mouse-scroll-subr start-window (- mouse-row top)))
+		((>= mouse-row bottom)
+		 (mouse-scroll-subr start-window
+				    (1+ (- mouse-row bottom)))))))))))
+      (when (consp event)
+	(let ((fun (key-binding (vector (car event)))))
+	  ;; Run the binding of the terminating up-event, if possible.
+	  ;; In the case of a multiple click, it gives the wrong results,
+	  ;; because it would fail to set up a region.
+	  (when nil
+	    ;; (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
+	    ;; In this case, we can just let the up-event execute normally.
+	    (let ((end (event-end event)))
+	      ;; Set the position in the event before we replay it,
+	      ;; because otherwise it may have a position in the wrong
+	      ;; buffer.
+	      (setcar (cdr end) end-of-range)
+	      ;; Delete the overlay before calling the function,
+	      ;; because delete-overlay increases buffer-modified-tick.
+	      (push event unread-command-events))))))))
+
+(defun gnus-pick-next-page ()
+  "Go to the next page.  If at the end of the buffer, start reading articles."
+  (interactive)
+  (let ((scroll-in-place nil))
+    (condition-case nil
+	(scroll-up)
+      (end-of-buffer (gnus-pick-start-reading)))))
+
+;;;
+;;; gnus-binary-mode
+;;;
+
+(defvar gnus-binary-mode nil
+  "Minor mode for providing a binary group interface in Gnus summary buffers.")
+
+(defvar gnus-binary-mode-hook nil
+  "Hook run in summary binary mode buffers.")
+
+(defvar gnus-binary-mode-map nil)
+
+(unless gnus-binary-mode-map
+  (setq gnus-binary-mode-map (make-sparse-keymap))
+
+  (gnus-define-keys
+   gnus-binary-mode-map
+   "g" gnus-binary-show-article))
+
+(defun gnus-binary-make-menu-bar ()
+  (unless (boundp 'gnus-binary-menu)
+    (easy-menu-define
+     gnus-binary-menu gnus-binary-mode-map ""
+     '("Pick"
+       ["Switch binary mode off" gnus-binary-mode t]))))
+
+(defun gnus-binary-mode (&optional arg)
+  "Minor mode for providing a binary group interface in Gnus summary buffers."
+  (interactive "P")
+  (when (eq major-mode 'gnus-summary-mode)
+    (make-local-variable 'gnus-binary-mode)
+    (setq gnus-binary-mode
+	  (if (null arg) (not gnus-binary-mode)
+	    (> (prefix-numeric-value arg) 0)))
+    (when gnus-binary-mode
+      ;; Make sure that we don't select any articles upon group entry.
+      (make-local-variable 'gnus-auto-select-first)
+      (setq gnus-auto-select-first nil)
+      (make-local-variable 'gnus-summary-display-article-function)
+      (setq gnus-summary-display-article-function 'gnus-binary-display-article)
+      ;; Set up the menu.
+      (when (gnus-visual-p 'binary-menu 'menu)
+	(gnus-binary-make-menu-bar))
+      (unless (assq 'gnus-binary-mode minor-mode-alist)
+	(push '(gnus-binary-mode " Binary") minor-mode-alist))
+      (unless (assq 'gnus-binary-mode minor-mode-map-alist)
+	(push (cons 'gnus-binary-mode gnus-binary-mode-map)
+	      minor-mode-map-alist))
+      (run-hooks 'gnus-binary-mode-hook))))
+
+(defun gnus-binary-display-article (article &optional all-header)
+  "Run ARTICLE through the binary decode functions."
+  (when (gnus-summary-goto-subject article)
+    (let ((gnus-view-pseudos 'automatic))
+      (gnus-uu-decode-uu))))
+
+(defun gnus-binary-show-article (&optional arg)
+  "Bypass the binary functions and show the article."
+  (interactive "P")
+  (let (gnus-summary-display-article-function)
+    (gnus-summary-show-article arg)))
+
+;;;
+;;; gnus-tree-mode
+;;;
+
+(defvar gnus-tree-line-format "%(%[%3,3n%]%)"
+  "Format of tree elements.")
+
+(defvar gnus-tree-minimize-window t
+  "If non-nil, minimize the tree buffer window.
+If a number, never let the tree buffer grow taller than that number of
+lines.")
+
+(defvar gnus-selected-tree-face 'modeline
+  "*Face used for highlighting selected articles in the thread tree.")
+
+(defvar gnus-tree-brackets '((?\[ . ?\]) (?\( . ?\))
+			     (?\{ . ?\}) (?< . ?>))
+  "Brackets used in tree nodes.")
+
+(defvar gnus-tree-parent-child-edges '(?- ?\\ ?|)
+  "Characters used to connect parents with children.")
+
+(defvar gnus-tree-mode-line-format "Gnus: %%b %S %Z"
+  "*The format specification for the tree mode line.")
+
+(defvar gnus-generate-tree-function 'gnus-generate-vertical-tree
+  "*Function for generating a thread tree.
+Two predefined functions are available:
+`gnus-generate-horizontal-tree' and `gnus-generate-vertical-tree'.")
+
+(defvar gnus-tree-mode-hook nil
+  "*Hook run in tree mode buffers.")
+
+;;; Internal variables.
+
+(defvar gnus-tree-line-format-alist
+  `((?n gnus-tmp-name ?s)
+    (?f gnus-tmp-from ?s)
+    (?N gnus-tmp-number ?d)
+    (?\[ gnus-tmp-open-bracket ?c)
+    (?\] gnus-tmp-close-bracket ?c)
+    (?s gnus-tmp-subject ?s)))
+
+(defvar gnus-tree-mode-line-format-alist gnus-summary-mode-line-format-alist)
+
+(defvar gnus-tree-mode-line-format-spec nil)
+(defvar gnus-tree-line-format-spec nil)
+
+(defvar gnus-tree-node-length nil)
+(defvar gnus-selected-tree-overlay nil)
+
+(defvar gnus-tree-displayed-thread nil)
+
+(defvar gnus-tree-mode-map nil)
+(put 'gnus-tree-mode 'mode-class 'special)
+
+(unless gnus-tree-mode-map
+  (setq gnus-tree-mode-map (make-keymap))
+  (suppress-keymap gnus-tree-mode-map)
+  (gnus-define-keys
+   gnus-tree-mode-map
+   "\r" gnus-tree-select-article
+   gnus-mouse-2 gnus-tree-pick-article
+   "\C-?" gnus-tree-read-summary-keys
+
+   "\C-c\C-i" gnus-info-find-node)
+
+  (substitute-key-definition
+   'undefined 'gnus-tree-read-summary-keys gnus-tree-mode-map))
+
+(defun gnus-tree-make-menu-bar ()
+  (unless (boundp 'gnus-tree-menu)
+    (easy-menu-define
+     gnus-tree-menu gnus-tree-mode-map ""
+     '("Tree"
+       ["Select article" gnus-tree-select-article t]))))
+
+(defun gnus-tree-mode ()
+  "Major mode for displaying thread trees."
+  (interactive)
+  (setq gnus-tree-mode-line-format-spec
+	(gnus-parse-format gnus-tree-mode-line-format
+			   gnus-summary-mode-line-format-alist))
+  (setq gnus-tree-line-format-spec
+	(gnus-parse-format gnus-tree-line-format
+			   gnus-tree-line-format-alist t))
+  (when (gnus-visual-p 'tree-menu 'menu)
+    (gnus-tree-make-menu-bar))
+  (kill-all-local-variables)
+  (gnus-simplify-mode-line)
+  (setq mode-name "Tree")
+  (setq major-mode 'gnus-tree-mode)
+  (use-local-map gnus-tree-mode-map)
+  (buffer-disable-undo (current-buffer))
+  (setq buffer-read-only t)
+  (setq truncate-lines t)
+  (save-excursion
+    (gnus-set-work-buffer)
+    (gnus-tree-node-insert (make-mail-header "") nil)
+    (setq gnus-tree-node-length (1- (point))))
+  (run-hooks 'gnus-tree-mode-hook))
+
+(defun gnus-tree-read-summary-keys (&optional arg)
+  "Read a summary buffer key sequence and execute it."
+  (interactive "P")
+  (let ((buf (current-buffer))
+	win)
+    (gnus-article-read-summary-keys arg nil t)
+    (when (setq win (get-buffer-window buf))
+      (select-window win)
+      (when gnus-selected-tree-overlay
+	(goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
+      (gnus-tree-minimize))))
+
+(defun gnus-tree-select-article (article)
+  "Select the article under point, if any."
+  (interactive (list (gnus-tree-article-number)))
+  (let ((buf (current-buffer)))
+    (when article
+      (save-excursion
+	(set-buffer gnus-summary-buffer)
+	(gnus-summary-goto-article article))
+      (select-window (get-buffer-window buf)))))
+
+(defun gnus-tree-pick-article (e)
+  "Select the article under the mouse pointer."
+  (interactive "e")
+  (mouse-set-point e)
+  (gnus-tree-select-article (gnus-tree-article-number)))
+
+(defun gnus-tree-article-number ()
+  (get-text-property (point) 'gnus-number))
+
+(defun gnus-tree-article-region (article)
+  "Return a cons with BEG and END of the article region."
+  (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
+    (when pos
+      (cons pos (next-single-property-change pos 'gnus-number)))))
+
+(defun gnus-tree-goto-article (article)
+  (let ((pos (text-property-any (point-min) (point-max) 'gnus-number article)))
+    (when pos
+      (goto-char pos))))
+
+(defun gnus-tree-recenter ()
+  "Center point in the tree window."
+  (let ((selected (selected-window))
+	(tree-window (get-buffer-window gnus-tree-buffer t)))
+    (when tree-window
+      (select-window tree-window)
+      (when gnus-selected-tree-overlay
+	(goto-char (or (gnus-overlay-end gnus-selected-tree-overlay) 1)))
+      (let* ((top (cond ((< (window-height) 4) 0)
+			((< (window-height) 7) 1)
+			(t 2)))
+	     (height (1- (window-height)))
+	     (bottom (save-excursion (goto-char (point-max))
+				     (forward-line (- height))
+				     (point))))
+	;; Set the window start to either `bottom', which is the biggest
+	;; possible valid number, or the second line from the top,
+	;; whichever is the least.
+	(set-window-start
+	 tree-window (min bottom (save-excursion
+				   (forward-line (- top)) (point)))))
+      (select-window selected))))
+
+(defun gnus-get-tree-buffer ()
+  "Return the tree buffer properly initialized."
+  (save-excursion
+    (set-buffer (get-buffer-create gnus-tree-buffer))
+    (unless (eq major-mode 'gnus-tree-mode)
+      (gnus-add-current-to-buffer-list)
+      (gnus-tree-mode))
+    (current-buffer)))
+
+(defun gnus-tree-minimize ()
+  (when (and gnus-tree-minimize-window
+	     (not (one-window-p)))
+    (let ((windows 0)
+	  tot-win-height)
+      (walk-windows (lambda (window) (incf windows)))
+      (setq tot-win-height
+	    (- (frame-height)
+	       (* window-min-height (1- windows))
+	       2))
+      (let* ((window-min-height 2)
+	     (height (count-lines (point-min) (point-max)))
+	     (min (max (1- window-min-height) height))
+	     (tot (if (numberp gnus-tree-minimize-window)
+		      (min gnus-tree-minimize-window min)
+		    min))
+	     (win (get-buffer-window (current-buffer)))
+	     (wh (and win (1- (window-height win)))))
+	(setq tot (min tot tot-win-height))
+	(when (and win
+		   (not (eq tot wh)))
+	  (let ((selected (selected-window)))
+	    (when (ignore-errors (select-window win))
+	      (enlarge-window (- tot wh))
+	      (select-window selected))))))))
+
+;;; Generating the tree.
+
+(defun gnus-tree-node-insert (header sparse &optional adopted)
+  (let* ((dummy (stringp header))
+	 (header (if (vectorp header) header
+		   (progn
+		     (setq header (make-mail-header "*****"))
+		     (mail-header-set-number header 0)
+		     (mail-header-set-lines header 0)
+		     (mail-header-set-chars header 0)
+		     header)))
+	 (gnus-tmp-from (mail-header-from header))
+	 (gnus-tmp-subject (mail-header-subject header))
+	 (gnus-tmp-number (mail-header-number header))
+	 (gnus-tmp-name
+	  (cond
+	   ((string-match "(.+)" gnus-tmp-from)
+	    (substring gnus-tmp-from
+		       (1+ (match-beginning 0)) (1- (match-end 0))))
+	   ((string-match "<[^>]+> *$" gnus-tmp-from)
+	    (let ((beg (match-beginning 0)))
+	      (or (and (string-match "^\"[^\"]*\"" gnus-tmp-from)
+		       (substring gnus-tmp-from (1+ (match-beginning 0))
+				  (1- (match-end 0))))
+		  (substring gnus-tmp-from 0 beg))))
+	   ((memq gnus-tmp-number sparse)
+	    "***")
+	   (t gnus-tmp-from)))
+	 (gnus-tmp-open-bracket
+	  (cond ((memq gnus-tmp-number sparse)
+		 (caadr gnus-tree-brackets))
+		(dummy (caaddr gnus-tree-brackets))
+		(adopted (car (nth 3 gnus-tree-brackets)))
+		(t (caar gnus-tree-brackets))))
+	 (gnus-tmp-close-bracket
+	  (cond ((memq gnus-tmp-number sparse)
+		 (cdadr gnus-tree-brackets))
+		(adopted (cdr (nth 3 gnus-tree-brackets)))
+		(dummy
+		 (cdaddr gnus-tree-brackets))
+		(t (cdar gnus-tree-brackets))))
+	 (buffer-read-only nil)
+	 beg end)
+    (gnus-add-text-properties
+     (setq beg (point))
+     (setq end (progn (eval gnus-tree-line-format-spec) (point)))
+     (list 'gnus-number gnus-tmp-number))
+    (when (or t (gnus-visual-p 'tree-highlight 'highlight))
+      (gnus-tree-highlight-node gnus-tmp-number beg end))))
+
+(defun gnus-tree-highlight-node (article beg end)
+  "Highlight current line according to `gnus-summary-highlight'."
+  (let ((list gnus-summary-highlight)
+	face)
+    (save-excursion
+      (set-buffer gnus-summary-buffer)
+      (let* ((score (or (cdr (assq article gnus-newsgroup-scored))
+			gnus-summary-default-score 0))
+	     (default gnus-summary-default-score)
+	     (mark (or (gnus-summary-article-mark article) gnus-unread-mark)))
+	;; Eval the cars of the lists until we find a match.
+	(while (and list
+		    (not (eval (caar list))))
+	  (setq list (cdr list)))))
+    (unless (eq (setq face (cdar list)) (get-text-property beg 'face))
+      (gnus-put-text-property
+       beg end 'face
+       (if (boundp face) (symbol-value face) face)))))
+
+(defun gnus-tree-indent (level)
+  (insert (make-string (1- (* (1+ gnus-tree-node-length) level)) ? )))
+
+(defvar gnus-tmp-limit)
+(defvar gnus-tmp-sparse)
+(defvar gnus-tmp-indent)
+
+(defun gnus-generate-tree (thread)
+  "Generate a thread tree for THREAD."
+  (save-excursion
+    (set-buffer (gnus-get-tree-buffer))
+    (let ((buffer-read-only nil)
+	  (gnus-tmp-indent 0))
+      (erase-buffer)
+      (funcall gnus-generate-tree-function thread 0)
+      (gnus-set-mode-line 'tree)
+      (goto-char (point-min))
+      (gnus-tree-minimize)
+      (gnus-tree-recenter)
+      (let ((selected (selected-window)))
+	(when (get-buffer-window (set-buffer gnus-tree-buffer) t)
+	  (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
+	  (gnus-horizontal-recenter)
+	  (select-window selected))))))
+
+(defun gnus-generate-horizontal-tree (thread level &optional dummyp adopted)
+  "Generate a horizontal tree."
+  (let* ((dummy (stringp (car thread)))
+	 (do (or dummy
+		 (memq (mail-header-number (car thread)) gnus-tmp-limit)))
+	 col beg)
+    (if (not do)
+	;; We don't want this article.
+	(setq thread (cdr thread))
+      (if (not (bolp))
+	  ;; Not the first article on the line, so we insert a "-".
+	  (insert (car gnus-tree-parent-child-edges))
+	;; If the level isn't zero, then we insert some indentation.
+	(unless (zerop level)
+	  (gnus-tree-indent level)
+	  (insert (cadr gnus-tree-parent-child-edges))
+	  (setq col (- (setq beg (point)) (gnus-point-at-bol) 1))
+	  ;; Draw "|" lines upwards.
+	  (while (progn
+		   (forward-line -1)
+		   (forward-char col)
+		   (= (following-char) ? ))
+	    (delete-char 1)
+	    (insert (caddr gnus-tree-parent-child-edges)))
+	  (goto-char beg)))
+      (setq dummyp nil)
+      ;; Insert the article node.
+      (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted))
+    (if (null thread)
+	;; End of the thread, so we go to the next line.
+	(unless (bolp)
+	  (insert "\n"))
+      ;; Recurse downwards in all children of this article.
+      (while thread
+	(gnus-generate-horizontal-tree
+	 (pop thread) (if do (1+ level) level)
+	 (or dummyp dummy) dummy)))))
+
+(defsubst gnus-tree-indent-vertical ()
+  (let ((len (- (* (1+ gnus-tree-node-length) gnus-tmp-indent)
+		(- (point) (gnus-point-at-bol)))))
+    (when (> len 0)
+      (insert (make-string len ? )))))
+
+(defsubst gnus-tree-forward-line (n)
+  (while (>= (decf n) 0)
+    (unless (zerop (forward-line 1))
+      (end-of-line)
+      (insert "\n")))
+  (end-of-line))
+
+(defun gnus-generate-vertical-tree (thread level &optional dummyp adopted)
+  "Generate a vertical tree."
+  (let* ((dummy (stringp (car thread)))
+	 (do (or dummy
+		 (and (car thread)
+		      (memq (mail-header-number (car thread))
+			    gnus-tmp-limit))))
+	 beg)
+    (if (not do)
+	;; We don't want this article.
+	(setq thread (cdr thread))
+      (if (not (save-excursion (beginning-of-line) (bobp)))
+	  ;; Not the first article on the line, so we insert a "-".
+	  (progn
+	    (gnus-tree-indent-vertical)
+	    (insert (make-string (/ gnus-tree-node-length 2) ? ))
+	    (insert (caddr gnus-tree-parent-child-edges))
+	    (gnus-tree-forward-line 1))
+	;; If the level isn't zero, then we insert some indentation.
+	(unless (zerop gnus-tmp-indent)
+	  (gnus-tree-forward-line (1- (* 2 level)))
+	  (gnus-tree-indent-vertical)
+	  (delete-char -1)
+	  (insert (cadr gnus-tree-parent-child-edges))
+	  (setq beg (point))
+	  ;; Draw "-" lines leftwards.
+	  (while (progn
+		   (unless (bolp)
+		     (forward-char -2))
+		   (= (following-char) ? ))
+	    (delete-char 1)
+	    (insert (car gnus-tree-parent-child-edges)))
+	  (goto-char beg)
+	  (gnus-tree-forward-line 1)))
+      (setq dummyp nil)
+      ;; Insert the article node.
+      (gnus-tree-indent-vertical)
+      (gnus-tree-node-insert (pop thread) gnus-tmp-sparse adopted)
+      (gnus-tree-forward-line 1))
+    (if (null thread)
+	;; End of the thread, so we go to the next line.
+	(progn
+	  (goto-char (point-min))
+	  (end-of-line)
+	  (incf gnus-tmp-indent))
+      ;; Recurse downwards in all children of this article.
+      (while thread
+	(gnus-generate-vertical-tree
+	 (pop thread) (if do (1+ level) level)
+	 (or dummyp dummy) dummy)))))
+
+;;; Interface functions.
+
+(defun gnus-possibly-generate-tree (article &optional force)
+  "Generate the thread tree for ARTICLE if it isn't displayed already."
+  (when (save-excursion
+	  (set-buffer gnus-summary-buffer)
+	  (and gnus-use-trees
+	       gnus-show-threads
+	       (vectorp (gnus-summary-article-header article))))
+    (save-excursion
+      (let ((top (save-excursion
+		   (set-buffer gnus-summary-buffer)
+		   (gnus-cut-thread
+		    (gnus-remove-thread
+		     (mail-header-id
+		      (gnus-summary-article-header article))
+		     t))))
+	    (gnus-tmp-limit gnus-newsgroup-limit)
+	    (gnus-tmp-sparse gnus-newsgroup-sparse))
+	(when (or force
+		  (not (eq top gnus-tree-displayed-thread)))
+	  (gnus-generate-tree top)
+	  (setq gnus-tree-displayed-thread top))))))
+
+(defun gnus-tree-open (group)
+  (gnus-get-tree-buffer))
+
+(defun gnus-tree-close (group)
+					;(gnus-kill-buffer gnus-tree-buffer)
+  )
+
+(defun gnus-highlight-selected-tree (article)
+  "Highlight the selected article in the tree."
+  (let ((buf (current-buffer))
+	region)
+    (set-buffer gnus-tree-buffer)
+    (when (setq region (gnus-tree-article-region article))
+      (when (or (not gnus-selected-tree-overlay)
+		(gnus-extent-detached-p gnus-selected-tree-overlay))
+	;; Create a new overlay.
+	(gnus-overlay-put
+	 (setq gnus-selected-tree-overlay (gnus-make-overlay 1 2))
+	 'face gnus-selected-tree-face))
+      ;; Move the overlay to the article.
+      (gnus-move-overlay
+       gnus-selected-tree-overlay (goto-char (car region)) (cdr region))
+      (gnus-tree-minimize)
+      (gnus-tree-recenter)
+      (let ((selected (selected-window)))
+	(when (get-buffer-window (set-buffer gnus-tree-buffer) t)
+	  (select-window (get-buffer-window (set-buffer gnus-tree-buffer) t))
+	  (gnus-horizontal-recenter)
+	  (select-window selected))))
+    ;; If we remove this save-excursion, it updates the wrong mode lines?!?
+    (save-excursion
+      (set-buffer gnus-tree-buffer)
+      (gnus-set-mode-line 'tree))
+    (set-buffer buf)))
+
+(defun gnus-tree-highlight-article (article face)
+  (save-excursion
+    (set-buffer (gnus-get-tree-buffer))
+    (let (region)
+      (when (setq region (gnus-tree-article-region article))
+	(gnus-put-text-property (car region) (cdr region) 'face face)
+	(set-window-point
+	 (get-buffer-window (current-buffer) t) (cdr region))))))
+
+;;;
+;;; gnus-carpal
+;;;
+
+(defvar gnus-carpal-group-buffer-buttons
+  '(("next" . gnus-group-next-unread-group)
+    ("prev" . gnus-group-prev-unread-group)
+    ("read" . gnus-group-read-group)
+    ("select" . gnus-group-select-group)
+    ("catch-up" . gnus-group-catchup-current)
+    ("new-news" . gnus-group-get-new-news-this-group)
+    ("toggle-sub" . gnus-group-unsubscribe-current-group)
+    ("subscribe" . gnus-group-unsubscribe-group)
+    ("kill" . gnus-group-kill-group)
+    ("yank" . gnus-group-yank-group)
+    ("describe" . gnus-group-describe-group)
+    "list"
+    ("subscribed" . gnus-group-list-groups)
+    ("all" . gnus-group-list-all-groups)
+    ("killed" . gnus-group-list-killed)
+    ("zombies" . gnus-group-list-zombies)
+    ("matching" . gnus-group-list-matching)
+    ("post" . gnus-group-post-news)
+    ("mail" . gnus-group-mail)
+    ("rescan" . gnus-group-get-new-news)
+    ("browse-foreign" . gnus-group-browse-foreign)
+    ("exit" . gnus-group-exit)))
+
+(defvar gnus-carpal-summary-buffer-buttons
+  '("mark"
+    ("read" . gnus-summary-mark-as-read-forward)
+    ("tick" . gnus-summary-tick-article-forward)
+    ("clear" . gnus-summary-clear-mark-forward)
+    ("expirable" . gnus-summary-mark-as-expirable)
+    "move"
+    ("scroll" . gnus-summary-next-page)
+    ("next-unread" . gnus-summary-next-unread-article)
+    ("prev-unread" . gnus-summary-prev-unread-article)
+    ("first" . gnus-summary-first-unread-article)
+    ("best" . gnus-summary-best-unread-article)
+    "article"
+    ("headers" . gnus-summary-toggle-header)
+    ("uudecode" . gnus-uu-decode-uu)
+    ("enter-digest" . gnus-summary-enter-digest-group)
+    ("fetch-parent" . gnus-summary-refer-parent-article)
+    "mail"
+    ("move" . gnus-summary-move-article)
+    ("copy" . gnus-summary-copy-article)
+    ("respool" . gnus-summary-respool-article)
+    "threads"
+    ("lower" . gnus-summary-lower-thread)
+    ("kill" . gnus-summary-kill-thread)
+    "post"
+    ("post" . gnus-summary-post-news)
+    ("mail" . gnus-summary-mail)
+    ("followup" . gnus-summary-followup-with-original)
+    ("reply" . gnus-summary-reply-with-original)
+    ("cancel" . gnus-summary-cancel-article)
+    "misc"
+    ("exit" . gnus-summary-exit)
+    ("fed-up" . gnus-summary-catchup-and-goto-next-group)))
+
+(defvar gnus-carpal-server-buffer-buttons
+  '(("add" . gnus-server-add-server)
+    ("browse" . gnus-server-browse-server)
+    ("list" . gnus-server-list-servers)
+    ("kill" . gnus-server-kill-server)
+    ("yank" . gnus-server-yank-server)
+    ("copy" . gnus-server-copy-server)
+    ("exit" . gnus-server-exit)))
+
+(defvar gnus-carpal-browse-buffer-buttons
+  '(("subscribe" . gnus-browse-unsubscribe-current-group)
+    ("exit" . gnus-browse-exit)))
+
+(defvar gnus-carpal-group-buffer "*Carpal Group*")
+(defvar gnus-carpal-summary-buffer "*Carpal Summary*")
+(defvar gnus-carpal-server-buffer "*Carpal Server*")
+(defvar gnus-carpal-browse-buffer "*Carpal Browse*")
+
+(defvar gnus-carpal-attached-buffer nil)
+
+(defvar gnus-carpal-mode-hook nil
+  "*Hook run in carpal mode buffers.")
+
+(defvar gnus-carpal-button-face 'bold
+  "*Face used on carpal buttons.")
+
+(defvar gnus-carpal-header-face 'bold-italic
+  "*Face used on carpal buffer headers.")
+
+(defvar gnus-carpal-mode-map nil)
+(put 'gnus-carpal-mode 'mode-class 'special)
+
+(if gnus-carpal-mode-map
+    nil
+  (setq gnus-carpal-mode-map (make-keymap))
+  (suppress-keymap gnus-carpal-mode-map)
+  (define-key gnus-carpal-mode-map " " 'gnus-carpal-select)
+  (define-key gnus-carpal-mode-map "\r" 'gnus-carpal-select)
+  (define-key gnus-carpal-mode-map gnus-mouse-2 'gnus-carpal-mouse-select))
+
+(defun gnus-carpal-mode ()
+  "Major mode for clicking buttons.
+
+All normal editing commands are switched off.
+\\<gnus-carpal-mode-map>
+The following commands are available:
+
+\\{gnus-carpal-mode-map}"
+  (interactive)
+  (kill-all-local-variables)
+  (setq mode-line-modified "-- ")
+  (setq major-mode 'gnus-carpal-mode)
+  (setq mode-name "Gnus Carpal")
+  (setq mode-line-process nil)
+  (use-local-map gnus-carpal-mode-map)
+  (buffer-disable-undo (current-buffer))
+  (setq buffer-read-only t)
+  (make-local-variable 'gnus-carpal-attached-buffer)
+  (run-hooks 'gnus-carpal-mode-hook))
+
+(defun gnus-carpal-setup-buffer (type)
+  (let ((buffer (symbol-value (intern (format "gnus-carpal-%s-buffer" type)))))
+    (if (get-buffer buffer)
+	()
+      (save-excursion
+	(set-buffer (get-buffer-create buffer))
+	(gnus-carpal-mode)
+	(setq gnus-carpal-attached-buffer
+	      (intern (format "gnus-%s-buffer" type)))
+	(gnus-add-current-to-buffer-list)
+	(let ((buttons (symbol-value
+			(intern (format "gnus-carpal-%s-buffer-buttons"
+					type))))
+	      (buffer-read-only nil)
+	      button)
+	  (while buttons
+	    (setq button (car buttons)
+		  buttons (cdr buttons))
+	    (if (stringp button)
+		(gnus-set-text-properties
+		 (point)
+		 (prog2 (insert button) (point) (insert " "))
+		 (list 'face gnus-carpal-header-face))
+	      (gnus-set-text-properties
+	       (point)
+	       (prog2 (insert (car button)) (point) (insert " "))
+	       (list 'gnus-callback (cdr button)
+		     'face gnus-carpal-button-face
+		     gnus-mouse-face-prop 'highlight))))
+	  (let ((fill-column (- (window-width) 2)))
+	    (fill-region (point-min) (point-max)))
+	  (set-window-point (get-buffer-window (current-buffer))
+			    (point-min)))))))
+
+(defun gnus-carpal-select ()
+  "Select the button under point."
+  (interactive)
+  (let ((func (get-text-property (point) 'gnus-callback)))
+    (if (null func)
+	()
+      (pop-to-buffer (symbol-value gnus-carpal-attached-buffer))
+      (call-interactively func))))
+
+(defun gnus-carpal-mouse-select (event)
+  "Select the button under the mouse pointer."
+  (interactive "e")
+  (mouse-set-point event)
+  (gnus-carpal-select))
+
+;;; Allow redefinition of functions.
+(gnus-ems-redefine)
+
+(provide 'gnus-salt)
+
+;;; gnus-salt.el ends here

lisp/gnus/gnus-setup.el

@@ -0,0 +1,217 @@
+;;; gnus-setup.el --- Initialization & Setup for Gnus 5
+;; Copyright (C) 1995, 96 Free Software Foundation, Inc.
+
+;; Author: Steven L. Baur <steve@miranova.com>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+;; My head is starting to spin with all the different mail/news packages.
+;; Stop The Madness!
+
+;; Given that Emacs Lisp byte codes may be diverging, it is probably best
+;; not to byte compile this, and just arrange to have the .el loaded out
+;; of .emacs.
+
+;;; Code:
+
+(require 'cl)
+
+(defvar running-xemacs (string-match "XEmacs\\|Lucid" emacs-version))
+
+(defvar gnus-use-installed-gnus t
+  "*If non-nil Use installed version of Gnus.")
+
+(defvar gnus-use-installed-tm running-xemacs
+  "*If non-nil use installed version of tm.")
+
+(defvar gnus-use-installed-mailcrypt running-xemacs
+  "*If non-nil use installed version of mailcrypt.")
+
+(defvar gnus-emacs-lisp-directory (if running-xemacs
+				      "/usr/local/lib/xemacs/"
+				    "/usr/local/share/emacs/")
+  "Directory where Emacs site lisp is located.")
+
+(defvar gnus-gnus-lisp-directory (concat gnus-emacs-lisp-directory
+					 "gnus-5.0.15/lisp/")
+  "Directory where Gnus Emacs lisp is found.")
+
+(defvar gnus-tm-lisp-directory (concat gnus-emacs-lisp-directory
+				       "site-lisp/")
+  "Directory where TM Emacs lisp is found.")
+
+(defvar gnus-mailcrypt-lisp-directory (concat gnus-emacs-lisp-directory
+					      "site-lisp/mailcrypt-3.4/")
+  "Directory where Mailcrypt Emacs Lisp is found.")
+
+(defvar gnus-bbdb-lisp-directory (concat gnus-emacs-lisp-directory
+					 "site-lisp/bbdb-1.51/")
+  "Directory where Big Brother Database is found.")
+
+(defvar gnus-use-tm running-xemacs
+  "Set this if you want MIME support for Gnus")
+(defvar gnus-use-mhe nil
+  "Set this if you want to use MH-E for mail reading")
+(defvar gnus-use-rmail nil
+  "Set this if you want to use RMAIL for mail reading")
+(defvar gnus-use-sendmail t
+  "Set this if you want to use SENDMAIL for mail reading")
+(defvar gnus-use-vm nil
+  "Set this if you want to use the VM package for mail reading")
+(defvar gnus-use-sc nil
+  "Set this if you want to use Supercite")
+(defvar gnus-use-mailcrypt t
+  "Set this if you want to use Mailcrypt for dealing with PGP messages")
+(defvar gnus-use-bbdb nil
+  "Set this if you want to use the Big Brother DataBase")
+
+(when (and (not gnus-use-installed-gnus)
+	   (null (member gnus-gnus-lisp-directory load-path)))
+  (push gnus-gnus-lisp-directory load-path))
+
+;;; We can't do this until we know where Gnus is.
+(require 'message)
+
+;;; Tools for MIME by
+;;; UMEDA Masanobu <umerin@mse.kyutech.ac.jp>
+;;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+
+(when gnus-use-tm
+  (when (and (not gnus-use-installed-tm)
+	     (null (member gnus-tm-lisp-directory load-path)))
+    (setq load-path (cons gnus-tm-lisp-directory load-path)))
+  ;; tm may or may not be dumped with XEmacs.  In Sunpro it is, otherwise
+  ;; it isn't.
+  (unless (featurep 'mime-setup)
+    (load "mime-setup")))
+
+;;; Mailcrypt by
+;;; Jin Choi <jin@atype.com>
+;;; Patrick LoPresti <patl@lcs.mit.edu>
+
+(when gnus-use-mailcrypt
+  (when (and (not gnus-use-installed-mailcrypt)
+	     (null (member gnus-mailcrypt-lisp-directory load-path)))
+    (setq load-path (cons gnus-mailcrypt-lisp-directory load-path)))
+  (autoload 'mc-install-write-mode "mailcrypt" nil t)
+  (autoload 'mc-install-read-mode "mailcrypt" nil t)
+  (add-hook 'message-mode-hook 'mc-install-write-mode)
+  (add-hook 'gnus-summary-mode-hook 'mc-install-read-mode)
+  (when gnus-use-mhe
+    (add-hook 'mh-folder-mode-hook 'mc-install-read-mode)
+    (add-hook 'mh-letter-mode-hook 'mc-install-write-mode)))
+
+;;; BBDB by
+;;; Jamie Zawinski <jwz@lucid.com>
+
+(when gnus-use-bbdb
+  ;; bbdb will never be installed with emacs.
+  (when (null (member gnus-bbdb-lisp-directory load-path))
+    (setq load-path (cons gnus-bbdb-lisp-directory load-path)))
+  (autoload 'bbdb "bbdb-com"
+    "Insidious Big Brother Database" t)
+  (autoload 'bbdb-name "bbdb-com"
+    "Insidious Big Brother Database" t)
+  (autoload 'bbdb-company "bbdb-com"
+    "Insidious Big Brother Database" t)
+  (autoload 'bbdb-net "bbdb-com"
+    "Insidious Big Brother Database" t)
+  (autoload 'bbdb-notes "bbdb-com"
+    "Insidious Big Brother Database" t)
+
+  (when gnus-use-vm
+    (autoload 'bbdb-insinuate-vm "bbdb-vm"
+      "Hook BBDB into VM" t))
+
+  (when gnus-use-rmail
+    (autoload 'bbdb-insinuate-rmail "bbdb-rmail"
+      "Hook BBDB into RMAIL" t)
+    (add-hook 'rmail-mode-hook 'bbdb-insinuate-rmail))
+
+  (when gnus-use-mhe
+    (autoload 'bbdb-insinuate-mh "bbdb-mh"
+      "Hook BBDB into MH-E" t)
+    (add-hook 'mh-folder-mode-hook 'bbdb-insinuate-mh))
+
+  (autoload 'bbdb-insinuate-gnus "bbdb-gnus"
+    "Hook BBDB into Gnus" t)
+  (add-hook 'gnus-startup-hook 'bbdb-insinuate-gnus)
+
+  (when gnus-use-sendmail
+    (autoload 'bbdb-insinuate-sendmail "bbdb"
+      "Insidious Big Brother Database" t)
+    (add-hook 'mail-setup-hook 'bbdb-insinuate-sendmail)
+    (add-hook 'message-setup-hook 'bbdb-insinuate-sendmail)))
+
+(when gnus-use-sc
+  (add-hook 'mail-citation-hook 'sc-cite-original)
+  (setq message-cite-function 'sc-cite-original)
+  (autoload 'sc-cite-original "supercite"))
+
+;;;### (autoloads (gnus gnus-slave gnus-no-server) "gnus" "lisp/gnus.el" (12473 2137))
+;;; Generated autoloads from lisp/gnus.el
+
+;; Don't redo this if autoloads already exist
+(unless (fboundp 'gnus)
+  (autoload 'gnus-slave-no-server "gnus" "\
+Read network news as a slave without connecting to local server." t nil)
+
+  (autoload 'gnus-no-server "gnus" "\
+Read network news.
+If ARG is a positive number, Gnus will use that as the
+startup level.  If ARG is nil, Gnus will be started at level 2.
+If ARG is non-nil and not a positive number, Gnus will
+prompt the user for the name of an NNTP server to use.
+As opposed to `gnus', this command will not connect to the local server." t nil)
+
+  (autoload 'gnus-slave "gnus" "\
+Read news as a slave." t nil)
+
+  (autoload 'gnus "gnus" "\
+Read network news.
+If ARG is non-nil and a positive number, Gnus will use that as the
+startup level.  If ARG is non-nil and not a positive number, Gnus will
+prompt the user for the name of an NNTP server to use." t nil)
+
+;;;***
+
+;;; These have moved out of gnus.el into other files.
+;;; FIX FIX FIX: should other things be in gnus-setup? or these not in it?
+  (autoload 'gnus-update-format "gnus-spec" "\
+Update the format specification near point." t nil)
+
+  (autoload 'gnus-fetch-group "gnus-group" "\
+Start Gnus if necessary and enter GROUP.
+Returns whether the fetching was successful or not." t nil)
+
+  (defalias 'gnus-batch-kill 'gnus-batch-score)
+
+  (autoload 'gnus-batch-score "gnus-kill" "\
+Run batched scoring.
+Usage: emacs -batch -l gnus -f gnus-batch-score <newsgroups> ...
+Newsgroups is a list of strings in Bnews format.  If you want to score
+the comp hierarchy, you'd say \"comp.all\".  If you would not like to
+score the alt hierarchy, you'd say \"!alt.all\"." t nil))
+
+(provide 'gnus-setup)
+
+(run-hooks 'gnus-setup-load-hook)
+
+;;; gnus-setup.el ends here

lisp/gnus/gnus-soup.el

@@ -0,0 +1,565 @@
+;;; gnus-soup.el --- SOUP packet writing support for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
+;;	Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-art)
+(require 'message)
+(require 'gnus-start)
+(require 'gnus-range)
+
+;;; User Variables:
+
+(defvar gnus-soup-directory (nnheader-concat gnus-home-directory "SoupBrew/")
+  "*Directory containing an unpacked SOUP packet.")
+
+(defvar gnus-soup-replies-directory
+  (nnheader-concat gnus-soup-directory "SoupReplies/")
+  "*Directory where Gnus will do processing of replies.")
+
+(defvar gnus-soup-prefix-file "gnus-prefix"
+  "*Name of the file where Gnus stores the last used prefix.")
+
+(defvar gnus-soup-packer "tar cf - %s | gzip > $HOME/Soupout%d.tgz"
+  "Format string command for packing a SOUP packet.
+The SOUP files will be inserted where the %s is in the string.
+This string MUST contain both %s and %d.  The file number will be
+inserted where %d appears.")
+
+(defvar gnus-soup-unpacker "gunzip -c %s | tar xvf -"
+  "*Format string command for unpacking a SOUP packet.
+The SOUP packet file name will be inserted at the %s.")
+
+(defvar gnus-soup-packet-directory gnus-home-directory
+  "*Where gnus-soup will look for REPLIES packets.")
+
+(defvar gnus-soup-packet-regexp "Soupin"
+  "*Regular expression matching SOUP REPLIES packets in `gnus-soup-packet-directory'.")
+
+(defvar gnus-soup-ignored-headers "^Xref:"
+  "*Regexp to match headers to be removed when brewing SOUP packets.")
+
+;;; Internal Variables:
+
+(defvar gnus-soup-encoding-type ?n
+  "*Soup encoding type.
+`n' is news format, `m' is Unix mbox format, and `M' is MMDF mailbox
+format.")
+
+(defvar gnus-soup-index-type ?c
+  "*Soup index type.
+`n' means no index file and `c' means standard Cnews overview
+format.")
+
+(defvar gnus-soup-areas nil)
+(defvar gnus-soup-last-prefix nil)
+(defvar gnus-soup-prev-prefix nil)
+(defvar gnus-soup-buffers nil)
+
+;;; Access macros:
+
+(defmacro gnus-soup-area-prefix (area)
+  `(aref ,area 0))
+(defmacro gnus-soup-set-area-prefix (area prefix)
+  `(aset ,area 0 ,prefix))
+(defmacro gnus-soup-area-name (area)
+  `(aref ,area 1))
+(defmacro gnus-soup-area-encoding (area)
+  `(aref ,area 2))
+(defmacro gnus-soup-area-description (area)
+  `(aref ,area 3))
+(defmacro gnus-soup-area-number (area)
+  `(aref ,area 4))
+(defmacro gnus-soup-area-set-number (area value)
+  `(aset ,area 4 ,value))
+
+(defmacro gnus-soup-encoding-format (encoding)
+  `(aref ,encoding 0))
+(defmacro gnus-soup-encoding-index (encoding)
+  `(aref ,encoding 1))
+(defmacro gnus-soup-encoding-kind (encoding)
+  `(aref ,encoding 2))
+
+(defmacro gnus-soup-reply-prefix (reply)
+  `(aref ,reply 0))
+(defmacro gnus-soup-reply-kind (reply)
+  `(aref ,reply 1))
+(defmacro gnus-soup-reply-encoding (reply)
+  `(aref ,reply 2))
+
+;;; Commands:
+
+(defun gnus-soup-send-replies ()
+  "Unpack and send all replies in the reply packet."
+  (interactive)
+  (let ((packets (directory-files
+		  gnus-soup-packet-directory t gnus-soup-packet-regexp)))
+    (while packets
+      (when (gnus-soup-send-packet (car packets))
+	(delete-file (car packets)))
+      (setq packets (cdr packets)))))
+
+(defun gnus-soup-add-article (n)
+  "Add the current article to SOUP packet.
+If N is a positive number, add the N next articles.
+If N is a negative number, add the N previous articles.
+If N is nil and any articles have been marked with the process mark,
+move those articles instead."
+  (interactive "P")
+  (gnus-set-global-variables)
+  (let* ((articles (gnus-summary-work-articles n))
+	 (tmp-buf (get-buffer-create "*soup work*"))
+	 (area (gnus-soup-area gnus-newsgroup-name))
+	 (prefix (gnus-soup-area-prefix area))
+	 headers)
+    (buffer-disable-undo tmp-buf)
+    (save-excursion
+      (while articles
+	;; Find the header of the article.
+	(set-buffer gnus-summary-buffer)
+	(when (setq headers (gnus-summary-article-header (car articles)))
+	  ;; Put the article in a buffer.
+	  (set-buffer tmp-buf)
+	  (when (gnus-request-article-this-buffer
+		 (car articles) gnus-newsgroup-name)
+	    (save-restriction
+	      (message-narrow-to-head)
+	      (message-remove-header gnus-soup-ignored-headers t))
+	    (gnus-soup-store gnus-soup-directory prefix headers
+			     gnus-soup-encoding-type
+			     gnus-soup-index-type)
+	    (gnus-soup-area-set-number
+	     area (1+ (or (gnus-soup-area-number area) 0)))))
+	;; Mark article as read.
+	(set-buffer gnus-summary-buffer)
+	(gnus-summary-remove-process-mark (car articles))
+	(gnus-summary-mark-as-read (car articles) gnus-souped-mark)
+	(setq articles (cdr articles)))
+      (kill-buffer tmp-buf))
+    (gnus-soup-save-areas)))
+
+(defun gnus-soup-pack-packet ()
+  "Make a SOUP packet from the SOUP areas."
+  (interactive)
+  (gnus-soup-read-areas)
+  (unless (file-exists-p gnus-soup-directory)
+    (message "No such directory: %s" gnus-soup-directory))
+  (when (null (directory-files gnus-soup-directory nil "\\.MSG$"))
+    (message "No files to pack."))
+  (gnus-soup-pack gnus-soup-directory gnus-soup-packer))
+
+(defun gnus-group-brew-soup (n)
+  "Make a soup packet from the current group.
+Uses the process/prefix convention."
+  (interactive "P")
+  (let ((groups (gnus-group-process-prefix n)))
+    (while groups
+      (gnus-group-remove-mark (car groups))
+      (gnus-soup-group-brew (car groups) t)
+      (setq groups (cdr groups)))
+    (gnus-soup-save-areas)))
+
+(defun gnus-brew-soup (&optional level)
+  "Go through all groups on LEVEL or less and make a soup packet."
+  (interactive "P")
+  (let ((level (or level gnus-level-subscribed))
+	(newsrc (cdr gnus-newsrc-alist)))
+    (while newsrc
+      (when (<= (nth 1 (car newsrc)) level)
+	(gnus-soup-group-brew (caar newsrc) t))
+      (setq newsrc (cdr newsrc)))
+    (gnus-soup-save-areas)))
+
+;;;###autoload
+(defun gnus-batch-brew-soup ()
+  "Brew a SOUP packet from groups mention on the command line.
+Will use the remaining command line arguments as regular expressions
+for matching on group names.
+
+For instance, if you want to brew on all the nnml groups, as well as
+groups with \"emacs\" in the name, you could say something like:
+
+$ emacs -batch -f gnus-batch-brew-soup ^nnml \".*emacs.*\""
+  (interactive)
+  nil)
+
+;;; Internal Functions:
+
+;; Store the current buffer.
+(defun gnus-soup-store (directory prefix headers format index)
+  ;; Create the directory, if needed.
+  (gnus-make-directory directory)
+  (let* ((msg-buf (nnheader-find-file-noselect
+		   (concat directory prefix ".MSG")))
+	 (idx-buf (if (= index ?n)
+		      nil
+		    (nnheader-find-file-noselect
+		     (concat directory prefix ".IDX"))))
+	 (article-buf (current-buffer))
+	 from head-line beg type)
+    (setq gnus-soup-buffers (cons msg-buf (delq msg-buf gnus-soup-buffers)))
+    (buffer-disable-undo msg-buf)
+    (when idx-buf
+      (push idx-buf gnus-soup-buffers)
+      (buffer-disable-undo idx-buf))
+    (save-excursion
+      ;; Make sure the last char in the buffer is a newline.
+      (goto-char (point-max))
+      (unless (= (current-column) 0)
+	(insert "\n"))
+      ;; Find the "from".
+      (goto-char (point-min))
+      (setq from
+	    (gnus-mail-strip-quoted-names
+	     (or (mail-fetch-field "from")
+		 (mail-fetch-field "really-from")
+		 (mail-fetch-field "sender"))))
+      (goto-char (point-min))
+      ;; Depending on what encoding is supposed to be used, we make
+      ;; a soup header.
+      (setq head-line
+	    (cond
+	     ((= gnus-soup-encoding-type ?n)
+	      (format "#! rnews %d\n" (buffer-size)))
+	     ((= gnus-soup-encoding-type ?m)
+	      (while (search-forward "\nFrom " nil t)
+		(replace-match "\n>From " t t))
+	      (concat "From " (or from "unknown")
+		      " " (current-time-string) "\n"))
+	     ((= gnus-soup-encoding-type ?M)
+	      "\^a\^a\^a\^a\n")
+	     (t (error "Unsupported type: %c" gnus-soup-encoding-type))))
+      ;; Insert the soup header and the article in the MSG buf.
+      (set-buffer msg-buf)
+      (goto-char (point-max))
+      (insert head-line)
+      (setq beg (point))
+      (insert-buffer-substring article-buf)
+      ;; Insert the index in the IDX buf.
+      (cond ((= index ?c)
+	     (set-buffer idx-buf)
+	     (gnus-soup-insert-idx beg headers))
+	    ((/= index ?n)
+	     (error "Unknown index type: %c" type)))
+      ;; Return the MSG buf.
+      msg-buf)))
+
+(defun gnus-soup-group-brew (group &optional not-all)
+  "Enter GROUP and add all articles to a SOUP package.
+If NOT-ALL, don't pack ticked articles."
+  (let ((gnus-expert-user t)
+	(gnus-large-newsgroup nil)
+	(entry (gnus-gethash group gnus-newsrc-hashtb)))
+    (when (or (null entry)
+	      (eq (car entry) t)
+	      (and (car entry)
+		   (> (car entry) 0))
+	      (and (not not-all)
+		   (gnus-range-length (cdr (assq 'tick (gnus-info-marks
+							(nth 2 entry)))))))
+      (when (gnus-summary-read-group group nil t)
+	(setq gnus-newsgroup-processable
+	      (reverse
+	       (if (not not-all)
+		   (append gnus-newsgroup-marked gnus-newsgroup-unreads)
+		 gnus-newsgroup-unreads)))
+	(gnus-soup-add-article nil)
+	(gnus-summary-exit)))))
+
+(defun gnus-soup-insert-idx (offset header)
+  ;; [number subject from date id references chars lines xref]
+  (goto-char (point-max))
+  (insert
+   (format "%d\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t\t\n"
+	   offset
+	   (or (mail-header-subject header) "(none)")
+	   (or (mail-header-from header) "(nobody)")
+	   (or (mail-header-date header) "")
+	   (or (mail-header-id header)
+	       (concat "soup-dummy-id-"
+		       (mapconcat
+			(lambda (time) (int-to-string time))
+			(current-time) "-")))
+	   (or (mail-header-references header) "")
+	   (or (mail-header-chars header) 0)
+	   (or (mail-header-lines header) "0"))))
+
+(defun gnus-soup-save-areas ()
+  (gnus-soup-write-areas)
+  (save-excursion
+    (let (buf)
+      (while gnus-soup-buffers
+	(setq buf (car gnus-soup-buffers)
+	      gnus-soup-buffers (cdr gnus-soup-buffers))
+	(if (not (buffer-name buf))
+	    ()
+	  (set-buffer buf)
+	  (when (buffer-modified-p)
+	    (save-buffer))
+	  (kill-buffer (current-buffer)))))
+    (gnus-soup-write-prefixes)))
+
+(defun gnus-soup-write-prefixes ()
+  (let ((prefixes gnus-soup-last-prefix)
+	prefix)
+    (save-excursion
+      (gnus-set-work-buffer)
+      (while (setq prefix (pop prefixes))
+	(erase-buffer)
+	(insert (format "(setq gnus-soup-prev-prefix %d)\n" (cdr prefix)))
+	(gnus-write-buffer (concat (car prefix) gnus-soup-prefix-file))))))
+
+(defun gnus-soup-pack (dir packer)
+  (let* ((files (mapconcat 'identity
+			   '("AREAS" "*.MSG" "*.IDX" "INFO"
+			     "LIST" "REPLIES" "COMMANDS" "ERRORS")
+			   " "))
+	 (packer (if (< (string-match "%s" packer)
+			(string-match "%d" packer))
+		     (format packer files
+			     (string-to-int (gnus-soup-unique-prefix dir)))
+		   (format packer
+			   (string-to-int (gnus-soup-unique-prefix dir))
+			   files)))
+	 (dir (expand-file-name dir)))
+    (gnus-make-directory dir)
+    (setq gnus-soup-areas nil)
+    (gnus-message 4 "Packing %s..." packer)
+    (if (zerop (call-process shell-file-name
+			     nil nil nil shell-command-switch
+			     (concat "cd " dir " ; " packer)))
+	(progn
+	  (call-process shell-file-name nil nil nil shell-command-switch
+			(concat "cd " dir " ; rm " files))
+	  (gnus-message 4 "Packing...done" packer))
+      (error "Couldn't pack packet."))))
+
+(defun gnus-soup-parse-areas (file)
+  "Parse soup area file FILE.
+The result is a of vectors, each containing one entry from the AREA file.
+The vector contain five strings,
+  [prefix name encoding description number]
+though the two last may be nil if they are missing."
+  (let (areas)
+    (save-excursion
+      (set-buffer (nnheader-find-file-noselect file 'force))
+      (buffer-disable-undo (current-buffer))
+      (goto-char (point-min))
+      (while (not (eobp))
+	(push (vector (gnus-soup-field)
+		      (gnus-soup-field)
+		      (gnus-soup-field)
+		      (and (eq (preceding-char) ?\t)
+			   (gnus-soup-field))
+		      (and (eq (preceding-char) ?\t)
+			   (string-to-int (gnus-soup-field))))
+	      areas)
+	(when (eq (preceding-char) ?\t)
+	  (beginning-of-line 2)))
+      (kill-buffer (current-buffer)))
+    areas))
+
+(defun gnus-soup-parse-replies (file)
+  "Parse soup REPLIES file FILE.
+The result is a of vectors, each containing one entry from the REPLIES
+file.  The vector contain three strings, [prefix name encoding]."
+  (let (replies)
+    (save-excursion
+      (set-buffer (nnheader-find-file-noselect file))
+      (buffer-disable-undo (current-buffer))
+      (goto-char (point-min))
+      (while (not (eobp))
+	(push (vector (gnus-soup-field) (gnus-soup-field)
+		      (gnus-soup-field))
+	      replies)
+	(when (eq (preceding-char) ?\t)
+	  (beginning-of-line 2)))
+      (kill-buffer (current-buffer)))
+    replies))
+
+(defun gnus-soup-field ()
+  (prog1
+      (buffer-substring (point) (progn (skip-chars-forward "^\t\n") (point)))
+    (forward-char 1)))
+
+(defun gnus-soup-read-areas ()
+  (or gnus-soup-areas
+      (setq gnus-soup-areas
+	    (gnus-soup-parse-areas (concat gnus-soup-directory "AREAS")))))
+
+(defun gnus-soup-write-areas ()
+  "Write the AREAS file."
+  (interactive)
+  (when gnus-soup-areas
+    (nnheader-temp-write (concat gnus-soup-directory "AREAS")
+      (let ((areas gnus-soup-areas)
+	    area)
+	(while (setq area (pop areas))
+	  (insert
+	   (format
+	    "%s\t%s\t%s%s\n"
+	    (gnus-soup-area-prefix area)
+	    (gnus-soup-area-name area)
+	    (gnus-soup-area-encoding area)
+	    (if (or (gnus-soup-area-description area)
+		    (gnus-soup-area-number area))
+		(concat "\t" (or (gnus-soup-area-description
+				  area) "")
+			(if (gnus-soup-area-number area)
+			    (concat "\t" (int-to-string
+					  (gnus-soup-area-number area)))
+			  "")) ""))))))))
+
+(defun gnus-soup-write-replies (dir areas)
+  "Write a REPLIES file in DIR containing AREAS."
+  (nnheader-temp-write (concat dir "REPLIES")
+    (let (area)
+      (while (setq area (pop areas))
+	(insert (format "%s\t%s\t%s\n"
+			(gnus-soup-reply-prefix area)
+			(gnus-soup-reply-kind area)
+			(gnus-soup-reply-encoding area)))))))
+
+(defun gnus-soup-area (group)
+  (gnus-soup-read-areas)
+  (let ((areas gnus-soup-areas)
+	(real-group (gnus-group-real-name group))
+	area result)
+    (while areas
+      (setq area (car areas)
+	    areas (cdr areas))
+      (when (equal (gnus-soup-area-name area) real-group)
+	(setq result area)))
+    (unless result
+      (setq result
+	    (vector (gnus-soup-unique-prefix)
+		    real-group
+		    (format "%c%c%c"
+			    gnus-soup-encoding-type
+			    gnus-soup-index-type
+			    (if (gnus-member-of-valid 'mail group) ?m ?n))
+		    nil nil)
+	    gnus-soup-areas (cons result gnus-soup-areas)))
+    result))
+
+(defun gnus-soup-unique-prefix (&optional dir)
+  (let* ((dir (file-name-as-directory (or dir gnus-soup-directory)))
+	 (entry (assoc dir gnus-soup-last-prefix))
+	 gnus-soup-prev-prefix)
+    (if entry
+	()
+      (when (file-exists-p (concat dir gnus-soup-prefix-file))
+	(ignore-errors
+	  (load (concat dir gnus-soup-prefix-file) nil t t)))
+      (push (setq entry (cons dir (or gnus-soup-prev-prefix 0)))
+	    gnus-soup-last-prefix))
+    (setcdr entry (1+ (cdr entry)))
+    (gnus-soup-write-prefixes)
+    (int-to-string (cdr entry))))
+
+(defun gnus-soup-unpack-packet (dir unpacker packet)
+  "Unpack PACKET into DIR using UNPACKER.
+Return whether the unpacking was successful."
+  (gnus-make-directory dir)
+  (gnus-message 4 "Unpacking: %s" (format unpacker packet))
+  (prog1
+      (zerop (call-process
+	      shell-file-name nil nil nil shell-command-switch
+	      (format "cd %s ; %s" (expand-file-name dir)
+		      (format unpacker packet))))
+    (gnus-message 4 "Unpacking...done")))
+
+(defun gnus-soup-send-packet (packet)
+  (gnus-soup-unpack-packet
+   gnus-soup-replies-directory gnus-soup-unpacker packet)
+  (let ((replies (gnus-soup-parse-replies
+		  (concat gnus-soup-replies-directory "REPLIES"))))
+    (save-excursion
+      (while replies
+	(let* ((msg-file (concat gnus-soup-replies-directory
+				 (gnus-soup-reply-prefix (car replies))
+				 ".MSG"))
+	       (msg-buf (and (file-exists-p msg-file)
+			     (nnheader-find-file-noselect msg-file)))
+	       (tmp-buf (get-buffer-create " *soup send*"))
+	       beg end)
+	  (cond
+	   ((/= (gnus-soup-encoding-format
+		 (gnus-soup-reply-encoding (car replies)))
+		?n)
+	    (error "Unsupported encoding"))
+	   ((null msg-buf)
+	    t)
+	   (t
+	    (buffer-disable-undo msg-buf)
+	    (buffer-disable-undo tmp-buf)
+	    (set-buffer msg-buf)
+	    (goto-char (point-min))
+	    (while (not (eobp))
+	      (unless (looking-at "#! *rnews +\\([0-9]+\\)")
+		(error "Bad header."))
+	      (forward-line 1)
+	      (setq beg (point)
+		    end (+ (point) (string-to-int
+				    (buffer-substring
+				     (match-beginning 1) (match-end 1)))))
+	      (switch-to-buffer tmp-buf)
+	      (erase-buffer)
+	      (insert-buffer-substring msg-buf beg end)
+	      (goto-char (point-min))
+	      (search-forward "\n\n")
+	      (forward-char -1)
+	      (insert mail-header-separator)
+	      (setq message-newsreader (setq message-mailer
+					     (gnus-extended-version)))
+	      (cond
+	       ((string= (gnus-soup-reply-kind (car replies)) "news")
+		(gnus-message 5 "Sending news message to %s..."
+			      (mail-fetch-field "newsgroups"))
+		(sit-for 1)
+		(let ((message-syntax-checks
+		       'dont-check-for-anything-just-trust-me))
+		  (funcall message-send-news-function)))
+	       ((string= (gnus-soup-reply-kind (car replies)) "mail")
+		(gnus-message 5 "Sending mail to %s..."
+			      (mail-fetch-field "to"))
+		(sit-for 1)
+		(message-send-mail))
+	       (t
+		(error "Unknown reply kind")))
+	      (set-buffer msg-buf)
+	      (goto-char end))
+	    (delete-file (buffer-file-name))
+	    (kill-buffer msg-buf)
+	    (kill-buffer tmp-buf)
+	    (gnus-message 4 "Sent packet"))))
+	(setq replies (cdr replies)))
+      t)))
+
+(provide 'gnus-soup)
+
+;;; gnus-soup.el ends here

lisp/gnus/gnus-spec.el

@@ -0,0 +1,528 @@
+;;; gnus-spec.el --- format spec functions for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+
+;;; Internal variables.
+
+(defvar gnus-summary-mark-positions nil)
+(defvar gnus-group-mark-positions nil)
+(defvar gnus-group-indentation "")
+
+;; Format specs.  The chunks below are the machine-generated forms
+;; that are to be evaled as the result of the default format strings.
+;; We write them in here to get them byte-compiled.  That way the
+;; default actions will be quite fast, while still retaining the full
+;; flexibility of the user-defined format specs.
+
+;; First we have lots of dummy defvars to let the compiler know these
+;; are really dynamic variables.
+
+(defvar gnus-tmp-unread)
+(defvar gnus-tmp-replied)
+(defvar gnus-tmp-score-char)
+(defvar gnus-tmp-indentation)
+(defvar gnus-tmp-opening-bracket)
+(defvar gnus-tmp-lines)
+(defvar gnus-tmp-name)
+(defvar gnus-tmp-closing-bracket)
+(defvar gnus-tmp-subject-or-nil)
+(defvar gnus-tmp-subject)
+(defvar gnus-tmp-marked)
+(defvar gnus-tmp-marked-mark)
+(defvar gnus-tmp-subscribed)
+(defvar gnus-tmp-process-marked)
+(defvar gnus-tmp-number-of-unread)
+(defvar gnus-tmp-group-name)
+(defvar gnus-tmp-group)
+(defvar gnus-tmp-article-number)
+(defvar gnus-tmp-unread-and-unselected)
+(defvar gnus-tmp-news-method)
+(defvar gnus-tmp-news-server)
+(defvar gnus-tmp-article-number)
+(defvar gnus-mouse-face)
+(defvar gnus-mouse-face-prop)
+
+(defun gnus-summary-line-format-spec ()
+  (insert gnus-tmp-unread gnus-tmp-replied
+	  gnus-tmp-score-char gnus-tmp-indentation)
+  (gnus-put-text-property
+   (point)
+   (progn
+     (insert
+      gnus-tmp-opening-bracket
+      (format "%4d: %-20s"
+	      gnus-tmp-lines
+	      (if (> (length gnus-tmp-name) 20)
+		  (substring gnus-tmp-name 0 20)
+		gnus-tmp-name))
+      gnus-tmp-closing-bracket)
+     (point))
+   gnus-mouse-face-prop gnus-mouse-face)
+  (insert " " gnus-tmp-subject-or-nil "\n"))
+
+(defvar gnus-summary-line-format-spec
+  (gnus-byte-code 'gnus-summary-line-format-spec))
+
+(defun gnus-summary-dummy-line-format-spec ()
+  (insert "*  ")
+  (gnus-put-text-property
+   (point)
+   (progn
+     (insert ":				 :")
+     (point))
+   gnus-mouse-face-prop gnus-mouse-face)
+  (insert " " gnus-tmp-subject "\n"))
+
+(defvar gnus-summary-dummy-line-format-spec
+  (gnus-byte-code 'gnus-summary-dummy-line-format-spec))
+
+(defun gnus-group-line-format-spec ()
+  (insert gnus-tmp-marked-mark gnus-tmp-subscribed
+	  gnus-tmp-process-marked
+	  gnus-group-indentation
+	  (format "%5s: " gnus-tmp-number-of-unread))
+  (gnus-put-text-property
+   (point)
+   (progn
+     (insert gnus-tmp-group "\n")
+     (1- (point)))
+   gnus-mouse-face-prop gnus-mouse-face))
+(defvar gnus-group-line-format-spec
+  (gnus-byte-code 'gnus-group-line-format-spec))
+
+(defvar gnus-format-specs
+  `((version . ,emacs-version)
+    (group "%M\%S\%p\%P\%5y: %(%g%)%l\n" ,gnus-group-line-format-spec)
+    (summary-dummy "*  %(:                          :%) %S\n"
+		   ,gnus-summary-dummy-line-format-spec)
+    (summary "%U\%R\%z\%I\%(%[%4L: %-20,20n%]%) %s\n"
+	     ,gnus-summary-line-format-spec))
+  "Alist of format specs.")
+
+(defvar gnus-article-mode-line-format-spec nil)
+(defvar gnus-summary-mode-line-format-spec nil)
+(defvar gnus-group-mode-line-format-spec nil)
+
+;;; Phew.  All that gruft is over, fortunately.
+
+;;;###autoload
+(defun gnus-update-format (var)
+  "Update the format specification near point."
+  (interactive
+   (list
+    (save-excursion
+      (eval-defun nil)
+      ;; Find the end of the current word.
+      (re-search-forward "[ \t\n]" nil t)
+      ;; Search backward.
+      (when (re-search-backward "\\(gnus-[-a-z]+-line-format\\)" nil t)
+	(match-string 1)))))
+  (let* ((type (intern (progn (string-match "gnus-\\([-a-z]+\\)-line" var)
+			      (match-string 1 var))))
+	 (entry (assq type gnus-format-specs))
+	 value spec)
+    (when entry
+      (setq gnus-format-specs (delq entry gnus-format-specs)))
+    (set
+     (intern (format "%s-spec" var))
+     (gnus-parse-format (setq value (symbol-value (intern var)))
+			(symbol-value (intern (format "%s-alist" var)))
+			(not (string-match "mode" var))))
+    (setq spec (symbol-value (intern (format "%s-spec" var))))
+    (push (list type value spec) gnus-format-specs)
+
+    (pop-to-buffer "*Gnus Format*")
+    (erase-buffer)
+    (lisp-interaction-mode)
+    (insert (pp-to-string spec))))
+
+(defun gnus-update-format-specifications (&optional force &rest types)
+  "Update all (necessary) format specifications."
+  ;; Make the indentation array.
+  ;; See whether all the stored info needs to be flushed.
+  (when (or force
+	    (not (equal emacs-version
+			(cdr (assq 'version gnus-format-specs)))))
+    (setq gnus-format-specs nil))
+
+  ;; Go through all the formats and see whether they need updating.
+  (let (new-format entry type val)
+    (while (setq type (pop types))
+      ;; Jump to the proper buffer to find out the value of
+      ;; the variable, if possible.  (It may be buffer-local.)
+      (save-excursion
+	(let ((buffer (intern (format "gnus-%s-buffer" type)))
+	      val)
+	  (when (and (boundp buffer)
+		     (setq val (symbol-value buffer))
+		     (get-buffer val)
+		     (buffer-name (get-buffer val)))
+	    (set-buffer (get-buffer val)))
+	  (setq new-format (symbol-value
+			    (intern (format "gnus-%s-line-format" type)))))
+	(setq entry (cdr (assq type gnus-format-specs)))
+	(if (and (car entry)
+		 (equal (car entry) new-format))
+	    ;; Use the old format.
+	    (set (intern (format "gnus-%s-line-format-spec" type))
+		 (cadr entry))
+	  ;; This is a new format.
+	  (setq val
+		(if (not (stringp new-format))
+		    ;; This is a function call or something.
+		    new-format
+		  ;; This is a "real" format.
+		  (gnus-parse-format
+		   new-format
+		   (symbol-value
+		    (intern (format "gnus-%s-line-format-alist"
+				    (if (eq type 'article-mode)
+					'summary-mode type))))
+		   (not (string-match "mode$" (symbol-name type))))))
+	  ;; Enter the new format spec into the list.
+	  (if entry
+	      (progn
+		(setcar (cdr entry) val)
+		(setcar entry new-format))
+	    (push (list type new-format val) gnus-format-specs))
+	  (set (intern (format "gnus-%s-line-format-spec" type)) val)))))
+
+  (unless (assq 'version gnus-format-specs)
+    (push (cons 'version emacs-version) gnus-format-specs)))
+
+(defvar gnus-mouse-face-0 'highlight)
+(defvar gnus-mouse-face-1 'highlight)
+(defvar gnus-mouse-face-2 'highlight)
+(defvar gnus-mouse-face-3 'highlight)
+(defvar gnus-mouse-face-4 'highlight)
+
+(defun gnus-mouse-face-function (form type)
+  `(gnus-put-text-property
+    (point) (progn ,@form (point))
+    gnus-mouse-face-prop
+    ,(if (equal type 0)
+	 'gnus-mouse-face
+       `(quote ,(symbol-value (intern (format "gnus-mouse-face-%d" type)))))))
+
+(defvar gnus-face-0 'bold)
+(defvar gnus-face-1 'italic)
+(defvar gnus-face-2 'bold-italic)
+(defvar gnus-face-3 'bold)
+(defvar gnus-face-4 'bold)
+
+(defun gnus-face-face-function (form type)
+  `(gnus-put-text-property
+    (point) (progn ,@form (point))
+    'face ',(symbol-value (intern (format "gnus-face-%d" type)))))
+
+(defun gnus-tilde-max-form (el max-width)
+  "Return a form that limits EL to MAX-WIDTH."
+  (let ((max (abs max-width)))
+    (if (symbolp el)
+	`(if (> (length ,el) ,max)
+	     ,(if (< max-width 0)
+		  `(substring ,el (- (length el) ,max))
+		`(substring ,el 0 ,max))
+	   ,el)
+      `(let ((val (eval ,el)))
+	 (if (> (length val) ,max)
+	     ,(if (< max-width 0)
+		  `(substring val (- (length val) ,max))
+		`(substring val 0 ,max))
+	   val)))))
+
+(defun gnus-tilde-cut-form (el cut-width)
+  "Return a form that cuts CUT-WIDTH off of EL."
+  (let ((cut (abs cut-width)))
+    (if (symbolp el)
+	`(if (> (length ,el) ,cut)
+	     ,(if (< cut-width 0)
+		  `(substring ,el 0 (- (length el) ,cut))
+		`(substring ,el ,cut))
+	   ,el)
+      `(let ((val (eval ,el)))
+	 (if (> (length val) ,cut)
+	     ,(if (< cut-width 0)
+		  `(substring val 0 (- (length val) ,cut))
+		`(substring val ,cut))
+	   val)))))
+
+(defun gnus-tilde-ignore-form (el ignore-value)
+  "Return a form that is blank when EL is IGNORE-VALUE."
+  (if (symbolp el)
+      `(if (equal ,el ,ignore-value)
+	   "" ,el)
+    `(let ((val (eval ,el)))
+       (if (equal val ,ignore-value)
+	   "" val))))
+
+(defun gnus-parse-format (format spec-alist &optional insert)
+  ;; This function parses the FORMAT string with the help of the
+  ;; SPEC-ALIST and returns a list that can be eval'ed to return the
+  ;; string.  If the FORMAT string contains the specifiers %( and %)
+  ;; the text between them will have the mouse-face text property.
+  (if (string-match
+       "\\`\\(.*\\)%[0-9]?[{(]\\(.*\\)%[0-9]?[})]\\(.*\n?\\)\\'"
+       format)
+      (gnus-parse-complex-format format spec-alist)
+    ;; This is a simple format.
+    (gnus-parse-simple-format format spec-alist insert)))
+
+(defun gnus-parse-complex-format (format spec-alist)
+  (save-excursion
+    (gnus-set-work-buffer)
+    (insert format)
+    (goto-char (point-min))
+    (while (re-search-forward "\"" nil t)
+      (replace-match "\\\"" nil t))
+    (goto-char (point-min))
+    (insert "(\"")
+    (while (re-search-forward "%\\([0-9]+\\)?\\([{}()]\\)" nil t)
+      (let ((number (if (match-beginning 1)
+			(match-string 1) "0"))
+	    (delim (aref (match-string 2) 0)))
+	(if (or (= delim ?\() (= delim ?\{))
+	    (replace-match (concat "\"(" (if (= delim ?\() "mouse" "face")
+				   " " number " \""))
+	  (replace-match "\")\""))))
+    (goto-char (point-max))
+    (insert "\")")
+    (goto-char (point-min))
+    (let ((form (read (current-buffer))))
+      (cons 'progn (gnus-complex-form-to-spec form spec-alist)))))
+
+(defun gnus-complex-form-to-spec (form spec-alist)
+  (delq nil
+	(mapcar
+	 (lambda (sform)
+	   (if (stringp sform)
+	       (gnus-parse-simple-format sform spec-alist t)
+	     (funcall (intern (format "gnus-%s-face-function" (car sform)))
+		      (gnus-complex-form-to-spec (cddr sform) spec-alist)
+		      (nth 1 sform))))
+	 form)))
+
+(defun gnus-parse-simple-format (format spec-alist &optional insert)
+  ;; This function parses the FORMAT string with the help of the
+  ;; SPEC-ALIST and returns a list that can be eval'ed to return a
+  ;; string.
+  (let ((max-width 0)
+	spec flist fstring elem result dontinsert user-defined
+	type value pad-width spec-beg cut-width ignore-value
+	tilde-form tilde elem-type)
+    (save-excursion
+      (gnus-set-work-buffer)
+      (insert format)
+      (goto-char (point-min))
+      (while (re-search-forward "%" nil t)
+	(setq user-defined nil
+	      spec-beg nil
+	      pad-width nil
+	      max-width nil
+	      cut-width nil
+	      ignore-value nil
+	      tilde-form nil)
+	(setq spec-beg (1- (point)))
+
+	;; Parse this spec fully.
+	(while
+	    (cond
+	     ((looking-at "\\([-.0-9]+\\)\\(,[-0-9]+\\)?")
+	      (setq pad-width (string-to-number (match-string 1)))
+	      (when (match-beginning 2)
+		(setq max-width (string-to-number (buffer-substring
+						   (1+ (match-beginning 2))
+						   (match-end 2)))))
+	      (goto-char (match-end 0)))
+	     ((looking-at "~")
+	      (forward-char 1)
+	      (setq tilde (read (current-buffer))
+		    type (car tilde)
+		    value (cadr tilde))
+	      (cond
+	       ((memq type '(pad pad-left))
+		(setq pad-width value))
+	       ((eq type 'pad-right)
+		(setq pad-width (- value)))
+	       ((memq type '(max-right max))
+		(setq max-width value))
+	       ((eq type 'max-left)
+		(setq max-width (- value)))
+	       ((memq type '(cut cut-left))
+		(setq cut-width value))
+	       ((eq type 'cut-right)
+		(setq cut-width (- value)))
+	       ((eq type 'ignore)
+		(setq ignore-value
+		      (if (stringp value) value (format "%s" value))))
+	       ((eq type 'form)
+		(setq tilde-form value))
+	       (t
+		(error "Unknown tilde type: %s" tilde)))
+	      t)
+	     (t
+	      nil)))
+	;; User-defined spec -- find the spec name.
+	(when (= (setq spec (following-char)) ?u)
+	  (forward-char 1)
+	  (setq user-defined (following-char)))
+	(forward-char 1)
+	(delete-region spec-beg (point))
+
+	;; Now we have all the relevant data on this spec, so
+	;; we start doing stuff.
+	(insert "%")
+	(if (eq spec ?%)
+	    ;; "%%" just results in a "%".
+	    (insert "%")
+	  (cond
+	   ;; Do tilde forms.
+	   ((eq spec ?@)
+	    (setq elem (list tilde-form ?s)))
+	   ;; Treat user defined format specifiers specially.
+	   (user-defined
+	    (setq elem
+		  (list
+		   (list (intern (format "gnus-user-format-function-%c"
+					 user-defined))
+			 'gnus-tmp-header)
+		   ?s)))
+	   ;; Find the specification from `spec-alist'.
+	   ((setq elem (cdr (assq spec spec-alist))))
+	   (t
+	    (setq elem '("*" ?s))))
+	  (setq elem-type (cadr elem))
+	  ;; Insert the new format elements.
+	  (when pad-width
+	    (insert (number-to-string pad-width)))
+	  ;; Create the form to be evaled.
+	  (if (or max-width cut-width ignore-value)
+	      (progn
+		(insert ?s)
+		(let ((el (car elem)))
+		  (cond ((= (cadr elem) ?c)
+			 (setq el (list 'char-to-string el)))
+			((= (cadr elem) ?d)
+			 (setq el (list 'int-to-string el))))
+		  (when ignore-value
+		    (setq el (gnus-tilde-ignore-form el ignore-value)))
+		  (when cut-width
+		    (setq el (gnus-tilde-cut-form el cut-width)))
+		  (when max-width
+		    (setq el (gnus-tilde-max-form el max-width)))
+		  (push el flist)))
+	    (insert elem-type)
+	    (push (car elem) flist))))
+      (setq fstring (buffer-string)))
+
+    ;; Do some postprocessing to increase efficiency.
+    (setq
+     result
+     (cond
+      ;; Emptyness.
+      ((string= fstring "")
+       nil)
+      ;; Not a format string.
+      ((not (string-match "%" fstring))
+       (list fstring))
+      ;; A format string with just a single string spec.
+      ((string= fstring "%s")
+       (list (car flist)))
+      ;; A single character.
+      ((string= fstring "%c")
+       (list (car flist)))
+      ;; A single number.
+      ((string= fstring "%d")
+       (setq dontinsert)
+       (if insert
+	   (list `(princ ,(car flist)))
+	 (list `(int-to-string ,(car flist)))))
+      ;; Just lots of chars and strings.
+      ((string-match "\\`\\(%[cs]\\)+\\'" fstring)
+       (nreverse flist))
+      ;; A single string spec at the beginning of the spec.
+      ((string-match "\\`%[sc][^%]+\\'" fstring)
+       (list (car flist) (substring fstring 2)))
+      ;; A single string spec in the middle of the spec.
+      ((string-match "\\`\\([^%]+\\)%[sc]\\([^%]+\\)\\'" fstring)
+       (list (match-string 1 fstring) (car flist) (match-string 2 fstring)))
+      ;; A single string spec in the end of the spec.
+      ((string-match "\\`\\([^%]+\\)%[sc]\\'" fstring)
+       (list (match-string 1 fstring) (car flist)))
+      ;; A more complex spec.
+      (t
+       (list (cons 'format (cons fstring (nreverse flist)))))))
+
+    (if insert
+	(when result
+	  (if dontinsert
+	      result
+	    (cons 'insert result)))
+      (cond ((stringp result)
+	     result)
+	    ((consp result)
+	     (cons 'concat result))
+	    (t "")))))
+
+(defun gnus-eval-format (format &optional alist props)
+  "Eval the format variable FORMAT, using ALIST.
+If PROPS, insert the result."
+  (let ((form (gnus-parse-format format alist props)))
+    (if props
+	(gnus-add-text-properties (point) (progn (eval form) (point)) props)
+      (eval form))))
+
+(defun gnus-compile ()
+  "Byte-compile the user-defined format specs."
+  (interactive)
+  (when gnus-xemacs
+    (error "Can't compile specs under XEmacs"))
+  (let ((entries gnus-format-specs)
+	(byte-compile-warnings '(unresolved callargs redefine))
+	entry gnus-tmp-func)
+    (save-excursion
+      (gnus-message 7 "Compiling format specs...")
+
+      (while entries
+	(setq entry (pop entries))
+	(if (eq (car entry) 'version)
+	    (setq gnus-format-specs (delq entry gnus-format-specs))
+	  (when (and (listp (caddr entry))
+		     (not (eq 'byte-code (caaddr entry))))
+	    (fset 'gnus-tmp-func `(lambda () ,(caddr entry)))
+	    (byte-compile 'gnus-tmp-func)
+	    (setcar (cddr entry) (gnus-byte-code 'gnus-tmp-func)))))
+
+      (push (cons 'version emacs-version) gnus-format-specs)
+      ;; Mark the .newsrc.eld file as "dirty".
+      (gnus-dribble-enter " ")
+      (gnus-message 7 "Compiling user specs...done"))))
+
+(provide 'gnus-spec)
+
+;;; gnus-spec.el ends here

lisp/gnus/gnus-srvr.el

@@ -0,0 +1,752 @@
+;;; gnus-srvr.el --- virtual server support for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-spec)
+(require 'gnus-group)
+(require 'gnus-int)
+(require 'gnus-range)
+
+(defvar gnus-server-mode-hook nil
+  "Hook run in `gnus-server-mode' buffers.")
+
+(defconst gnus-server-line-format "     {%(%h:%w%)} %s\n"
+  "Format of server lines.
+It works along the same lines as a normal formatting string,
+with some simple extensions.")
+
+(defvar gnus-server-mode-line-format "Gnus  List of servers"
+  "The format specification for the server mode line.")
+
+(defvar gnus-server-exit-hook nil
+  "*Hook run when exiting the server buffer.")
+
+;;; Internal variables.
+
+(defvar gnus-inserted-opened-servers nil)
+
+(defvar gnus-server-line-format-alist
+  `((?h how ?s)
+    (?n name ?s)
+    (?w where ?s)
+    (?s status ?s)))
+
+(defvar gnus-server-mode-line-format-alist
+  `((?S news-server ?s)
+    (?M news-method ?s)
+    (?u user-defined ?s)))
+
+(defvar gnus-server-line-format-spec nil)
+(defvar gnus-server-mode-line-format-spec nil)
+(defvar gnus-server-killed-servers nil)
+
+(defvar gnus-server-mode-map)
+
+(defvar gnus-server-menu-hook nil
+  "*Hook run after the creation of the server mode menu.")
+
+(defun gnus-server-make-menu-bar ()
+  (gnus-turn-off-edit-menu 'server)
+  (unless (boundp 'gnus-server-server-menu)
+    (easy-menu-define
+     gnus-server-server-menu gnus-server-mode-map ""
+     '("Server"
+       ["Add" gnus-server-add-server t]
+       ["Browse" gnus-server-read-server t]
+       ["Scan" gnus-server-scan-server t]
+       ["List" gnus-server-list-servers t]
+       ["Kill" gnus-server-kill-server t]
+       ["Yank" gnus-server-yank-server t]
+       ["Copy" gnus-server-copy-server t]
+       ["Edit" gnus-server-edit-server t]
+       ["Regenerate" gnus-server-regenerate-server t]
+       ["Exit" gnus-server-exit t]))
+
+    (easy-menu-define
+     gnus-server-connections-menu gnus-server-mode-map ""
+     '("Connections"
+       ["Open" gnus-server-open-server t]
+       ["Close" gnus-server-close-server t]
+       ["Deny" gnus-server-deny-server t]
+       "---"
+       ["Open All" gnus-server-open-all-servers t]
+       ["Close All" gnus-server-close-all-servers t]
+       ["Reset All" gnus-server-remove-denials t]))
+
+    (run-hooks 'gnus-server-menu-hook)))
+
+(defvar gnus-server-mode-map nil)
+(put 'gnus-server-mode 'mode-class 'special)
+
+(unless gnus-server-mode-map
+  (setq gnus-server-mode-map (make-sparse-keymap))
+  (suppress-keymap gnus-server-mode-map)
+
+  (gnus-define-keys
+   gnus-server-mode-map
+   " " gnus-server-read-server
+   "\r" gnus-server-read-server
+   gnus-mouse-2 gnus-server-pick-server
+   "q" gnus-server-exit
+   "l" gnus-server-list-servers
+   "k" gnus-server-kill-server
+   "y" gnus-server-yank-server
+   "c" gnus-server-copy-server
+   "a" gnus-server-add-server
+   "e" gnus-server-edit-server
+   "s" gnus-server-scan-server
+
+   "O" gnus-server-open-server
+   "\M-o" gnus-server-open-all-servers
+   "C" gnus-server-close-server
+   "\M-c" gnus-server-close-all-servers
+   "D" gnus-server-deny-server
+   "R" gnus-server-remove-denials
+
+   "g" gnus-server-regenerate-server
+
+    "\C-c\C-i" gnus-info-find-node
+    "\C-c\C-b" gnus-bug))
+
+(defun gnus-server-mode ()
+  "Major mode for listing and editing servers.
+
+All normal editing commands are switched off.
+\\<gnus-server-mode-map>
+For more in-depth information on this mode, read the manual
+(`\\[gnus-info-find-node]').
+
+The following commands are available:
+
+\\{gnus-server-mode-map}"
+  (interactive)
+  (when (gnus-visual-p 'server-menu 'menu)
+    (gnus-server-make-menu-bar))
+  (kill-all-local-variables)
+  (gnus-simplify-mode-line)
+  (setq major-mode 'gnus-server-mode)
+  (setq mode-name "Server")
+  (gnus-set-default-directory)
+  (setq mode-line-process nil)
+  (use-local-map gnus-server-mode-map)
+  (buffer-disable-undo (current-buffer))
+  (setq truncate-lines t)
+  (setq buffer-read-only t)
+  (run-hooks 'gnus-server-mode-hook))
+
+(defun gnus-server-insert-server-line (name method)
+  (let* ((how (car method))
+	 (where (nth 1 method))
+	 (elem (assoc method gnus-opened-servers))
+	 (status (cond ((eq (nth 1 elem) 'denied)
+			"(denied)")
+		       ((or (gnus-server-opened method)
+			    (eq (nth 1 elem) 'ok))
+			"(opened)")
+		       (t
+			"(closed)"))))
+    (beginning-of-line)
+    (gnus-add-text-properties
+     (point)
+     (prog1 (1+ (point))
+       ;; Insert the text.
+       (eval gnus-server-line-format-spec))
+     (list 'gnus-server (intern name)))))
+
+(defun gnus-enter-server-buffer ()
+  "Set up the server buffer."
+  (gnus-server-setup-buffer)
+  (gnus-configure-windows 'server)
+  (gnus-server-prepare))
+
+(defun gnus-server-setup-buffer ()
+  "Initialize the server buffer."
+  (unless (get-buffer gnus-server-buffer)
+    (save-excursion
+      (set-buffer (get-buffer-create gnus-server-buffer))
+      (gnus-server-mode)
+      (when gnus-carpal
+	(gnus-carpal-setup-buffer 'server)))))
+
+(defun gnus-server-prepare ()
+  (setq gnus-server-mode-line-format-spec
+	(gnus-parse-format gnus-server-mode-line-format
+			   gnus-server-mode-line-format-alist))
+  (setq gnus-server-line-format-spec
+	(gnus-parse-format gnus-server-line-format
+			   gnus-server-line-format-alist t))
+  (let ((alist gnus-server-alist)
+	(buffer-read-only nil)
+	(opened gnus-opened-servers)
+	done server op-ser)
+    (erase-buffer)
+    (setq gnus-inserted-opened-servers nil)
+    ;; First we do the real list of servers.
+    (while alist
+      (unless (member (cdar alist) done)
+	(push (cdar alist) done)
+	(cdr (setq server (pop alist)))
+	(when (and server (car server) (cdr server))
+	  (gnus-server-insert-server-line (car server) (cdr server))))
+      (when (member (cdar alist) done)
+	(pop alist)))
+    ;; Then we insert the list of servers that have been opened in
+    ;; this session.
+    (while opened
+      (unless (member (caar opened) done)
+	(push (caar opened) done)
+	(gnus-server-insert-server-line
+	 (setq op-ser (format "%s:%s" (caaar opened) (nth 1 (caar opened))))
+	 (caar opened))
+	(push (list op-ser (caar opened)) gnus-inserted-opened-servers))
+      (setq opened (cdr opened))))
+  (goto-char (point-min))
+  (gnus-server-position-point))
+
+(defun gnus-server-server-name ()
+  (let ((server (get-text-property (gnus-point-at-bol) 'gnus-server)))
+    (and server (symbol-name server))))
+
+(defalias 'gnus-server-position-point 'gnus-goto-colon)
+
+(defconst gnus-server-edit-buffer "*Gnus edit server*")
+
+(defun gnus-server-update-server (server)
+  (save-excursion
+    (set-buffer gnus-server-buffer)
+    (let* ((buffer-read-only nil)
+	   (entry (assoc server gnus-server-alist))
+	   (oentry (assoc (gnus-server-to-method server)
+			  gnus-opened-servers)))
+      (when entry
+	(gnus-dribble-enter
+	 (concat "(gnus-server-set-info \"" server "\" '"
+		 (prin1-to-string (cdr entry)) ")\n")))
+      (when (or entry oentry)
+	;; Buffer may be narrowed.
+	(save-restriction
+	  (widen)
+	  (when (gnus-server-goto-server server)
+	    (gnus-delete-line))
+	  (if entry
+	      (gnus-server-insert-server-line (car entry) (cdr entry))
+	    (gnus-server-insert-server-line
+	     (format "%s:%s" (caar oentry) (nth 1 (car oentry)))
+	     (car oentry)))
+	  (gnus-server-position-point))))))
+
+(defun gnus-server-set-info (server info)
+  ;; Enter a select method into the virtual server alist.
+  (when (and server info)
+    (gnus-dribble-enter
+     (concat "(gnus-server-set-info \"" server "\" '"
+	     (prin1-to-string info) ")"))
+    (let* ((server (nth 1 info))
+	   (entry (assoc server gnus-server-alist)))
+      (if entry (setcdr entry info)
+	(setq gnus-server-alist
+	      (nconc gnus-server-alist (list (cons server info))))))))
+
+;;; Interactive server functions.
+
+(defun gnus-server-kill-server (server)
+  "Kill the server on the current line."
+  (interactive (list (gnus-server-server-name)))
+  (unless (gnus-server-goto-server server)
+    (if server (error "No such server: %s" server)
+      (error "No server on the current line")))
+  (unless (assoc server gnus-server-alist)
+    (error "Read-only server %s" server))
+  (gnus-dribble-enter "")
+  (let ((buffer-read-only nil))
+    (gnus-delete-line))
+  (push (assoc server gnus-server-alist) gnus-server-killed-servers)
+  (setq gnus-server-alist (delq (car gnus-server-killed-servers)
+				gnus-server-alist))
+  (gnus-server-position-point))
+
+(defun gnus-server-yank-server ()
+  "Yank the previously killed server."
+  (interactive)
+  (unless gnus-server-killed-servers
+    (error "No killed servers to be yanked"))
+  (let ((alist gnus-server-alist)
+	(server (gnus-server-server-name))
+	(killed (car gnus-server-killed-servers)))
+    (if (not server)
+	(setq gnus-server-alist (nconc gnus-server-alist (list killed)))
+      (if (string= server (caar gnus-server-alist))
+	  (push killed gnus-server-alist)
+	(while (and (cdr alist)
+		    (not (string= server (caadr alist))))
+	  (setq alist (cdr alist)))
+	(if alist
+	    (setcdr alist (cons killed (cdr alist)))
+ 	  (setq gnus-server-alist (list killed)))))
+    (gnus-server-update-server (car killed))
+    (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
+    (gnus-server-position-point)))
+
+(defun gnus-server-exit ()
+  "Return to the group buffer."
+  (interactive)
+  (run-hooks 'gnus-server-exit-hook)
+  (kill-buffer (current-buffer))
+  (gnus-configure-windows 'group t))
+
+(defun gnus-server-list-servers ()
+  "List all available servers."
+  (interactive)
+  (let ((cur (gnus-server-server-name)))
+    (gnus-server-prepare)
+    (if cur (gnus-server-goto-server cur)
+      (goto-char (point-max))
+      (forward-line -1))
+    (gnus-server-position-point)))
+
+(defun gnus-server-set-status (method status)
+  "Make METHOD have STATUS."
+  (let ((entry (assoc method gnus-opened-servers)))
+    (if entry
+	(setcar (cdr entry) status)
+      (push (list method status) gnus-opened-servers))))
+
+(defun gnus-opened-servers-remove (method)
+  "Remove METHOD from the list of opened servers."
+  (setq gnus-opened-servers (delq (assoc method gnus-opened-servers)
+				  gnus-opened-servers)))
+
+(defun gnus-server-open-server (server)
+  "Force an open of SERVER."
+  (interactive (list (gnus-server-server-name)))
+  (let ((method (gnus-server-to-method server)))
+    (unless method
+      (error "No such server: %s" server))
+    (gnus-server-set-status method 'ok)
+    (prog1
+	(or (gnus-open-server method)
+	    (progn (message "Couldn't open %s" server) nil))
+      (gnus-server-update-server server)
+      (gnus-server-position-point))))
+
+(defun gnus-server-open-all-servers ()
+  "Open all servers."
+  (interactive)
+  (let ((servers gnus-inserted-opened-servers))
+    (while servers
+      (gnus-server-open-server (car (pop servers))))))
+
+(defun gnus-server-close-server (server)
+  "Close SERVER."
+  (interactive (list (gnus-server-server-name)))
+  (let ((method (gnus-server-to-method server)))
+    (unless method
+      (error "No such server: %s" server))
+    (gnus-server-set-status method 'closed)
+    (prog1
+	(gnus-close-server method)
+      (gnus-server-update-server server)
+      (gnus-server-position-point))))
+
+(defun gnus-server-close-all-servers ()
+  "Close all servers."
+  (interactive)
+  (let ((servers gnus-inserted-opened-servers))
+    (while servers
+      (gnus-server-close-server (car (pop servers))))))
+
+(defun gnus-server-deny-server (server)
+  "Make sure SERVER will never be attempted opened."
+  (interactive (list (gnus-server-server-name)))
+  (let ((method (gnus-server-to-method server)))
+    (unless method
+      (error "No such server: %s" server))
+    (gnus-server-set-status method 'denied))
+  (gnus-server-update-server server)
+  (gnus-server-position-point)
+  t)
+
+(defun gnus-server-remove-denials ()
+  "Make all denied servers into closed servers."
+  (interactive)
+  (let ((servers gnus-opened-servers))
+    (while servers
+      (when (eq (nth 1 (car servers)) 'denied)
+	(setcar (nthcdr 1 (car servers)) 'closed))
+      (setq servers (cdr servers))))
+  (gnus-server-list-servers))
+
+(defun gnus-server-copy-server (from to)
+  (interactive
+   (list
+    (or (gnus-server-server-name)
+	(error "No server on the current line"))
+    (read-string "Copy to: ")))
+  (unless from
+    (error "No server on current line"))
+  (unless (and to (not (string= to "")))
+    (error "No name to copy to"))
+  (when (assoc to gnus-server-alist)
+    (error "%s already exists" to))
+  (unless (gnus-server-to-method from)
+    (error "%s: no such server" from))
+  (let ((to-entry (cons from (gnus-copy-sequence
+			      (gnus-server-to-method from)))))
+    (setcar to-entry to)
+    (setcar (nthcdr 2 to-entry) to)
+    (push to-entry gnus-server-killed-servers)
+    (gnus-server-yank-server)))
+
+(defun gnus-server-add-server (how where)
+  (interactive
+   (list (intern (completing-read "Server method: "
+				  gnus-valid-select-methods nil t))
+	 (read-string "Server name: ")))
+  (when (assq where gnus-server-alist)
+    (error "Server with that name already defined"))
+  (push (list where how where) gnus-server-killed-servers)
+  (gnus-server-yank-server))
+
+(defun gnus-server-goto-server (server)
+  "Jump to a server line."
+  (interactive
+   (list (completing-read "Goto server: " gnus-server-alist nil t)))
+  (let ((to (text-property-any (point-min) (point-max)
+			       'gnus-server (intern server))))
+    (when to
+      (goto-char to)
+      (gnus-server-position-point))))
+
+(defun gnus-server-edit-server (server)
+  "Edit the server on the current line."
+  (interactive (list (gnus-server-server-name)))
+  (unless server
+    (error "No server on current line"))
+  (unless (assoc server gnus-server-alist)
+    (error "This server can't be edited"))
+  (let ((info (cdr (assoc server gnus-server-alist))))
+    (gnus-close-server info)
+    (gnus-edit-form
+     info "Editing the server."
+     `(lambda (form)
+	(gnus-server-set-info ,server form)
+	(gnus-server-list-servers)
+	(gnus-server-position-point)))))
+
+(defun gnus-server-scan-server (server)
+  "Request a scan from the current server."
+  (interactive (list (gnus-server-server-name)))
+  (gnus-message 3 "Scanning %s...done" server)
+  (gnus-request-scan nil (gnus-server-to-method server))
+  (gnus-message 3 "Scanning %s...done" server))
+
+(defun gnus-server-read-server (server)
+  "Browse a server."
+  (interactive (list (gnus-server-server-name)))
+  (let ((buf (current-buffer)))
+    (prog1
+	(gnus-browse-foreign-server (gnus-server-to-method server) buf)
+      (save-excursion
+	(set-buffer buf)
+	(gnus-server-update-server (gnus-server-server-name))
+	(gnus-server-position-point)))))
+
+(defun gnus-server-pick-server (e)
+  (interactive "e")
+  (mouse-set-point e)
+  (gnus-server-read-server (gnus-server-server-name)))
+
+
+;;;
+;;; Browse Server Mode
+;;;
+
+(defvar gnus-browse-menu-hook nil
+  "*Hook run after the creation of the browse mode menu.")
+
+(defvar gnus-browse-mode-hook nil)
+(defvar gnus-browse-mode-map nil)
+(put 'gnus-browse-mode 'mode-class 'special)
+
+(unless gnus-browse-mode-map
+  (setq gnus-browse-mode-map (make-keymap))
+  (suppress-keymap gnus-browse-mode-map)
+
+  (gnus-define-keys
+   gnus-browse-mode-map
+   " " gnus-browse-read-group
+   "=" gnus-browse-select-group
+   "n" gnus-browse-next-group
+   "p" gnus-browse-prev-group
+   "\177" gnus-browse-prev-group
+   "N" gnus-browse-next-group
+   "P" gnus-browse-prev-group
+   "\M-n" gnus-browse-next-group
+   "\M-p" gnus-browse-prev-group
+   "\r" gnus-browse-select-group
+   "u" gnus-browse-unsubscribe-current-group
+   "l" gnus-browse-exit
+   "L" gnus-browse-exit
+   "q" gnus-browse-exit
+   "Q" gnus-browse-exit
+   "\C-c\C-c" gnus-browse-exit
+   "?" gnus-browse-describe-briefly
+
+   "\C-c\C-i" gnus-info-find-node
+   "\C-c\C-b" gnus-bug))
+
+(defun gnus-browse-make-menu-bar ()
+  (gnus-turn-off-edit-menu 'browse)
+  (unless (boundp 'gnus-browse-menu)
+    (easy-menu-define
+     gnus-browse-menu gnus-browse-mode-map ""
+     '("Browse"
+       ["Subscribe" gnus-browse-unsubscribe-current-group t]
+       ["Read" gnus-browse-read-group t]
+       ["Select" gnus-browse-read-group t]
+       ["Next" gnus-browse-next-group t]
+       ["Prev" gnus-browse-next-group t]
+       ["Exit" gnus-browse-exit t]))
+    (run-hooks 'gnus-browse-menu-hook)))
+
+(defvar gnus-browse-current-method nil)
+(defvar gnus-browse-return-buffer nil)
+
+(defvar gnus-browse-buffer "*Gnus Browse Server*")
+
+(defun gnus-browse-foreign-server (method &optional return-buffer)
+  "Browse the server METHOD."
+  (setq gnus-browse-current-method method)
+  (setq gnus-browse-return-buffer return-buffer)
+  (when (stringp method)
+    (setq method (gnus-server-to-method method)))
+  (let ((gnus-select-method method)
+	groups group)
+    (gnus-message 5 "Connecting to %s..." (nth 1 method))
+    (cond
+     ((not (gnus-check-server method))
+      (gnus-message
+       1 "Unable to contact server: %s" (gnus-status-message method))
+      nil)
+     ((not
+       (prog2
+	   (gnus-message 6 "Reading active file...")
+	   (gnus-request-list method)
+	 (gnus-message 6 "Reading active file...done")))
+      (gnus-message
+       1 "Couldn't request list: %s" (gnus-status-message method))
+      nil)
+     (t
+      (get-buffer-create gnus-browse-buffer)
+      (gnus-add-current-to-buffer-list)
+      (when gnus-carpal
+	(gnus-carpal-setup-buffer 'browse))
+      (gnus-configure-windows 'browse)
+      (buffer-disable-undo (current-buffer))
+      (let ((buffer-read-only nil))
+	(erase-buffer))
+      (gnus-browse-mode)
+      (setq mode-line-buffer-identification
+	    (list
+	     (format
+	      "Gnus: %%b {%s:%s}" (car method) (cadr method))))
+      (save-excursion
+	(set-buffer nntp-server-buffer)
+	(let ((cur (current-buffer)))
+	  (goto-char (point-min))
+	  (unless (string= gnus-ignored-newsgroups "")
+	    (delete-matching-lines gnus-ignored-newsgroups))
+	  (while (re-search-forward
+		  "\\(^[^ \t]+\\)[ \t]+[0-9]+[ \t]+[0-9]+" nil t)
+	    (goto-char (match-end 1))
+	    (push (cons (match-string 1)
+			(max 0 (- (1+ (read cur)) (read cur))))
+		  groups))))
+      (setq groups (sort groups
+			 (lambda (l1 l2)
+			   (string< (car l1) (car l2)))))
+      (let ((buffer-read-only nil))
+	(while groups
+	  (setq group (car groups))
+	  (insert
+	   (format "K%7d: %s\n" (cdr group) (car group)))
+	  (setq groups (cdr groups))))
+      (switch-to-buffer (current-buffer))
+      (goto-char (point-min))
+      (gnus-group-position-point)
+      (gnus-message 5 "Connecting to %s...done" (nth 1 method))
+      t))))
+
+(defun gnus-browse-mode ()
+  "Major mode for browsing a foreign server.
+
+All normal editing commands are switched off.
+
+\\<gnus-browse-mode-map>
+The only things you can do in this buffer is
+
+1) `\\[gnus-browse-unsubscribe-current-group]' to subscribe to a group.
+The group will be inserted into the group buffer upon exit from this
+buffer.
+
+2) `\\[gnus-browse-read-group]' to read a group ephemerally.
+
+3) `\\[gnus-browse-exit]' to return to the group buffer."
+  (interactive)
+  (kill-all-local-variables)
+  (when (gnus-visual-p 'browse-menu 'menu)
+    (gnus-browse-make-menu-bar))
+  (gnus-simplify-mode-line)
+  (setq major-mode 'gnus-browse-mode)
+  (setq mode-name "Browse Server")
+  (setq mode-line-process nil)
+  (use-local-map gnus-browse-mode-map)
+  (buffer-disable-undo (current-buffer))
+  (setq truncate-lines t)
+  (gnus-set-default-directory)
+  (setq buffer-read-only t)
+  (run-hooks 'gnus-browse-mode-hook))
+
+(defun gnus-browse-read-group (&optional no-article)
+  "Enter the group at the current line."
+  (interactive)
+  (let ((group (gnus-group-real-name (gnus-browse-group-name))))
+    (unless (gnus-group-read-ephemeral-group
+	     group gnus-browse-current-method nil
+	     (cons (current-buffer) 'browse))
+      (error "Couldn't enter %s" group))))
+
+(defun gnus-browse-select-group ()
+  "Select the current group."
+  (interactive)
+  (gnus-browse-read-group 'no))
+
+(defun gnus-browse-next-group (n)
+  "Go to the next group."
+  (interactive "p")
+  (prog1
+      (forward-line n)
+    (gnus-group-position-point)))
+
+(defun gnus-browse-prev-group (n)
+  "Go to the next group."
+  (interactive "p")
+  (gnus-browse-next-group (- n)))
+
+(defun gnus-browse-unsubscribe-current-group (arg)
+  "(Un)subscribe to the next ARG groups."
+  (interactive "p")
+  (when (eobp)
+    (error "No group at current line."))
+  (let ((ward (if (< arg 0) -1 1))
+	(arg (abs arg)))
+    (while (and (> arg 0)
+		(not (eobp))
+		(gnus-browse-unsubscribe-group)
+		(zerop (gnus-browse-next-group ward)))
+      (decf arg))
+    (gnus-group-position-point)
+    (when (/= 0 arg)
+      (gnus-message 7 "No more newsgroups"))
+    arg))
+
+(defun gnus-browse-group-name ()
+  (save-excursion
+    (beginning-of-line)
+    (when (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t)
+      (gnus-group-prefixed-name
+       ;; Remove text props.
+       (format "%s" (match-string 1))
+       gnus-browse-current-method))))
+
+(defun gnus-browse-unsubscribe-group ()
+  "Toggle subscription of the current group in the browse buffer."
+  (let ((sub nil)
+	(buffer-read-only nil)
+	group)
+    (save-excursion
+      (beginning-of-line)
+      ;; If this group it killed, then we want to subscribe it.
+      (when (= (following-char) ?K)
+	(setq sub t))
+      (setq group (gnus-browse-group-name))
+      ;; Make sure the group has been properly removed before we
+      ;; subscribe to it.
+      (gnus-kill-ephemeral-group group)
+      (delete-char 1)
+      (if sub
+	  (progn
+	    (gnus-group-change-level
+	     (list t group gnus-level-default-subscribed
+		   nil nil gnus-browse-current-method)
+	     gnus-level-default-subscribed gnus-level-killed
+	     (and (car (nth 1 gnus-newsrc-alist))
+		  (gnus-gethash (car (nth 1 gnus-newsrc-alist))
+				gnus-newsrc-hashtb))
+	     t)
+	    (insert ? ))
+	(gnus-group-change-level
+	 group gnus-level-killed gnus-level-default-subscribed)
+	(insert ?K)))
+    t))
+
+(defun gnus-browse-exit ()
+  "Quit browsing and return to the group buffer."
+  (interactive)
+  (when (eq major-mode 'gnus-browse-mode)
+    (kill-buffer (current-buffer)))
+  ;; Insert the newly subscribed groups in the group buffer.
+  (save-excursion
+    (set-buffer gnus-group-buffer)
+    (gnus-group-list-groups nil))
+  (if gnus-browse-return-buffer
+      (gnus-configure-windows 'server 'force)
+    (gnus-configure-windows 'group 'force)))
+
+(defun gnus-browse-describe-briefly ()
+  "Give a one line description of the group mode commands."
+  (interactive)
+  (gnus-message 6
+		(substitute-command-keys "\\<gnus-browse-mode-map>\\[gnus-group-next-group]:Forward  \\[gnus-group-prev-group]:Backward  \\[gnus-browse-exit]:Exit  \\[gnus-info-find-node]:Run Info  \\[gnus-browse-describe-briefly]:This help")))
+
+(defun gnus-server-regenerate-server ()
+  "Issue a command to the server to regenerate all its data structures."
+  (interactive)
+  (let ((server (gnus-server-server-name)))
+    (unless server
+      (error "No server on the current line"))
+    (if (not (gnus-check-backend-function
+	      'request-regenerate (car (gnus-server-to-method server))))
+	(error "This backend doesn't support regeneration")
+      (gnus-message 5 "Requesting regeneration of %s..." server)
+      (if (gnus-request-regenerate server)
+	  (gnus-message 5 "Requesting regeneration of %s...done" server)
+	(gnus-message 5 "Couldn't regenerate %s" server)))))
+
+(provide 'gnus-srvr)
+
+;;; gnus-srvr.el ends here.

lisp/gnus/gnus-undo.el

@@ -0,0 +1,173 @@
+;;; gnus-undo.el --- minor mode for undoing in Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This package allows arbitrary undoing in Gnus buffers.  As all the
+;; Gnus buffers aren't very text-oriented (what is in the buffers is
+;; just some random representation of the actual data), normal Emacs
+;; undoing doesn't work at all for Gnus.
+;;
+;; This package works by letting Gnus register functions for reversing
+;; actions, and then calling these functions when the user pushes the
+;; `undo' key.  As with normal `undo', there it is possible to set
+;; undo boundaries and so on.
+;;
+;; Internally, the undo sequence is represented by the
+;; `gnus-undo-actions' list, where each element is a list of functions
+;; to be called, in sequence, to undo some action.  (An "action" is a
+;; collection of functions.)
+;;
+;; For instance, a function for killing a group will call
+;; `gnus-undo-register' with a function that un-kills the group.  This
+;; package will put that function into an action.
+
+;;; Code:
+
+(require 'gnus-util)
+(require 'gnus)
+
+(defvar gnus-undo-mode nil
+  "Minor mode for undoing in Gnus buffers.")
+
+(defvar gnus-undo-mode-hook nil
+  "Hook called in all `gnus-undo-mode' buffers.")
+
+;;; Internal variables.
+
+(defvar gnus-undo-actions nil)
+(defvar gnus-undo-boundary t)
+(defvar gnus-undo-last nil)
+(defvar gnus-undo-boundary-inhibit nil)
+
+;;; Minor mode definition.
+
+(defvar gnus-undo-mode-map nil)
+
+(unless gnus-undo-mode-map
+  (setq gnus-undo-mode-map (make-sparse-keymap))
+
+  (gnus-define-keys gnus-undo-mode-map
+   "\M-\C-_"     gnus-undo
+   "\C-_"        gnus-undo
+   "\C-xu"       gnus-undo
+   [(control /)] gnus-undo    ; many people are used to type `C-/' on
+			      ; X terminals and get `C-_'.
+   ))
+
+(defun gnus-undo-make-menu-bar ()
+  (when nil
+  (define-key-after (current-local-map) [menu-bar file gnus-undo]
+    (cons "Undo" 'gnus-undo-actions)
+    [menu-bar file whatever])))
+
+(defun gnus-undo-mode (&optional arg)
+  "Minor mode for providing `undo' in Gnus buffers.
+
+\\{gnus-undo-mode-map}"
+  (interactive "P")
+  (set (make-local-variable 'gnus-undo-mode)
+       (if (null arg) (not gnus-undo-mode)
+	 (> (prefix-numeric-value arg) 0)))
+  (set (make-local-variable 'gnus-undo-actions) nil)
+  (set (make-local-variable 'gnus-undo-boundary) t)
+  (when gnus-undo-mode
+    ;; Set up the menu.
+    (when (gnus-visual-p 'undo-menu 'menu)
+      (gnus-undo-make-menu-bar))
+    ;; Don't display anything in the mode line -- too annoying.
+    ;;(unless (assq 'gnus-undo-mode minor-mode-alist)
+    ;;  (push '(gnus-undo-mode " Undo") minor-mode-alist))
+    (unless (assq 'gnus-undo-mode minor-mode-map-alist)
+      (push (cons 'gnus-undo-mode gnus-undo-mode-map)
+	    minor-mode-map-alist))
+    (make-local-hook 'post-command-hook)
+    (add-hook 'post-command-hook 'gnus-undo-boundary nil t)
+    (add-hook 'gnus-summary-exit-hook 'gnus-undo-boundary)
+    (run-hooks 'gnus-undo-mode-hook)))
+
+;;; Interface functions.
+
+(defun gnus-disable-undo (&optional buffer)
+  "Disable undoing in the current buffer."
+  (interactive)
+  (save-excursion
+    (when buffer
+      (set-buffer buffer))
+    (gnus-undo-mode -1)))
+
+(defun gnus-undo-boundary ()
+  "Set Gnus undo boundary."
+  (if gnus-undo-boundary-inhibit
+      (setq gnus-undo-boundary-inhibit nil)
+    (setq gnus-undo-boundary t)))
+
+(defun gnus-undo-register (form)
+  "Register FORMS as something to be performed to undo a change.
+FORMS may use backtick quote syntax."
+  (when gnus-undo-mode
+    (gnus-undo-register-1
+     `(lambda ()
+	,form))))
+
+(put 'gnus-undo-register 'lisp-indent-function 0)
+(put 'gnus-undo-register 'edebug-form-spec '(body))
+
+(defun gnus-undo-register-1 (function)
+  "Register FUNCTION as something to be performed to undo a change."
+  (when gnus-undo-mode
+    (cond
+     ;; We are on a boundary, so we create a new action.
+     (gnus-undo-boundary
+      (push (list function) gnus-undo-actions)
+      (setq gnus-undo-boundary nil))
+     ;; Prepend the function to an old action.
+     (gnus-undo-actions
+      (setcar gnus-undo-actions (cons function (car gnus-undo-actions))))
+     ;; Initialize list.
+     (t
+      (setq gnus-undo-actions (list (list function)))))
+    (setq gnus-undo-boundary-inhibit t)))
+
+(defun gnus-undo (n)
+  "Undo some previous changes in Gnus buffers.
+Repeat this command to undo more changes.
+A numeric argument serves as a repeat count."
+  (interactive "p")
+  (unless gnus-undo-mode
+    (error "Undoing is not enabled in this buffer"))
+  (message "%s" last-command)
+  (when (or (not (eq last-command 'gnus-undo))
+	    (not gnus-undo-last))
+    (setq gnus-undo-last gnus-undo-actions))
+  (let ((action (pop gnus-undo-last)))
+    (unless action
+      (error "Nothing further to undo"))
+    (setq gnus-undo-actions (delq action gnus-undo-actions))
+    (setq gnus-undo-boundary t)
+    (while action
+      (funcall (pop action)))))
+
+(provide 'gnus-undo)
+
+;;; gnus-undo.el ends here

lisp/gnus/gnus-util.el

@@ -0,0 +1,829 @@
+;;; gnus-util.el --- utility functions for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Nothing in this file depends on any other parts of Gnus -- all
+;; functions and macros in this file are utility functions that are
+;; used by Gnus and may be used by any other package without loading
+;; Gnus first.
+
+;;; Code:
+
+(require 'custom)
+(require 'cl)
+(require 'nnheader)
+(require 'timezone)
+(require 'message)
+
+(eval-and-compile
+  (autoload 'nnmail-date-to-time "nnmail"))
+
+(defun gnus-boundp (variable)
+  "Return non-nil if VARIABLE is bound and non-nil."
+  (and (boundp variable)
+       (symbol-value variable)))
+
+(defmacro gnus-eval-in-buffer-window (buffer &rest forms)
+  "Pop to BUFFER, evaluate FORMS, and then return to the original window."
+  (let ((tempvar (make-symbol "GnusStartBufferWindow"))
+        (w (make-symbol "w"))
+        (buf (make-symbol "buf")))
+    `(let* ((,tempvar (selected-window))
+            (,buf ,buffer)
+            (,w (get-buffer-window ,buf 'visible)))
+       (unwind-protect
+           (progn
+             (if ,w
+                 (progn
+                   (select-window ,w)
+                   (set-buffer (window-buffer ,w)))
+               (pop-to-buffer ,buf))
+             ,@forms)
+         (select-window ,tempvar)))))
+
+(put 'gnus-eval-in-buffer-window 'lisp-indent-function 1)
+(put 'gnus-eval-in-buffer-window 'edebug-form-spec '(form body))
+
+(defmacro gnus-intern-safe (string hashtable)
+  "Set hash value.  Arguments are STRING, VALUE, and HASHTABLE."
+  `(let ((symbol (intern ,string ,hashtable)))
+     (or (boundp symbol)
+	 (set symbol nil))
+     symbol))
+
+;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;   function `substring' might cut on a middle of multi-octet
+;;   character.
+(defun gnus-truncate-string (str width)
+  (substring str 0 width))
+
+;; Added by Geoffrey T. Dairiki <dairiki@u.washington.edu>.  A safe way
+;; to limit the length of a string.  This function is necessary since
+;; `(substr "abc" 0 30)' pukes with "Args out of range".
+(defsubst gnus-limit-string (str width)
+  (if (> (length str) width)
+      (substring str 0 width)
+    str))
+
+(defsubst gnus-functionp (form)
+  "Return non-nil if FORM is funcallable."
+  (or (and (symbolp form) (fboundp form))
+      (and (listp form) (eq (car form) 'lambda))
+      (compiled-function-p form)))
+
+(defsubst gnus-goto-char (point)
+  (and point (goto-char point)))
+
+(defmacro gnus-buffer-exists-p (buffer)
+  `(let ((buffer ,buffer))
+     (when buffer
+       (funcall (if (stringp buffer) 'get-buffer 'buffer-name)
+		buffer))))
+
+(defmacro gnus-kill-buffer (buffer)
+  `(let ((buf ,buffer))
+     (when (gnus-buffer-exists-p buf)
+       (kill-buffer buf))))
+
+(if (fboundp 'point-at-bol)
+    (fset 'gnus-point-at-bol 'point-at-bol)
+  (defun gnus-point-at-bol ()
+    "Return point at the beginning of the line."
+    (let ((p (point)))
+      (beginning-of-line)
+      (prog1
+	  (point)
+	(goto-char p)))))
+
+(if (fboundp 'point-at-eol)
+    (fset 'gnus-point-at-eol 'point-at-eol)
+  (defun gnus-point-at-eol ()
+    "Return point at the end of the line."
+    (let ((p (point)))
+      (end-of-line)
+      (prog1
+	  (point)
+	(goto-char p)))))
+
+(defun gnus-delete-first (elt list)
+  "Delete by side effect the first occurrence of ELT as a member of LIST."
+  (if (equal (car list) elt)
+      (cdr list)
+    (let ((total list))
+      (while (and (cdr list)
+		  (not (equal (cadr list) elt)))
+	(setq list (cdr list)))
+      (when (cdr list)
+	(setcdr list (cddr list)))
+      total)))
+
+;; Delete the current line (and the next N lines).
+(defmacro gnus-delete-line (&optional n)
+  `(delete-region (progn (beginning-of-line) (point))
+		  (progn (forward-line ,(or n 1)) (point))))
+
+(defun gnus-byte-code (func)
+  "Return a form that can be `eval'ed based on FUNC."
+  (let ((fval (symbol-function func)))
+    (if (compiled-function-p fval)
+	(let ((flist (append fval nil)))
+	  (setcar flist 'byte-code)
+	  flist)
+      (cons 'progn (cddr fval)))))
+
+(defun gnus-extract-address-components (from)
+  (let (name address)
+    ;; First find the address - the thing with the @ in it.  This may
+    ;; not be accurate in mail addresses, but does the trick most of
+    ;; the time in news messages.
+    (when (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from)
+      (setq address (substring from (match-beginning 0) (match-end 0))))
+    ;; Then we check whether the "name <address>" format is used.
+    (and address
+	 ;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>
+	 ;; Linear white space is not required.
+	 (string-match (concat "[ \t]*<" (regexp-quote address) ">") from)
+	 (and (setq name (substring from 0 (match-beginning 0)))
+	      ;; Strip any quotes from the name.
+	      (string-match "\".*\"" name)
+	      (setq name (substring name 1 (1- (match-end 0))))))
+    ;; If not, then "address (name)" is used.
+    (or name
+	(and (string-match "(.+)" from)
+	     (setq name (substring from (1+ (match-beginning 0))
+				   (1- (match-end 0)))))
+	(and (string-match "()" from)
+	     (setq name address))
+	;; Fix by MORIOKA Tomohiko <morioka@jaist.ac.jp>.
+	;; XOVER might not support folded From headers.
+	(and (string-match "(.*" from)
+	     (setq name (substring from (1+ (match-beginning 0))
+				   (match-end 0)))))
+    ;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
+    (list (or name from) (or address from))))
+
+(defun gnus-fetch-field (field)
+  "Return the value of the header FIELD of current article."
+  (save-excursion
+    (save-restriction
+      (let ((case-fold-search t)
+	    (inhibit-point-motion-hooks t))
+	(nnheader-narrow-to-headers)
+	(message-fetch-field field)))))
+
+(defun gnus-goto-colon ()
+  (beginning-of-line)
+  (search-forward ":" (gnus-point-at-eol) t))
+
+(defun gnus-remove-text-with-property (prop)
+  "Delete all text in the current buffer with text property PROP."
+  (save-excursion
+    (goto-char (point-min))
+    (while (not (eobp))
+      (while (get-text-property (point) prop)
+	(delete-char 1))
+      (goto-char (next-single-property-change (point) prop nil (point-max))))))
+
+(defun gnus-newsgroup-directory-form (newsgroup)
+  "Make hierarchical directory name from NEWSGROUP name."
+  (let ((newsgroup (gnus-newsgroup-savable-name newsgroup))
+	(len (length newsgroup))
+	idx)
+    ;; If this is a foreign group, we don't want to translate the
+    ;; entire name.
+    (if (setq idx (string-match ":" newsgroup))
+	(aset newsgroup idx ?/)
+      (setq idx 0))
+    ;; Replace all occurrences of `.' with `/'.
+    (while (< idx len)
+      (when (= (aref newsgroup idx) ?.)
+	(aset newsgroup idx ?/))
+      (setq idx (1+ idx)))
+    newsgroup))
+
+(defun gnus-newsgroup-savable-name (group)
+  ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group)
+  ;; with dots.
+  (nnheader-replace-chars-in-string group ?/ ?.))
+
+(defun gnus-string> (s1 s2)
+  (not (or (string< s1 s2)
+	   (string= s1 s2))))
+
+;;; Time functions.
+
+(defun gnus-days-between (date1 date2)
+  ;; Return the number of days between date1 and date2.
+  (- (gnus-day-number date1) (gnus-day-number date2)))
+
+(defun gnus-day-number (date)
+  (let ((dat (mapcar (lambda (s) (and s (string-to-int s)) )
+		     (timezone-parse-date date))))
+    (timezone-absolute-from-gregorian
+     (nth 1 dat) (nth 2 dat) (car dat))))
+
+(defun gnus-time-to-day (time)
+  "Convert TIME to day number."
+  (let ((tim (decode-time time)))
+    (timezone-absolute-from-gregorian
+     (nth 4 tim) (nth 3 tim) (nth 5 tim))))
+
+(defun gnus-encode-date (date)
+  "Convert DATE to internal time."
+  (let* ((parse (timezone-parse-date date))
+	 (date (mapcar (lambda (d) (and d (string-to-int d))) parse))
+	 (time (mapcar 'string-to-int (timezone-parse-time (aref parse 3)))))
+    (encode-time (caddr time) (cadr time) (car time)
+		 (caddr date) (cadr date) (car date) (nth 4 date))))
+
+(defun gnus-time-minus (t1 t2)
+  "Subtract two internal times."
+  (let ((borrow (< (cadr t1) (cadr t2))))
+    (list (- (car t1) (car t2) (if borrow 1 0))
+	  (- (+ (if borrow 65536 0) (cadr t1)) (cadr t2)))))
+
+(defun gnus-time-less (t1 t2)
+  "Say whether time T1 is less than time T2."
+  (or (< (car t1) (car t2))
+      (and (= (car t1) (car t2))
+	   (< (nth 1 t1) (nth 1 t2)))))
+
+(defun gnus-file-newer-than (file date)
+  (let ((fdate (nth 5 (file-attributes file))))
+    (or (> (car fdate) (car date))
+	(and (= (car fdate) (car date))
+	     (> (nth 1 fdate) (nth 1 date))))))
+
+;;; Keymap macros.
+
+(defmacro gnus-local-set-keys (&rest plist)
+  "Set the keys in PLIST in the current keymap."
+  `(gnus-define-keys-1 (current-local-map) ',plist))
+
+(defmacro gnus-define-keys (keymap &rest plist)
+  "Define all keys in PLIST in KEYMAP."
+  `(gnus-define-keys-1 (quote ,keymap) (quote ,plist)))
+
+(defmacro gnus-define-keys-safe (keymap &rest plist)
+  "Define all keys in PLIST in KEYMAP without overwriting previous definitions."
+  `(gnus-define-keys-1 (quote ,keymap) (quote ,plist) t))
+
+(put 'gnus-define-keys 'lisp-indent-function 1)
+(put 'gnus-define-keys-safe 'lisp-indent-function 1)
+(put 'gnus-local-set-keys 'lisp-indent-function 1)
+
+(defmacro gnus-define-keymap (keymap &rest plist)
+  "Define all keys in PLIST in KEYMAP."
+  `(gnus-define-keys-1 ,keymap (quote ,plist)))
+
+(put 'gnus-define-keymap 'lisp-indent-function 1)
+
+(defun gnus-define-keys-1 (keymap plist &optional safe)
+  (when (null keymap)
+    (error "Can't set keys in a null keymap"))
+  (cond ((symbolp keymap)
+	 (setq keymap (symbol-value keymap)))
+	((keymapp keymap))
+	((listp keymap)
+	 (set (car keymap) nil)
+	 (define-prefix-command (car keymap))
+	 (define-key (symbol-value (caddr keymap)) (cadr keymap) (car keymap))
+	 (setq keymap (symbol-value (car keymap)))))
+  (let (key)
+    (while plist
+      (when (symbolp (setq key (pop plist)))
+	(setq key (symbol-value key)))
+      (if (or (not safe)
+	      (eq (lookup-key keymap key) 'undefined))
+	  (define-key keymap key (pop plist))
+	(pop plist)))))
+
+(defun gnus-completing-read (default prompt &rest args)
+  ;; Like `completing-read', except that DEFAULT is the default argument.
+  (let* ((prompt (if default
+		     (concat prompt " (default " default ") ")
+		   (concat prompt " ")))
+	 (answer (apply 'completing-read prompt args)))
+    (if (or (null answer) (zerop (length answer)))
+	default
+      answer)))
+
+;; Two silly functions to ensure that all `y-or-n-p' questions clear
+;; the echo area.
+(defun gnus-y-or-n-p (prompt)
+  (prog1
+      (y-or-n-p prompt)
+    (message "")))
+
+(defun gnus-yes-or-no-p (prompt)
+  (prog1
+      (yes-or-no-p prompt)
+    (message "")))
+
+;; I suspect there's a better way, but I haven't taken the time to do
+;; it yet.  -erik selberg@cs.washington.edu
+(defun gnus-dd-mmm (messy-date)
+  "Return a string like DD-MMM from a big messy string"
+  (let ((datevec (ignore-errors (timezone-parse-date messy-date))))
+    (if (not datevec)
+	"??-???"
+      (format "%2s-%s"
+	      (condition-case ()
+		  ;; Make sure leading zeroes are stripped.
+		  (number-to-string (string-to-number (aref datevec 2)))
+		(error "??"))
+	      (capitalize
+	       (or (car
+		    (nth (1- (string-to-number (aref datevec 1)))
+			 timezone-months-assoc))
+		   "???"))))))
+
+(defmacro gnus-date-get-time (date)
+  "Convert DATE string to Emacs time.
+Cache the result as a text property stored in DATE."
+  ;; Either return the cached value...
+  `(let ((d ,date))
+     (if (equal "" d)
+	 '(0 0)
+       (or (get-text-property 0 'gnus-time d)
+	   ;; or compute the value...
+	   (let ((time (nnmail-date-to-time d)))
+	     ;; and store it back in the string.
+	     (put-text-property 0 1 'gnus-time time d)
+	     time)))))
+
+(defsubst gnus-time-iso8601 (time)
+  "Return a string of TIME in YYMMDDTHHMMSS format."
+  (format-time-string "%Y%m%dT%H%M%S" time))
+
+(defun gnus-date-iso8601 (header)
+  "Convert the date field in HEADER to YYMMDDTHHMMSS"
+  (condition-case ()
+      (gnus-time-iso8601 (gnus-date-get-time (mail-header-date header)))
+    (error "")))
+
+(defun gnus-mode-string-quote (string)
+  "Quote all \"%\"'s in STRING."
+  (save-excursion
+    (gnus-set-work-buffer)
+    (insert string)
+    (goto-char (point-min))
+    (while (search-forward "%" nil t)
+      (insert "%"))
+    (buffer-string)))
+
+;; Make a hash table (default and minimum size is 256).
+;; Optional argument HASHSIZE specifies the table size.
+(defun gnus-make-hashtable (&optional hashsize)
+  (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 256) 256) 0))
+
+;; Make a number that is suitable for hashing; bigger than MIN and
+;; equal to some 2^x.  Many machines (such as sparcs) do not have a
+;; hardware modulo operation, so they implement it in software.  On
+;; many sparcs over 50% of the time to intern is spent in the modulo.
+;; Yes, it's slower than actually computing the hash from the string!
+;; So we use powers of 2 so people can optimize the modulo to a mask.
+(defun gnus-create-hash-size (min)
+  (let ((i 1))
+    (while (< i min)
+      (setq i (* 2 i)))
+    i))
+
+(defcustom gnus-verbose 7
+  "*Integer that says how verbose Gnus should be.
+The higher the number, the more messages Gnus will flash to say what
+it's doing.  At zero, Gnus will be totally mute; at five, Gnus will
+display most important messages; and at ten, Gnus will keep on
+jabbering all the time."
+  :group 'gnus-start
+  :type 'integer)
+
+;; Show message if message has a lower level than `gnus-verbose'.
+;; Guideline for numbers:
+;; 1 - error messages, 3 - non-serious error messages, 5 - messages
+;; for things that take a long time, 7 - not very important messages
+;; on stuff, 9 - messages inside loops.
+(defun gnus-message (level &rest args)
+  (if (<= level gnus-verbose)
+      (apply 'message args)
+    ;; We have to do this format thingy here even if the result isn't
+    ;; shown - the return value has to be the same as the return value
+    ;; from `message'.
+    (apply 'format args)))
+
+(defun gnus-error (level &rest args)
+  "Beep an error if LEVEL is equal to or less than `gnus-verbose'."
+  (when (<= (floor level) gnus-verbose)
+    (apply 'message args)
+    (ding)
+    (let (duration)
+      (when (and (floatp level)
+		 (not (zerop (setq duration (* 10 (- level (floor level)))))))
+	(sit-for duration))))
+  nil)
+
+(defun gnus-split-references (references)
+  "Return a list of Message-IDs in REFERENCES."
+  (let ((beg 0)
+	ids)
+    (while (string-match "<[^>]+>" references beg)
+      (push (substring references (match-beginning 0) (setq beg (match-end 0)))
+	    ids))
+    (nreverse ids)))
+
+(defun gnus-parent-id (references &optional n)
+  "Return the last Message-ID in REFERENCES.
+If N, return the Nth ancestor instead."
+  (when references
+    (let ((ids (inline (gnus-split-references references))))
+      (car (last ids (or n 1))))))
+
+(defsubst gnus-buffer-live-p (buffer)
+  "Say whether BUFFER is alive or not."
+  (and buffer
+       (get-buffer buffer)
+       (buffer-name (get-buffer buffer))))
+
+(defun gnus-horizontal-recenter ()
+  "Recenter the current buffer horizontally."
+  (if (< (current-column) (/ (window-width) 2))
+      (set-window-hscroll (get-buffer-window (current-buffer) t) 0)
+    (let* ((orig (point))
+	   (end (window-end (get-buffer-window (current-buffer) t)))
+	   (max 0))
+      ;; Find the longest line currently displayed in the window.
+      (goto-char (window-start))
+      (while (and (not (eobp))
+		  (< (point) end))
+	(end-of-line)
+	(setq max (max max (current-column)))
+	(forward-line 1))
+      (goto-char orig)
+      ;; Scroll horizontally to center (sort of) the point.
+      (if (> max (window-width))
+	  (set-window-hscroll
+	   (get-buffer-window (current-buffer) t)
+	   (min (- (current-column) (/ (window-width) 3))
+		(+ 2 (- max (window-width)))))
+	(set-window-hscroll (get-buffer-window (current-buffer) t) 0))
+      max)))
+
+(defun gnus-read-event-char ()
+  "Get the next event."
+  (let ((event (read-event)))
+    ;; should be gnus-characterp, but this can't be called in XEmacs anyway
+    (cons (and (numberp event) event) event)))
+
+(defun gnus-sortable-date (date)
+  "Make sortable string by string-lessp from DATE.
+Timezone package is used."
+  (condition-case ()
+      (progn
+	(setq date (inline (timezone-fix-time
+			    date nil
+			    (aref (inline (timezone-parse-date date)) 4))))
+	(inline
+	  (timezone-make-sortable-date
+	   (aref date 0) (aref date 1) (aref date 2)
+	   (inline
+	     (timezone-make-time-string
+	      (aref date 3) (aref date 4) (aref date 5))))))
+    (error "")))
+
+(defun gnus-copy-file (file &optional to)
+  "Copy FILE to TO."
+  (interactive
+   (list (read-file-name "Copy file: " default-directory)
+	 (read-file-name "Copy file to: " default-directory)))
+  (unless to
+    (setq to (read-file-name "Copy file to: " default-directory)))
+  (when (file-directory-p to)
+    (setq to (concat (file-name-as-directory to)
+		     (file-name-nondirectory file))))
+  (copy-file file to))
+
+(defun gnus-kill-all-overlays ()
+  "Delete all overlays in the current buffer."
+  (unless gnus-xemacs
+    (let* ((overlayss (overlay-lists))
+	   (buffer-read-only nil)
+	   (overlays (nconc (car overlayss) (cdr overlayss))))
+      (while overlays
+	(delete-overlay (pop overlays))))))
+
+(defvar gnus-work-buffer " *gnus work*")
+
+(defun gnus-set-work-buffer ()
+  "Put point in the empty Gnus work buffer."
+  (if (get-buffer gnus-work-buffer)
+      (progn
+	(set-buffer gnus-work-buffer)
+	(erase-buffer))
+    (set-buffer (get-buffer-create gnus-work-buffer))
+    (kill-all-local-variables)
+    (buffer-disable-undo (current-buffer))))
+
+(defmacro gnus-group-real-name (group)
+  "Find the real name of a foreign newsgroup."
+  `(let ((gname ,group))
+     (if (string-match "^[^:]+:" gname)
+	 (substring gname (match-end 0))
+       gname)))
+
+(defun gnus-make-sort-function (funs)
+  "Return a composite sort condition based on the functions in FUNC."
+  (cond
+   ((not (listp funs)) funs)
+   ((null funs) funs)
+   ((cdr funs)
+    `(lambda (t1 t2)
+       ,(gnus-make-sort-function-1 (reverse funs))))
+   (t
+    (car funs))))
+
+(defun gnus-make-sort-function-1 (funs)
+  "Return a composite sort condition based on the functions in FUNC."
+  (if (cdr funs)
+      `(or (,(car funs) t1 t2)
+	   (and (not (,(car funs) t2 t1))
+		,(gnus-make-sort-function-1 (cdr funs))))
+    `(,(car funs) t1 t2)))
+
+(defun gnus-turn-off-edit-menu (type)
+  "Turn off edit menu in `gnus-TYPE-mode-map'."
+  (define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
+    [menu-bar edit] 'undefined))
+
+(defun gnus-prin1 (form)
+  "Use `prin1' on FORM in the current buffer.
+Bind `print-quoted' to t while printing."
+  (let ((print-quoted t)
+	print-level print-length)
+    (prin1 form (current-buffer))))
+
+(defun gnus-prin1-to-string (form)
+  "The same as `prin1', but but `print-quoted' to t."
+  (let ((print-quoted t))
+    (prin1-to-string form)))
+
+(defun gnus-make-directory (directory)
+  "Make DIRECTORY (and all its parents) if it doesn't exist."
+  (when (and directory
+	     (not (file-exists-p directory)))
+    (make-directory directory t))
+  t)
+
+(defun gnus-write-buffer (file)
+  "Write the current buffer's contents to FILE."
+  ;; Make sure the directory exists.
+  (gnus-make-directory (file-name-directory file))
+  ;; Write the buffer.
+  (write-region (point-min) (point-max) file nil 'quietly))
+
+(defmacro gnus-delete-assq (key list)
+  `(let ((listval (eval ,list)))
+     (setq ,list (delq (assq ,key listval) listval))))
+
+(defmacro gnus-delete-assoc (key list)
+  `(let ((listval ,list))
+     (setq ,list (delq (assoc ,key listval) listval))))
+
+(defun gnus-delete-file (file)
+  "Delete FILE if it exists."
+  (when (file-exists-p file)
+    (delete-file file)))
+
+(defun gnus-strip-whitespace (string)
+  "Return STRING stripped of all whitespace."
+  (while (string-match "[\r\n\t ]+" string)
+    (setq string (replace-match "" t t string)))
+  string)
+
+(defun gnus-put-text-property-excluding-newlines (beg end prop val)
+  "The same as `put-text-property', but don't put this prop on any newlines in the region."
+  (save-match-data
+    (save-excursion
+      (save-restriction
+	(goto-char beg)
+	(while (re-search-forward "[ \t]*\n" end 'move)
+	  (put-text-property beg (match-beginning 0) prop val)
+	  (setq beg (point)))
+	(put-text-property beg (point) prop val)))))
+
+;;; Protected and atomic operations.  dmoore@ucsd.edu 21.11.1996
+;;; The primary idea here is to try to protect internal datastructures
+;;; from becoming corrupted when the user hits C-g, or if a hook or
+;;; similar blows up.  Often in Gnus multiple tables/lists need to be
+;;; updated at the same time, or information can be lost.
+
+(defvar gnus-atomic-be-safe t
+  "If t, certain operations will be protected from interruption by C-g.")
+
+(defmacro gnus-atomic-progn (&rest forms)
+  "Evaluate FORMS atomically, which means to protect the evaluation
+from being interrupted by the user.  An error from the forms themselves
+will return without finishing the operation.  Since interrupts from
+the user are disabled, it is recommended that only the most minimal
+operations are performed by FORMS.  If you wish to assign many
+complicated values atomically, compute the results into temporary
+variables and then do only the assignment atomically."
+  `(let ((inhibit-quit gnus-atomic-be-safe))
+     ,@forms))
+
+(put 'gnus-atomic-progn 'lisp-indent-function 0)
+
+(defmacro gnus-atomic-progn-assign (protect &rest forms)
+  "Evaluate FORMS, but insure that the variables listed in PROTECT
+are not changed if anything in FORMS signals an error or otherwise
+non-locally exits.  The variables listed in PROTECT are updated atomically.
+It is safe to use gnus-atomic-progn-assign with long computations.
+
+Note that if any of the symbols in PROTECT were unbound, they will be
+set to nil on a sucessful assignment.  In case of an error or other
+non-local exit, it will still be unbound."
+  (let* ((temp-sym-map (mapcar (lambda (x) (list (make-symbol
+						  (concat (symbol-name x)
+							  "-tmp"))
+						 x))
+			       protect))
+	 (sym-temp-map (mapcar (lambda (x) (list (cadr x) (car x)))
+			       temp-sym-map))
+	 (temp-sym-let (mapcar (lambda (x) (list (car x)
+						 `(and (boundp ',(cadr x))
+						       ,(cadr x))))
+			       temp-sym-map))
+	 (sym-temp-let sym-temp-map)
+	 (temp-sym-assign (apply 'append temp-sym-map))
+	 (sym-temp-assign (apply 'append sym-temp-map))
+	 (result (make-symbol "result-tmp")))
+    `(let (,@temp-sym-let
+	   ,result)
+       (let ,sym-temp-let
+	 (setq ,result (progn ,@forms))
+	 (setq ,@temp-sym-assign))
+       (let ((inhibit-quit gnus-atomic-be-safe))
+	 (setq ,@sym-temp-assign))
+       ,result)))
+
+(put 'gnus-atomic-progn-assign 'lisp-indent-function 1)
+;(put 'gnus-atomic-progn-assign 'edebug-form-spec '(sexp body))
+
+(defmacro gnus-atomic-setq (&rest pairs)
+  "Similar to setq, except that the real symbols are only assigned when
+there are no errors.  And when the real symbols are assigned, they are
+done so atomically.  If other variables might be changed via side-effect,
+see gnus-atomic-progn-assign.  It is safe to use gnus-atomic-setq
+with potentially long computations."
+  (let ((tpairs pairs)
+	syms)
+    (while tpairs
+      (push (car tpairs) syms)
+      (setq tpairs (cddr tpairs)))
+    `(gnus-atomic-progn-assign ,syms
+       (setq ,@pairs))))
+
+;(put 'gnus-atomic-setq 'edebug-form-spec '(body))
+
+
+;;; Functions for saving to babyl/mail files.
+
+(defvar rmail-default-rmail-file)
+(defun gnus-output-to-rmail (filename &optional ask)
+  "Append the current article to an Rmail file named FILENAME."
+  (require 'rmail)
+  ;; Most of these codes are borrowed from rmailout.el.
+  (setq filename (expand-file-name filename))
+  (setq rmail-default-rmail-file filename)
+  (let ((artbuf (current-buffer))
+	(tmpbuf (get-buffer-create " *Gnus-output*")))
+    (save-excursion
+      (or (get-file-buffer filename)
+	  (file-exists-p filename)
+	  (if (or (not ask)
+		  (gnus-yes-or-no-p
+		   (concat "\"" filename "\" does not exist, create it? ")))
+	      (let ((file-buffer (create-file-buffer filename)))
+		(save-excursion
+		  (set-buffer file-buffer)
+		  (rmail-insert-rmail-file-header)
+		  (let ((require-final-newline nil))
+		    (gnus-write-buffer filename)))
+		(kill-buffer file-buffer))
+	    (error "Output file does not exist")))
+      (set-buffer tmpbuf)
+      (erase-buffer)
+      (insert-buffer-substring artbuf)
+      (gnus-convert-article-to-rmail)
+      ;; Decide whether to append to a file or to an Emacs buffer.
+      (let ((outbuf (get-file-buffer filename)))
+	(if (not outbuf)
+	    (append-to-file (point-min) (point-max) filename)
+	  ;; File has been visited, in buffer OUTBUF.
+	  (set-buffer outbuf)
+	  (let ((buffer-read-only nil)
+		(msg (and (boundp 'rmail-current-message)
+			  (symbol-value 'rmail-current-message))))
+	    ;; If MSG is non-nil, buffer is in RMAIL mode.
+	    (when msg
+	      (widen)
+	      (narrow-to-region (point-max) (point-max)))
+	    (insert-buffer-substring tmpbuf)
+	    (when msg
+	      (goto-char (point-min))
+	      (widen)
+	      (search-backward "\^_")
+	      (narrow-to-region (point) (point-max))
+	      (goto-char (1+ (point-min)))
+	      (rmail-count-new-messages t)
+	      (rmail-show-message msg))))))
+    (kill-buffer tmpbuf)))
+
+(defun gnus-output-to-mail (filename &optional ask)
+  "Append the current article to a mail file named FILENAME."
+  (setq filename (expand-file-name filename))
+  (let ((artbuf (current-buffer))
+	(tmpbuf (get-buffer-create " *Gnus-output*")))
+    (save-excursion
+      ;; Create the file, if it doesn't exist.
+      (when (and (not (get-file-buffer filename))
+		 (not (file-exists-p filename)))
+	(if (or (not ask)
+		(gnus-y-or-n-p
+		 (concat "\"" filename "\" does not exist, create it? ")))
+	    (let ((file-buffer (create-file-buffer filename)))
+	      (save-excursion
+		(set-buffer file-buffer)
+		(let ((require-final-newline nil))
+		  (gnus-write-buffer filename)))
+	      (kill-buffer file-buffer))
+	  (error "Output file does not exist")))
+      (set-buffer tmpbuf)
+      (erase-buffer)
+      (insert-buffer-substring artbuf)
+      (goto-char (point-min))
+      (if (looking-at "From ")
+	  (forward-line 1)
+	(insert "From nobody " (current-time-string) "\n"))
+      (let (case-fold-search)
+	(while (re-search-forward "^From " nil t)
+	  (beginning-of-line)
+	  (insert ">")))
+      ;; Decide whether to append to a file or to an Emacs buffer.
+      (let ((outbuf (get-file-buffer filename)))
+	(if (not outbuf)
+	    (let ((buffer-read-only nil))
+	      (save-excursion
+		(goto-char (point-max))
+		(forward-char -2)
+		(unless (looking-at "\n\n")
+		  (goto-char (point-max))
+		  (unless (bolp)
+		    (insert "\n"))
+		  (insert "\n"))
+		(goto-char (point-max))
+		(append-to-file (point-min) (point-max) filename)))
+	  ;; File has been visited, in buffer OUTBUF.
+	  (set-buffer outbuf)
+	  (let ((buffer-read-only nil))
+	    (goto-char (point-max))
+	    (unless (eobp)
+	      (insert "\n"))
+	    (insert "\n")
+	    (insert-buffer-substring tmpbuf)))))
+    (kill-buffer tmpbuf)))
+
+(defun gnus-convert-article-to-rmail ()
+  "Convert article in current buffer to Rmail message format."
+  (let ((buffer-read-only nil))
+    ;; Convert article directly into Babyl format.
+    (goto-char (point-min))
+    (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
+    (while (search-forward "\n\^_" nil t) ;single char
+      (replace-match "\n^_" t t))	;2 chars: "^" and "_"
+    (goto-char (point-max))
+    (insert "\^_")))
+
+(provide 'gnus-util)
+
+;;; gnus-util.el ends here

lisp/gnus/gnus-vm.el

@@ -0,0 +1,107 @@
+;;; gnus-vm.el --- vm interface for Gnus
+;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc.
+
+;; Author: Per Persson <pp@gnu.ai.mit.edu>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Major contributors:
+;;	Christian Limpach <Christian.Limpach@nice.ch>
+;; Some code stolen from:
+;;	Rick Sladkey <jrs@world.std.com>
+
+;;; Code:
+
+(require 'sendmail)
+(require 'message)
+(require 'gnus)
+(require 'gnus-msg)
+
+(eval-when-compile
+  (autoload 'vm-mode "vm")
+  (autoload 'vm-save-message "vm")
+  (autoload 'vm-forward-message "vm")
+  (autoload 'vm-reply "vm")
+  (autoload 'vm-mail "vm"))
+
+(defvar gnus-vm-inhibit-window-system nil
+  "Inhibit loading `win-vm' if using a window-system.
+Has to be set before gnus-vm is loaded.")
+
+(or gnus-vm-inhibit-window-system
+    (condition-case nil
+	(when window-system
+	  (require 'win-vm))
+      (error nil)))
+
+(when (not (featurep 'vm))
+  (load "vm"))
+
+(defun gnus-vm-make-folder (&optional buffer)
+  (let ((article (or buffer (current-buffer)))
+	(tmp-folder (generate-new-buffer " *tmp-folder*"))
+	(start (point-min))
+	(end (point-max)))
+    (set-buffer tmp-folder)
+    (insert-buffer-substring article start end)
+    (goto-char (point-min))
+    (if (looking-at "^\\(From [^ ]+ \\).*$")
+	(replace-match (concat "\\1" (current-time-string)))
+      (insert "From " gnus-newsgroup-name " "
+	      (current-time-string) "\n"))
+    (while (re-search-forward "\n\nFrom " nil t)
+      (replace-match "\n\n>From "))
+    ;; insert a newline, otherwise the last line gets lost
+    (goto-char (point-max))
+    (insert "\n")
+    (vm-mode)
+    tmp-folder))
+
+(defun gnus-summary-save-article-vm (&optional arg)
+  "Append the current article to a vm folder.
+If N is a positive number, save the N next articles.
+If N is a negative number, save the N previous articles.
+If N is nil and any articles have been marked with the process mark,
+save those articles instead."
+  (interactive "P")
+  (let ((gnus-default-article-saver 'gnus-summary-save-in-vm))
+    (gnus-summary-save-article arg)))
+
+(defun gnus-summary-save-in-vm (&optional folder)
+  (interactive)
+  (setq folder
+	(cond ((eq folder 'default) default-name)
+	      (folder folder)
+	      (t (gnus-read-save-file-name
+		  "Save %s in VM folder:" folder
+		  gnus-mail-save-name gnus-newsgroup-name
+		  gnus-current-headers 'gnus-newsgroup-last-mail))))
+  (gnus-eval-in-buffer-window gnus-original-article-buffer
+    (save-excursion
+      (save-restriction
+	(widen)
+	(let ((vm-folder (gnus-vm-make-folder)))
+	  (vm-save-message folder)
+	  (kill-buffer vm-folder))))))
+
+(provide 'gnus-vm)
+
+;;; gnus-vm.el ends here.

lisp/gnus/gnus-win.el

@@ -0,0 +1,550 @@
+;;; gnus-win.el --- window configuration functions for Gnus
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+
+(defgroup gnus-windows nil
+  "Window configuration."
+  :group 'gnus)
+
+(defcustom gnus-use-full-window t
+  "*If non-nil, use the entire Emacs screen."
+  :group 'gnus-windows
+  :type 'boolean)
+
+(defvar gnus-window-configuration nil
+  "Obsolete variable.  See `gnus-buffer-configuration'.")
+
+(defcustom gnus-window-min-width 2
+  "*Minimum width of Gnus buffers."
+  :group 'gnus-windows
+  :type 'integer)
+
+(defcustom gnus-window-min-height 1
+  "*Minimum height of Gnus buffers."
+  :group 'gnus-windows
+  :type 'integer)
+
+(defcustom gnus-always-force-window-configuration nil
+  "*If non-nil, always force the Gnus window configurations."
+  :group 'gnus-windows
+  :type 'boolean)
+
+(defvar gnus-buffer-configuration
+  '((group
+     (vertical 1.0
+	       (group 1.0 point)
+	       (if gnus-carpal '(group-carpal 4))))
+    (summary
+     (vertical 1.0
+	       (summary 1.0 point)
+	       (if gnus-carpal '(summary-carpal 4))))
+    (article
+     (cond
+      ((and gnus-use-picons
+	    (eq gnus-picons-display-where 'picons))
+       '(frame 1.0
+	       (vertical 1.0
+			 (summary 0.25 point)
+			 (if gnus-carpal '(summary-carpal 4))
+			 (article 1.0))
+	       (vertical ((height . 5) (width . 15)
+			  (user-position . t)
+			  (left . -1) (top . 1))
+			 (picons 1.0))))
+      (gnus-use-trees
+       '(vertical 1.0
+		  (summary 0.25 point)
+		  (tree 0.25)
+		  (article 1.0)))
+      (t
+       '(vertical 1.0
+		 (summary 0.25 point)
+		 (if gnus-carpal '(summary-carpal 4))
+		 (article 1.0)))))
+    (server
+     (vertical 1.0
+	       (server 1.0 point)
+	       (if gnus-carpal '(server-carpal 2))))
+    (browse
+     (vertical 1.0
+	       (browse 1.0 point)
+	       (if gnus-carpal '(browse-carpal 2))))
+    (message
+     (vertical 1.0
+	       (message 1.0 point)))
+    (pick
+     (vertical 1.0
+	       (article 1.0 point)))
+    (info
+     (vertical 1.0
+	       (info 1.0 point)))
+    (summary-faq
+     (vertical 1.0
+	       (summary 0.25)
+	       (faq 1.0 point)))
+    (edit-article
+     (vertical 1.0
+	       (article 1.0 point)))
+    (edit-form
+     (vertical 1.0
+	       (group 0.5)
+	       (edit-form 1.0 point)))
+    (edit-score
+     (vertical 1.0
+	       (summary 0.25)
+	       (edit-score 1.0 point)))
+    (post
+     (vertical 1.0
+	       (post 1.0 point)))
+    (reply
+     (vertical 1.0
+	       (article-copy 0.5)
+	       (message 1.0 point)))
+    (forward
+     (vertical 1.0
+	       (message 1.0 point)))
+    (reply-yank
+     (vertical 1.0
+	       (message 1.0 point)))
+    (mail-bounce
+     (vertical 1.0
+	       (article 0.5)
+	       (message 1.0 point)))
+    (draft
+     (vertical 1.0
+	       (draft 1.0 point)))
+    (pipe
+     (vertical 1.0
+	       (summary 0.25 point)
+	       (if gnus-carpal '(summary-carpal 4))
+	       ("*Shell Command Output*" 1.0)))
+    (bug
+     (vertical 1.0
+	       ("*Gnus Help Bug*" 0.5)
+	       ("*Gnus Bug*" 1.0 point)))
+    (score-trace
+     (vertical 1.0
+	       (summary 0.5 point)
+	       ("*Score Trace*" 1.0)))
+    (score-words
+     (vertical 1.0
+	       (summary 0.5 point)
+	       ("*Score Words*" 1.0)))
+    (compose-bounce
+     (vertical 1.0
+	       (article 0.5)
+	       (message 1.0 point))))
+  "Window configuration for all possible Gnus buffers.
+See the Gnus manual for an explanation of the syntax used.")
+
+(defvar gnus-window-to-buffer
+  '((group . gnus-group-buffer)
+    (summary . gnus-summary-buffer)
+    (article . gnus-article-buffer)
+    (server . gnus-server-buffer)
+    (browse . "*Gnus Browse Server*")
+    (edit-group . gnus-group-edit-buffer)
+    (edit-form . gnus-edit-form-buffer)
+    (edit-server . gnus-server-edit-buffer)
+    (group-carpal . gnus-carpal-group-buffer)
+    (summary-carpal . gnus-carpal-summary-buffer)
+    (server-carpal . gnus-carpal-server-buffer)
+    (browse-carpal . gnus-carpal-browse-buffer)
+    (edit-score . gnus-score-edit-buffer)
+    (message . gnus-message-buffer)
+    (mail . gnus-message-buffer)
+    (post-news . gnus-message-buffer)
+    (faq . gnus-faq-buffer)
+    (picons . "*Picons*")
+    (tree . gnus-tree-buffer)
+    (info . gnus-info-buffer)
+    (article-copy . gnus-article-copy)
+    (draft . gnus-draft-buffer))
+  "Mapping from short symbols to buffer names or buffer variables.")
+
+;;; Internal variables.
+
+(defvar gnus-current-window-configuration nil
+  "The most recently set window configuration.")
+
+(defvar gnus-created-frames nil)
+
+(defun gnus-kill-gnus-frames ()
+  "Kill all frames Gnus has created."
+  (while gnus-created-frames
+    (when (frame-live-p (car gnus-created-frames))
+      ;; We slap a condition-case around this `delete-frame' to ensure
+      ;; against errors if we try do delete the single frame that's left.
+      (ignore-errors
+	(delete-frame (car gnus-created-frames))))
+    (pop gnus-created-frames)))
+
+(defun gnus-window-configuration-element (list)
+  (while (and list
+	      (not (assq (car list) gnus-window-configuration)))
+    (pop list))
+  (cadr (assq (car list) gnus-window-configuration)))
+
+(defun gnus-windows-old-to-new (setting)
+  ;; First we take care of the really, really old Gnus 3 actions.
+  (when (symbolp setting)
+    (setq setting
+	  ;; Take care of ooold GNUS 3.x values.
+	  (cond ((eq setting 'SelectArticle) 'article)
+		((memq setting '(SelectNewsgroup SelectSubject ExpandSubject))
+		 'summary)
+		((memq setting '(ExitNewsgroup)) 'group)
+		(t setting))))
+  (if (or (listp setting)
+	  (not (and gnus-window-configuration
+		    (memq setting '(group summary article)))))
+      setting
+    (let* ((elem
+	    (cond
+	     ((eq setting 'group)
+	      (gnus-window-configuration-element
+	       '(group newsgroups ExitNewsgroup)))
+	     ((eq setting 'summary)
+	      (gnus-window-configuration-element
+	       '(summary SelectNewsgroup SelectSubject ExpandSubject)))
+	     ((eq setting 'article)
+	      (gnus-window-configuration-element
+	       '(article SelectArticle)))))
+	   (total (apply '+ elem))
+	   (types '(group summary article))
+	   (pbuf (if (eq setting 'newsgroups) 'group 'summary))
+	   (i 0)
+	   perc out)
+      (while (< i 3)
+	(or (not (numberp (nth i elem)))
+	    (zerop (nth i elem))
+	    (progn
+	      (setq perc (if (= i 2)
+			     1.0
+			   (/ (float (nth i elem)) total)))
+	      (push (if (eq pbuf (nth i types))
+			(list (nth i types) perc 'point)
+		      (list (nth i types) perc))
+		    out)))
+	(incf i))
+      `(vertical 1.0 ,@(nreverse out)))))
+
+;;;###autoload
+(defun gnus-add-configuration (conf)
+  "Add the window configuration CONF to `gnus-buffer-configuration'."
+  (setq gnus-buffer-configuration
+	(cons conf (delq (assq (car conf) gnus-buffer-configuration)
+			 gnus-buffer-configuration))))
+
+(defvar gnus-frame-list nil)
+
+(defun gnus-configure-frame (split &optional window)
+  "Split WINDOW according to SPLIT."
+  (unless window
+    (setq window (get-buffer-window (current-buffer))))
+  (select-window window)
+  ;; This might be an old-stylee buffer config.
+  (when (vectorp split)
+    (setq split (append split nil)))
+  (when (or (consp (car split))
+	    (vectorp (car split)))
+    (push 1.0 split)
+    (push 'vertical split))
+  ;; The SPLIT might be something that is to be evaled to
+  ;; return a new SPLIT.
+  (while (and (not (assq (car split) gnus-window-to-buffer))
+	      (gnus-functionp (car split)))
+    (setq split (eval split)))
+  (let* ((type (car split))
+	 (subs (cddr split))
+	 (len (if (eq type 'horizontal) (window-width) (window-height)))
+	 (total 0)
+	 (window-min-width (or gnus-window-min-width window-min-width))
+	 (window-min-height (or gnus-window-min-height window-min-height))
+	 s result new-win rest comp-subs size sub)
+    (cond
+     ;; Nothing to do here.
+     ((null split))
+     ;; Don't switch buffers.
+     ((null type)
+      (and (memq 'point split) window))
+     ;; This is a buffer to be selected.
+     ((not (memq type '(frame horizontal vertical)))
+      (let ((buffer (cond ((stringp type) type)
+			  (t (cdr (assq type gnus-window-to-buffer)))))
+	    buf)
+	(unless buffer
+	  (error "Illegal buffer type: %s" type))
+	(unless (setq buf (get-buffer (if (symbolp buffer)
+					  (symbol-value buffer) buffer)))
+	  (setq buf (get-buffer-create (if (symbolp buffer)
+					   (symbol-value buffer) buffer))))
+	(switch-to-buffer buf)
+	;; We return the window if it has the `point' spec.
+	(and (memq 'point split) window)))
+     ;; This is a frame split.
+     ((eq type 'frame)
+      (unless gnus-frame-list
+	(setq gnus-frame-list (list (window-frame
+				     (get-buffer-window (current-buffer))))))
+      (let ((i 0)
+	    params frame fresult)
+	(while (< i (length subs))
+	  ;; Frame parameter is gotten from the sub-split.
+	  (setq params (cadr (elt subs i)))
+	  ;; It should be a list.
+	  (unless (listp params)
+	    (setq params nil))
+	  ;; Create a new frame?
+	  (unless (setq frame (elt gnus-frame-list i))
+	    (nconc gnus-frame-list (list (setq frame (make-frame params))))
+	    (push frame gnus-created-frames))
+	  ;; Is the old frame still alive?
+	  (unless (frame-live-p frame)
+	    (setcar (nthcdr i gnus-frame-list)
+		    (setq frame (make-frame params))))
+	  ;; Select the frame in question and do more splits there.
+	  (select-frame frame)
+	  (setq fresult (or (gnus-configure-frame (elt subs i)) fresult))
+	  (incf i))
+	;; Select the frame that has the selected buffer.
+	(when fresult
+	  (select-frame (window-frame fresult)))))
+     ;; This is a normal split.
+     (t
+      (when (> (length subs) 0)
+	;; First we have to compute the sizes of all new windows.
+	(while subs
+	  (setq sub (append (pop subs) nil))
+	  (while (and (not (assq (car sub) gnus-window-to-buffer))
+		      (gnus-functionp (car sub)))
+	    (setq sub (eval sub)))
+	  (when sub
+	    (push sub comp-subs)
+	    (setq size (cadar comp-subs))
+	    (cond ((equal size 1.0)
+		   (setq rest (car comp-subs))
+		   (setq s 0))
+		  ((floatp size)
+		   (setq s (floor (* size len))))
+		  ((integerp size)
+		   (setq s size))
+		  (t
+		   (error "Illegal size: %s" size)))
+	    ;; Try to make sure that we are inside the safe limits.
+	    (cond ((zerop s))
+		  ((eq type 'horizontal)
+		   (setq s (max s window-min-width)))
+		  ((eq type 'vertical)
+		   (setq s (max s window-min-height))))
+	    (setcar (cdar comp-subs) s)
+	    (incf total s)))
+	;; Take care of the "1.0" spec.
+	(if rest
+	    (setcar (cdr rest) (- len total))
+	  (error "No 1.0 specs in %s" split))
+	;; The we do the actual splitting in a nice recursive
+	;; fashion.
+	(setq comp-subs (nreverse comp-subs))
+	(while comp-subs
+	  (if (null (cdr comp-subs))
+	      (setq new-win window)
+	    (setq new-win
+		  (split-window window (cadar comp-subs)
+				(eq type 'horizontal))))
+	  (setq result (or (gnus-configure-frame
+			    (car comp-subs) window)
+			   result))
+	  (select-window new-win)
+	  (setq window new-win)
+	  (setq comp-subs (cdr comp-subs))))
+      ;; Return the proper window, if any.
+      (when result
+	(select-window result))))))
+
+(defvar gnus-frame-split-p nil)
+
+(defun gnus-configure-windows (setting &optional force)
+  (setq gnus-current-window-configuration setting)
+  (setq force (or force gnus-always-force-window-configuration))
+  (setq setting (gnus-windows-old-to-new setting))
+  (let ((split (if (symbolp setting)
+		   (cadr (assq setting gnus-buffer-configuration))
+		 setting))
+	all-visible)
+
+    (setq gnus-frame-split-p nil)
+
+    (unless split
+      (error "No such setting: %s" setting))
+
+    (if (and (setq all-visible (gnus-all-windows-visible-p split))
+	     (not force))
+	;; All the windows mentioned are already visible, so we just
+	;; put point in the assigned buffer, and do not touch the
+	;; winconf.
+	(select-window all-visible)
+
+      ;; Either remove all windows or just remove all Gnus windows.
+      (let ((frame (selected-frame)))
+	(unwind-protect
+	    (if gnus-use-full-window
+		;; We want to remove all other windows.
+		(if (not gnus-frame-split-p)
+		    ;; This is not a `frame' split, so we ignore the
+		    ;; other frames.
+		    (delete-other-windows)
+		  ;; This is a `frame' split, so we delete all windows
+		  ;; on all frames.
+		  (gnus-delete-windows-in-gnusey-frames))
+	      ;; Just remove some windows.
+	      (gnus-remove-some-windows)
+	      (switch-to-buffer nntp-server-buffer))
+	  (select-frame frame)))
+
+      (switch-to-buffer nntp-server-buffer)
+      (gnus-configure-frame split (get-buffer-window (current-buffer))))))
+
+(defun gnus-delete-windows-in-gnusey-frames ()
+  "Do a `delete-other-windows' in all frames that have Gnus windows."
+  (let ((buffers
+	 (mapcar
+	  (lambda (elem)
+	    (if (symbolp (cdr elem))
+		(when (and (boundp (cdr elem))
+			   (symbol-value (cdr elem)))
+		  (get-buffer (symbol-value (cdr elem))))
+	      (when (cdr elem)
+		(get-buffer (cdr elem)))))
+	  gnus-window-to-buffer)))
+    (mapcar
+     (lambda (frame)
+       (unless (eq (cdr (assq 'minibuffer
+			      (frame-parameters frame)))
+		   'only)
+	 (select-frame frame)
+	 (let (do-delete)
+	   (walk-windows
+	    (lambda (window)
+	      (when (memq (window-buffer window) buffers)
+		(setq do-delete t))))
+	   (when do-delete
+	     (delete-other-windows)))))
+     (frame-list))))
+
+(defun gnus-all-windows-visible-p (split)
+  "Say whether all buffers in SPLIT are currently visible.
+In particular, the value returned will be the window that
+should have point."
+  (let ((stack (list split))
+	(all-visible t)
+	type buffer win buf)
+    (while (and (setq split (pop stack))
+		all-visible)
+      ;; Be backwards compatible.
+      (when (vectorp split)
+	(setq split (append split nil)))
+      (when (or (consp (car split))
+		(vectorp (car split)))
+	(push 1.0 split)
+	(push 'vertical split))
+      ;; The SPLIT might be something that is to be evaled to
+      ;; return a new SPLIT.
+      (while (and (not (assq (car split) gnus-window-to-buffer))
+		  (gnus-functionp (car split)))
+	(setq split (eval split)))
+
+      (setq type (elt split 0))
+      (cond
+       ;; Nothing here.
+       ((null split) t)
+       ;; A buffer.
+       ((not (memq type '(horizontal vertical frame)))
+	(setq buffer (cond ((stringp type) type)
+			   (t (cdr (assq type gnus-window-to-buffer)))))
+	(unless buffer
+	  (error "Illegal buffer type: %s" type))
+	(when (setq buf (get-buffer (if (symbolp buffer)
+					(symbol-value buffer)
+				      buffer)))
+	  (setq win (get-buffer-window buf t)))
+	(if win
+	    (when (memq 'point split)
+	      (setq all-visible win))
+	  (setq all-visible nil)))
+       (t
+	(when (eq type 'frame)
+	  (setq gnus-frame-split-p t))
+	(setq stack (append (cddr split) stack)))))
+    (unless (eq all-visible t)
+      all-visible)))
+
+(defun gnus-window-top-edge (&optional window)
+  (nth 1 (window-edges window)))
+
+(defun gnus-remove-some-windows ()
+  (let ((buffers gnus-window-to-buffer)
+	buf bufs lowest-buf lowest)
+    (save-excursion
+      ;; Remove windows on all known Gnus buffers.
+      (while buffers
+	(setq buf (cdar buffers))
+	(when (symbolp buf)
+	  (setq buf (and (boundp buf) (symbol-value buf))))
+	(and buf
+	     (get-buffer-window buf)
+	     (progn
+	       (push buf bufs)
+	       (pop-to-buffer buf)
+	       (when (or (not lowest)
+			 (< (gnus-window-top-edge) lowest))
+		 (setq lowest (gnus-window-top-edge))
+		 (setq lowest-buf buf))))
+	(setq buffers (cdr buffers)))
+      ;; Remove windows on *all* summary buffers.
+      (walk-windows
+       (lambda (win)
+	 (let ((buf (window-buffer win)))
+	   (when (string-match	"^\\*Summary" (buffer-name buf))
+	     (push buf bufs)
+	     (pop-to-buffer buf)
+	     (when (or (not lowest)
+		       (< (gnus-window-top-edge) lowest))
+	       (setq lowest-buf buf)
+	       (setq lowest (gnus-window-top-edge)))))))
+      (when lowest-buf
+	(pop-to-buffer lowest-buf)
+	(switch-to-buffer nntp-server-buffer))
+      (while bufs
+	(when (not (eq (car bufs) lowest-buf))
+	  (delete-windows-on (car bufs)))
+	(setq bufs (cdr bufs))))))
+
+(provide 'gnus-win)
+
+;;; gnus-win.el ends here

lisp/gnus/md5.el

@@ -0,0 +1,409 @@
+;;; md5.el -- MD5 Message Digest Algorithm
+;;; Gareth Rees <gdr11@cl.cam.ac.uk>
+
+;; LCD Archive Entry:
+;; md5|Gareth Rees|gdr11@cl.cam.ac.uk|
+;; MD5 cryptographic message digest algorithm|
+;; 13-Nov-95|1.0|~/misc/md5.el.Z|
+
+;;; Details: ------------------------------------------------------------------
+
+;; This is a direct translation into Emacs LISP of the reference C
+;; implementation of the MD5 Message-Digest Algorithm written by RSA
+;; Data Security, Inc.
+;; 
+;; The algorithm takes a message (that is, a string of bytes) and
+;; computes a 16-byte checksum or "digest" for the message.  This digest
+;; is supposed to be cryptographically strong in the sense that if you
+;; are given a 16-byte digest D, then there is no easier way to
+;; construct a message whose digest is D than to exhaustively search the
+;; space of messages.  However, the robustness of the algorithm has not
+;; been proven, and a similar algorithm (MD4) was shown to be unsound,
+;; so treat with caution!
+;; 
+;; The C algorithm uses 32-bit integers; because GNU Emacs
+;; implementations provide 28-bit integers (with 24-bit integers on
+;; versions prior to 19.29), the code represents a 32-bit integer as the
+;; cons of two 16-bit integers.  The most significant word is stored in
+;; the car and the least significant in the cdr.  The algorithm requires
+;; at least 17 bits of integer representation in order to represent the
+;; carry from a 16-bit addition.
+
+;;; Usage: --------------------------------------------------------------------
+
+;; To compute the MD5 Message Digest for a message M (represented as a
+;; string or as a vector of bytes), call
+;; 
+;;   (md5-encode M)
+;; 
+;; which returns the message digest as a vector of 16 bytes.  If you
+;; need to supply the message in pieces M1, M2, ... Mn, then call
+;; 
+;;   (md5-init)
+;;   (md5-update M1)
+;;   (md5-update M2)
+;;   ...
+;;   (md5-update Mn)
+;;   (md5-final)
+
+;;; Copyright and licence: ----------------------------------------------------
+
+;; Copyright (C) 1995 by Gareth Rees
+;; Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm
+;; 
+;; md5.el is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the
+;; Free Software Foundation; either version 2, or (at your option) any
+;; later version.
+;; 
+;; md5.el is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
+;; for more details.
+;; 
+;; The original copyright notice is given below, as required by the
+;; licence for the original code.  This code is distributed under *both*
+;; RSA's original licence and the GNU General Public Licence.  (There
+;; should be no problems, as the former is more liberal than the
+;; latter).
+
+;;; Original copyright notice: ------------------------------------------------
+
+;; Copyright (C) 1990, RSA Data Security, Inc. All rights reserved.
+;;
+;; License to copy and use this software is granted provided that it is
+;; identified as the "RSA Data Security, Inc. MD5 Message- Digest
+;; Algorithm" in all material mentioning or referencing this software or
+;; this function.
+;;
+;; License is also granted to make and use derivative works provided
+;; that such works are identified as "derived from the RSA Data
+;; Security, Inc. MD5 Message-Digest Algorithm" in all material
+;; mentioning or referencing the derived work.
+;;
+;; RSA Data Security, Inc. makes no representations concerning either
+;; the merchantability of this software or the suitability of this
+;; software for any particular purpose.  It is provided "as is" without
+;; express or implied warranty of any kind.
+;;
+;; These notices must be retained in any copies of any part of this
+;; documentation and/or software.
+
+;;; Code: ---------------------------------------------------------------------
+
+(defvar md5-program "md5"
+  "*Program that reads a message on its standard input and writes an
+MD5 digest on its output.")
+
+(defvar md5-maximum-internal-length 4096
+  "*The maximum size of a piece of data that should use the MD5 routines
+written in lisp.  If a message exceeds this, it will be run through an
+external filter for processing.  Also see the `md5-program' variable.
+This variable has no effect if you call the md5-init|update|final
+functions - only used by the `md5' function's simpler interface.")
+
+(defvar md5-bits (make-vector 4 0)
+  "Number of bits handled, modulo 2^64.
+Represented as four 16-bit numbers, least significant first.")
+(defvar md5-buffer (make-vector 4 '(0 . 0))
+  "Scratch buffer (four 32-bit integers).")
+(defvar md5-input (make-vector 64 0)
+  "Input buffer (64 bytes).")
+
+(defun md5-unhex (x)
+  (if (> x ?9)
+      (if (>= x ?a)
+	  (+ 10 (- x ?a))
+	(+ 10 (- x ?A)))
+    (- x ?0)))
+
+(defun md5-encode (message)
+  "Encodes MESSAGE using the MD5 message digest algorithm.
+MESSAGE must be a string or an array of bytes.
+Returns a vector of 16 bytes containing the message digest."
+  (if (<= (length message) md5-maximum-internal-length)
+      (progn
+	(md5-init)
+	(md5-update message)
+	(md5-final))
+    (save-excursion
+      (set-buffer (get-buffer-create " *md5-work*"))
+      (erase-buffer)
+      (insert message)
+      (call-process-region (point-min) (point-max)
+			   (or shell-file-name "/bin/sh")
+			   t (current-buffer) nil
+			   "-c" md5-program)
+      ;; MD5 digest is 32 chars long
+      ;; mddriver adds a newline to make neaten output for tty
+      ;; viewing, make sure we leave it behind.
+      (let ((data (buffer-substring (point-min) (+ (point-min) 32)))
+	    (vec (make-vector 16 0))
+	    (ctr 0))
+	(while (< ctr 16)
+	  (aset vec ctr (+ (* 16 (md5-unhex (aref data (* ctr 2))))
+			   (md5-unhex (aref data (1+ (* ctr 2))))))
+	  (setq ctr (1+ ctr)))))))
+
+(defsubst md5-add (x y)
+  "Return 32-bit sum of 32-bit integers X and Y."
+  (let ((m (+ (car x) (car y)))
+        (l (+ (cdr x) (cdr y))))
+    (cons (logand 65535 (+ m (lsh l -16))) (logand l 65535))))
+
+;; FF, GG, HH and II are basic MD5 functions, providing transformations
+;; for rounds 1, 2, 3 and 4 respectively.  Each function follows this
+;; pattern of computation (where ROTATE(x,y) means rotate 32-bit value x
+;; by y bits to the left):
+;; 
+;;   FF(a,b,c,d,x,s,ac) = ROTATE(a + F(b,c,d) + x + ac,s) + b
+;; 
+;; so we use the macro `md5-make-step' to construct each one.  The
+;; helper functions F, G, H and I operate on 16-bit numbers; the full
+;; operation splits its inputs, operates on the halves separately and
+;; then puts the results together.
+
+(defsubst md5-F (x y z) (logior (logand x y) (logand (lognot x) z)))
+(defsubst md5-G (x y z) (logior (logand x z) (logand y (lognot z))))
+(defsubst md5-H (x y z) (logxor x y z))
+(defsubst md5-I (x y z) (logxor y (logior x (logand 65535 (lognot z)))))
+
+(defmacro md5-make-step (name func)
+  (`
+   (defun (, name) (a b c d x s ac)
+     (let*
+         ((m1 (+ (car a) ((, func) (car b) (car c) (car d)) (car x) (car ac)))
+          (l1 (+ (cdr a) ((, func) (cdr b) (cdr c) (cdr d)) (cdr x) (cdr ac)))
+          (m2 (logand 65535 (+ m1 (lsh l1 -16))))
+          (l2 (logand 65535 l1))
+          (m3 (logand 65535 (if (> s 15)
+                                (+ (lsh m2 (- s 32)) (lsh l2 (- s 16)))
+                              (+ (lsh m2 s) (lsh l2 (- s 16))))))
+          (l3 (logand 65535 (if (> s 15)
+                                (+ (lsh l2 (- s 32)) (lsh m2 (- s 16)))
+                              (+ (lsh l2 s) (lsh m2 (- s 16)))))))
+       (md5-add (cons m3 l3) b)))))
+
+(md5-make-step md5-FF md5-F)
+(md5-make-step md5-GG md5-G)
+(md5-make-step md5-HH md5-H)
+(md5-make-step md5-II md5-I)
+
+(defun md5-init ()
+  "Initialise the state of the message-digest routines."
+  (aset md5-bits 0 0)
+  (aset md5-bits 1 0)
+  (aset md5-bits 2 0)
+  (aset md5-bits 3 0)
+  (aset md5-buffer 0 '(26437 .  8961))
+  (aset md5-buffer 1 '(61389 . 43913))
+  (aset md5-buffer 2 '(39098 . 56574))
+  (aset md5-buffer 3 '( 4146 . 21622)))
+
+(defun md5-update (string)
+  "Update the current MD5 state with STRING (an array of bytes)."
+  (let ((len (length string))
+        (i 0)
+        (j 0))
+    (while (< i len)
+      ;; Compute number of bytes modulo 64
+      (setq j (% (/ (aref md5-bits 0) 8) 64))
+
+      ;; Store this byte (truncating to 8 bits to be sure)
+      (aset md5-input j (logand 255 (aref string i)))
+
+      ;; Update number of bits by 8 (modulo 2^64)
+      (let ((c 8) (k 0))
+        (while (and (> c 0) (< k 4))
+          (let ((b (aref md5-bits k)))
+            (aset md5-bits k (logand 65535 (+ b c)))
+            (setq c (if (> b (- 65535 c)) 1 0)
+                  k (1+ k)))))
+
+      ;; Increment number of bytes processed
+      (setq i (1+ i))
+
+      ;; When 64 bytes accumulated, pack them into sixteen 32-bit
+      ;; integers in the array `in' and then tranform them.
+      (if (= j 63)
+          (let ((in (make-vector 16 (cons 0 0)))
+                (k 0)
+                (kk 0))
+            (while (< k 16)
+              (aset in k (md5-pack md5-input kk))
+              (setq k (+ k 1) kk (+ kk 4)))
+            (md5-transform in))))))
+
+(defun md5-pack (array i)
+  "Pack the four bytes at ARRAY reference I to I+3 into a 32-bit integer."
+  (cons (+ (lsh (aref array (+ i 3)) 8) (aref array (+ i 2)))
+        (+ (lsh (aref array (+ i 1)) 8) (aref array (+ i 0)))))
+
+(defun md5-byte (array n b)
+  "Unpack byte B (0 to 3) from Nth member of ARRAY of 32-bit integers."
+  (let ((e (aref array n)))
+    (cond ((eq b 0) (logand 255 (cdr e)))
+          ((eq b 1) (lsh (cdr e) -8))
+          ((eq b 2) (logand 255 (car e)))
+          ((eq b 3) (lsh (car e) -8)))))
+
+(defun md5-final ()
+  (let ((in (make-vector 16 (cons 0 0)))
+        (j 0)
+        (digest (make-vector 16 0))
+        (padding))
+
+    ;; Save the number of bits in the message
+    (aset in 14 (cons (aref md5-bits 1) (aref md5-bits 0)))
+    (aset in 15 (cons (aref md5-bits 3) (aref md5-bits 2)))
+
+    ;; Compute number of bytes modulo 64
+    (setq j (% (/ (aref md5-bits 0) 8) 64))
+
+    ;; Pad out computation to 56 bytes modulo 64
+    (setq padding (make-vector (if (< j 56) (- 56 j) (- 120 j)) 0))
+    (aset padding 0 128)
+    (md5-update padding)
+
+    ;; Append length in bits and transform
+    (let ((k 0) (kk 0))
+      (while (< k 14)
+        (aset in k (md5-pack md5-input kk))
+        (setq k (+ k 1) kk (+ kk 4))))
+    (md5-transform in)
+
+    ;; Store the results in the digest
+    (let ((k 0) (kk 0))
+      (while (< k 4)
+        (aset digest (+ kk 0) (md5-byte md5-buffer k 0))
+        (aset digest (+ kk 1) (md5-byte md5-buffer k 1))
+        (aset digest (+ kk 2) (md5-byte md5-buffer k 2))
+        (aset digest (+ kk 3) (md5-byte md5-buffer k 3))
+        (setq k (+ k 1) kk (+ kk 4))))
+
+    ;; Return digest
+    digest))
+
+;; It says in the RSA source, "Note that if the Mysterious Constants are
+;; arranged backwards in little-endian order and decrypted with the DES
+;; they produce OCCULT MESSAGES!"  Security through obscurity?
+
+(defun md5-transform (in)
+  "Basic MD5 step. Transform md5-buffer based on array IN."
+  (let ((a (aref md5-buffer 0))
+        (b (aref md5-buffer 1))
+        (c (aref md5-buffer 2))
+        (d (aref md5-buffer 3)))
+    (setq
+     a (md5-FF a b c d (aref in  0)  7 '(55146 . 42104))
+     d (md5-FF d a b c (aref in  1) 12 '(59591 . 46934))
+     c (md5-FF c d a b (aref in  2) 17 '( 9248 . 28891))
+     b (md5-FF b c d a (aref in  3) 22 '(49597 . 52974))
+     a (md5-FF a b c d (aref in  4)  7 '(62844 .  4015))
+     d (md5-FF d a b c (aref in  5) 12 '(18311 . 50730))
+     c (md5-FF c d a b (aref in  6) 17 '(43056 . 17939))
+     b (md5-FF b c d a (aref in  7) 22 '(64838 . 38145))
+     a (md5-FF a b c d (aref in  8)  7 '(27008 . 39128))
+     d (md5-FF d a b c (aref in  9) 12 '(35652 . 63407))
+     c (md5-FF c d a b (aref in 10) 17 '(65535 . 23473))
+     b (md5-FF b c d a (aref in 11) 22 '(35164 . 55230))
+     a (md5-FF a b c d (aref in 12)  7 '(27536 .  4386))
+     d (md5-FF d a b c (aref in 13) 12 '(64920 . 29075))
+     c (md5-FF c d a b (aref in 14) 17 '(42617 . 17294))
+     b (md5-FF b c d a (aref in 15) 22 '(18868 .  2081))
+     a (md5-GG a b c d (aref in  1)  5 '(63006 .  9570))
+     d (md5-GG d a b c (aref in  6)  9 '(49216 . 45888))
+     c (md5-GG c d a b (aref in 11) 14 '( 9822 . 23121))
+     b (md5-GG b c d a (aref in  0) 20 '(59830 . 51114))
+     a (md5-GG a b c d (aref in  5)  5 '(54831 .  4189))
+     d (md5-GG d a b c (aref in 10)  9 '(  580 .  5203))
+     c (md5-GG c d a b (aref in 15) 14 '(55457 . 59009))
+     b (md5-GG b c d a (aref in  4) 20 '(59347 . 64456))
+     a (md5-GG a b c d (aref in  9)  5 '( 8673 . 52710))
+     d (md5-GG d a b c (aref in 14)  9 '(49975 .  2006))
+     c (md5-GG c d a b (aref in  3) 14 '(62677 .  3463))
+     b (md5-GG b c d a (aref in  8) 20 '(17754 .  5357))
+     a (md5-GG a b c d (aref in 13)  5 '(43491 . 59653))
+     d (md5-GG d a b c (aref in  2)  9 '(64751 . 41976))
+     c (md5-GG c d a b (aref in  7) 14 '(26479 .   729))
+     b (md5-GG b c d a (aref in 12) 20 '(36138 . 19594))
+     a (md5-HH a b c d (aref in  5)  4 '(65530 . 14658))
+     d (md5-HH d a b c (aref in  8) 11 '(34673 . 63105))
+     c (md5-HH c d a b (aref in 11) 16 '(28061 . 24866))
+     b (md5-HH b c d a (aref in 14) 23 '(64997 . 14348))
+     a (md5-HH a b c d (aref in  1)  4 '(42174 . 59972))
+     d (md5-HH d a b c (aref in  4) 11 '(19422 . 53161))
+     c (md5-HH c d a b (aref in  7) 16 '(63163 . 19296))
+     b (md5-HH b c d a (aref in 10) 23 '(48831 . 48240))
+     a (md5-HH a b c d (aref in 13)  4 '(10395 . 32454))
+     d (md5-HH d a b c (aref in  0) 11 '(60065 . 10234))
+     c (md5-HH c d a b (aref in  3) 16 '(54511 . 12421))
+     b (md5-HH b c d a (aref in  6) 23 '( 1160 .  7429))
+     a (md5-HH a b c d (aref in  9)  4 '(55764 . 53305))
+     d (md5-HH d a b c (aref in 12) 11 '(59099 . 39397))
+     c (md5-HH c d a b (aref in 15) 16 '( 8098 . 31992))
+     b (md5-HH b c d a (aref in  2) 23 '(50348 . 22117))
+     a (md5-II a b c d (aref in  0)  6 '(62505 .  8772))
+     d (md5-II d a b c (aref in  7) 10 '(17194 . 65431))
+     c (md5-II c d a b (aref in 14) 15 '(43924 .  9127))
+     b (md5-II b c d a (aref in  5) 21 '(64659 . 41017))
+     a (md5-II a b c d (aref in 12)  6 '(25947 . 22979))
+     d (md5-II d a b c (aref in  3) 10 '(36620 . 52370))
+     c (md5-II c d a b (aref in 10) 15 '(65519 . 62589))
+     b (md5-II b c d a (aref in  1) 21 '(34180 . 24017))
+     a (md5-II a b c d (aref in  8)  6 '(28584 . 32335))
+     d (md5-II d a b c (aref in 15) 10 '(65068 . 59104))
+     c (md5-II c d a b (aref in  6) 15 '(41729 . 17172))
+     b (md5-II b c d a (aref in 13) 21 '(19976 .  4513))
+     a (md5-II a b c d (aref in  4)  6 '(63315 . 32386))
+     d (md5-II d a b c (aref in 11) 10 '(48442 . 62005))
+     c (md5-II c d a b (aref in  2) 15 '(10967 . 53947))
+     b (md5-II b c d a (aref in  9) 21 '(60294 . 54161)))
+
+     (aset md5-buffer 0 (md5-add (aref md5-buffer 0) a))
+     (aset md5-buffer 1 (md5-add (aref md5-buffer 1) b))
+     (aset md5-buffer 2 (md5-add (aref md5-buffer 2) c))
+     (aset md5-buffer 3 (md5-add (aref md5-buffer 3) d))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Here begins the merger with the XEmacs API and the md5.el from the URL
+;;; package.  Courtesy wmperry@spry.com
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defun md5 (object &optional start end)
+  "Return the MD5 (a secure message digest algorithm) of an object.
+OBJECT is either a string or a buffer.
+Optional arguments START and END denote buffer positions for computing the
+hash of a portion of OBJECT."
+ (let ((buffer nil))
+    (unwind-protect
+	(save-excursion
+	  (setq buffer (generate-new-buffer " *md5-work*"))
+	  (set-buffer buffer)
+	  (cond
+	   ((bufferp object)
+	    (insert-buffer-substring object start end))
+	   ((stringp object)
+	    (insert (if (or start end)
+			(substring object start end)
+		      object)))
+	   (t nil))
+	  (prog1
+	      (if (<= (point-max) md5-maximum-internal-length)
+		  (mapconcat
+		   (function (lambda (node) (format "%02x" node)))
+		   (md5-encode (buffer-string))
+		   "")
+		(call-process-region (point-min) (point-max)
+				     (or shell-file-name "/bin/sh")
+				     t buffer nil
+				     "-c" md5-program)
+		;; MD5 digest is 32 chars long
+		;; mddriver adds a newline to make neaten output for tty
+		;; viewing, make sure we leave it behind.
+		(buffer-substring (point-min) (+ (point-min) 32)))
+	    (kill-buffer buffer)))
+      (and buffer (kill-buffer buffer) nil))))
+
+(provide 'md5)
+
+;;; md5.el ends here ----------------------------------------------------------

lisp/gnus/messcompat.el

@@ -0,0 +1,86 @@
+;;; messcompat.el --- making message mode compatible with mail mode
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: mail, news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This file tries to provide backward compatability with sendmail.el
+;; for Message mode.  It should be used by simply adding
+;;
+;; (require 'messcompat)
+;;
+;; to the .emacs file.  Loading it after Message mode has been
+;; loaded will have no effect.
+
+;;; Code:
+
+(require 'sendmail)
+
+(defvar message-from-style mail-from-style
+  "*Specifies how \"From\" headers look.
+
+If `nil', they contain just the return address like:
+	king@grassland.com
+If `parens', they look like:
+	king@grassland.com (Elvis Parsley)
+If `angles', they look like:
+	Elvis Parsley <king@grassland.com>
+
+Otherwise, most addresses look like `angles', but they look like
+`parens' if `angles' would need quoting and `parens' would not.")
+
+(defvar message-interactive mail-interactive
+  "Non-nil means when sending a message wait for and display errors.
+nil means let mailer mail back a message to report errors.")
+
+(defvar message-setup-hook mail-setup-hook
+  "Normal hook, run each time a new outgoing message is initialized.
+The function `message-setup' runs this hook.")
+
+(defvar message-mode-hook mail-mode-hook
+  "Hook run in message mode buffers.")
+
+(defvar message-indentation-spaces mail-indentation-spaces
+  "*Number of spaces to insert at the beginning of each cited line.
+Used by `message-yank-original' via `message-yank-cite'.")
+
+(defvar message-signature mail-signature
+  "*String to be inserted at the end of the message buffer.
+If t, the `message-signature-file' file will be inserted instead.
+If a function, the result from the function will be used instead.
+If a form, the result from the form will be used instead.")
+
+;;;###autoload
+(defvar message-signature-file mail-signature-file
+  "*File containing the text inserted at end of message. buffer.")
+
+(defvar message-default-headers mail-default-headers
+  "*A string containing header lines to be inserted in outgoing messages.
+It is inserted before you edit the message, so you can edit or delete
+these lines.")
+
+(defvar message-send-hook mail-send-hook
+  "Hook run before sending messages.")
+
+(provide 'messcompat)
+
+;;; messcompat.el ends here

lisp/gnus/nnbabyl.el

@@ -0,0 +1,650 @@
+;;; nnbabyl.el --- rmail mbox access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; For an overview of what the interface functions do, please see the
+;; Gnus sources.
+
+;;; Code:
+
+(require 'nnheader)
+(require 'rmail)
+(require 'nnmail)
+(require 'nnoo)
+(eval-when-compile (require 'cl))
+
+(nnoo-declare nnbabyl)
+
+(defvoo nnbabyl-mbox-file (expand-file-name "~/RMAIL")
+  "The name of the rmail box file in the users home directory.")
+
+(defvoo nnbabyl-active-file (expand-file-name "~/.rmail-active")
+  "The name of the active file for the rmail box.")
+
+(defvoo nnbabyl-get-new-mail t
+  "If non-nil, nnbabyl will check the incoming mail file and split the mail.")
+
+(defvoo nnbabyl-prepare-save-mail-hook nil
+  "Hook run narrowed to an article before saving.")
+
+
+
+(defvar nnbabyl-mail-delimiter "\^_")
+
+(defconst nnbabyl-version "nnbabyl 1.0"
+  "nnbabyl version.")
+
+(defvoo nnbabyl-mbox-buffer nil)
+(defvoo nnbabyl-current-group nil)
+(defvoo nnbabyl-status-string "")
+(defvoo nnbabyl-group-alist nil)
+(defvoo nnbabyl-active-timestamp nil)
+
+(defvoo nnbabyl-previous-buffer-mode nil)
+
+(eval-and-compile
+  (autoload 'gnus-set-text-properties "gnus-ems"))
+
+
+
+;;; Interface functions
+
+(nnoo-define-basics nnbabyl)
+
+(deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (let ((number (length articles))
+	  (count 0)
+	  (delim (concat "^" nnbabyl-mail-delimiter))
+	  article art-string start stop)
+      (nnbabyl-possibly-change-newsgroup group server)
+      (while (setq article (pop articles))
+	(setq art-string (nnbabyl-article-string article))
+	(set-buffer nnbabyl-mbox-buffer)
+	(end-of-line)
+	(when (or (search-forward art-string nil t)
+		  (search-backward art-string nil t))
+	  (unless (re-search-backward delim nil t)
+	    (goto-char (point-min)))
+	  (while (and (not (looking-at ".+:"))
+		      (zerop (forward-line 1))))
+	  (setq start (point))
+	  (search-forward "\n\n" nil t)
+	  (setq stop (1- (point)))
+	  (set-buffer nntp-server-buffer)
+	  (insert "221 ")
+	  (princ article (current-buffer))
+	  (insert " Article retrieved.\n")
+	  (insert-buffer-substring nnbabyl-mbox-buffer start stop)
+	  (goto-char (point-max))
+	  (insert ".\n"))
+	(and (numberp nnmail-large-newsgroup)
+	     (> number nnmail-large-newsgroup)
+	     (zerop (% (incf count) 20))
+	     (nnheader-message 5 "nnbabyl: Receiving headers... %d%%"
+			       (/ (* count 100) number))))
+
+      (and (numberp nnmail-large-newsgroup)
+	   (> number nnmail-large-newsgroup)
+	   (nnheader-message 5 "nnbabyl: Receiving headers...done"))
+
+      (set-buffer nntp-server-buffer)
+      (nnheader-fold-continuation-lines)
+      'headers)))
+
+(deffoo nnbabyl-open-server (server &optional defs)
+  (nnoo-change-server 'nnbabyl server defs)
+  (nnbabyl-create-mbox)
+  (cond
+   ((not (file-exists-p nnbabyl-mbox-file))
+    (nnbabyl-close-server)
+    (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file))
+   ((file-directory-p nnbabyl-mbox-file)
+    (nnbabyl-close-server)
+    (nnheader-report 'nnbabyl "Not a regular file: %s" nnbabyl-mbox-file))
+   (t
+    (nnheader-report 'nnbabyl "Opened server %s using mbox %s" server
+		     nnbabyl-mbox-file)
+    t)))
+
+(deffoo nnbabyl-close-server (&optional server)
+  ;; Restore buffer mode.
+  (when (and (nnbabyl-server-opened)
+	     nnbabyl-previous-buffer-mode)
+    (save-excursion
+      (set-buffer nnbabyl-mbox-buffer)
+      (narrow-to-region
+       (caar nnbabyl-previous-buffer-mode)
+       (cdar nnbabyl-previous-buffer-mode))
+      (funcall (cdr nnbabyl-previous-buffer-mode))))
+  (nnoo-close-server 'nnbabyl server)
+  (setq nnbabyl-mbox-buffer nil)
+  t)
+
+(deffoo nnbabyl-server-opened (&optional server)
+  (and (nnoo-current-server-p 'nnbabyl server)
+       nnbabyl-mbox-buffer
+       (buffer-name nnbabyl-mbox-buffer)
+       nntp-server-buffer
+       (buffer-name nntp-server-buffer)))
+
+(deffoo nnbabyl-request-article (article &optional newsgroup server buffer)
+  (nnbabyl-possibly-change-newsgroup newsgroup server)
+  (save-excursion
+    (set-buffer nnbabyl-mbox-buffer)
+    (goto-char (point-min))
+    (when (search-forward (nnbabyl-article-string article) nil t)
+      (let (start stop summary-line)
+	(unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
+	  (goto-char (point-min))
+	  (end-of-line))
+	(while (and (not (looking-at ".+:"))
+		    (zerop (forward-line 1))))
+	(setq start (point))
+	(or (when (re-search-forward
+		   (concat "^" nnbabyl-mail-delimiter) nil t)
+	      (beginning-of-line)
+	      t)
+	    (goto-char (point-max)))
+	(setq stop (point))
+	(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
+	  (set-buffer nntp-server-buffer)
+	  (erase-buffer)
+	  (insert-buffer-substring nnbabyl-mbox-buffer start stop)
+	  (goto-char (point-min))
+	  ;; If there is an EOOH header, then we have to remove some
+	  ;; duplicated headers.
+	  (setq summary-line (looking-at "Summary-line:"))
+	  (when (search-forward "\n*** EOOH ***" nil t)
+	    (if summary-line
+		;; The headers to be deleted are located before the
+		;; EOOH line...
+		(delete-region (point-min) (progn (forward-line 1)
+						  (point)))
+	      ;; ...or after.
+	      (delete-region (progn (beginning-of-line) (point))
+			     (or (search-forward "\n\n" nil t)
+				 (point)))))
+	  (if (numberp article)
+	      (cons nnbabyl-current-group article)
+	    (nnbabyl-article-group-number)))))))
+
+(deffoo nnbabyl-request-group (group &optional server dont-check)
+  (let ((active (cadr (assoc group nnbabyl-group-alist))))
+    (save-excursion
+      (cond
+       ((or (null active)
+	    (null (nnbabyl-possibly-change-newsgroup group server)))
+	(nnheader-report 'nnbabyl "No such group: %s" group))
+       (dont-check
+	(nnheader-report 'nnbabyl "Selected group %s" group)
+	(nnheader-insert ""))
+       (t
+	(nnheader-report 'nnbabyl "Selected group %s" group)
+	(nnheader-insert "211 %d %d %d %s\n"
+			 (1+ (- (cdr active) (car active)))
+			 (car active) (cdr active) group))))))
+
+(deffoo nnbabyl-request-scan (&optional group server)
+  (nnbabyl-possibly-change-newsgroup group server)
+  (nnbabyl-read-mbox)
+  (nnmail-get-new-mail
+   'nnbabyl
+   (lambda ()
+     (save-excursion
+       (set-buffer nnbabyl-mbox-buffer)
+       (save-buffer)))
+   (file-name-directory nnbabyl-mbox-file)
+   group
+   (lambda ()
+     (save-excursion
+       (let ((in-buf (current-buffer)))
+	 (goto-char (point-min))
+	 (while (search-forward "\n\^_\n" nil t)
+	   (delete-char -1))
+	 (set-buffer nnbabyl-mbox-buffer)
+	 (goto-char (point-max))
+	 (search-backward "\n\^_" nil t)
+	 (goto-char (match-end 0))
+	 (insert-buffer-substring in-buf)))
+     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))
+
+(deffoo nnbabyl-close-group (group &optional server)
+  t)
+
+(deffoo nnbabyl-request-create-group (group &optional server args)
+  (nnmail-activate 'nnbabyl)
+  (unless (assoc group nnbabyl-group-alist)
+    (push (list group (cons 1 0))
+				    nnbabyl-group-alist)
+    (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
+  t)
+
+(deffoo nnbabyl-request-list (&optional server)
+  (save-excursion
+    (nnmail-find-file nnbabyl-active-file)
+    (setq nnbabyl-group-alist (nnmail-get-active))
+    t))
+
+(deffoo nnbabyl-request-newgroups (date &optional server)
+  (nnbabyl-request-list server))
+
+(deffoo nnbabyl-request-list-newsgroups (&optional server)
+  (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented."))
+
+(deffoo nnbabyl-request-expire-articles
+  (articles newsgroup &optional server force)
+  (nnbabyl-possibly-change-newsgroup newsgroup server)
+  (let* ((is-old t)
+	 rest)
+    (nnmail-activate 'nnbabyl)
+
+    (save-excursion
+      (set-buffer nnbabyl-mbox-buffer)
+      (gnus-set-text-properties (point-min) (point-max) nil)
+      (while (and articles is-old)
+	(goto-char (point-min))
+	(when (search-forward (nnbabyl-article-string (car articles)) nil t)
+	  (if (setq is-old
+		    (nnmail-expired-article-p
+		     newsgroup
+		     (buffer-substring
+		      (point) (progn (end-of-line) (point))) force))
+	      (progn
+		(nnheader-message 5 "Deleting article %d in %s..."
+				  (car articles) newsgroup)
+		(nnbabyl-delete-mail))
+	    (push (car articles) rest)))
+	(setq articles (cdr articles)))
+      (save-buffer)
+      ;; Find the lowest active article in this group.
+      (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
+	(goto-char (point-min))
+	(while (and (not (search-forward
+			  (nnbabyl-article-string (car active)) nil t))
+		    (<= (car active) (cdr active)))
+	  (setcar active (1+ (car active)))
+	  (goto-char (point-min))))
+      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
+      (nconc rest articles))))
+
+(deffoo nnbabyl-request-move-article
+  (article group server accept-form &optional last)
+  (let ((buf (get-buffer-create " *nnbabyl move*"))
+	result)
+    (and
+     (nnbabyl-request-article article group server)
+     (save-excursion
+       (set-buffer buf)
+       (insert-buffer-substring nntp-server-buffer)
+       (goto-char (point-min))
+       (while (re-search-forward
+	       "^X-Gnus-Newsgroup:"
+	       (save-excursion (search-forward "\n\n" nil t) (point)) t)
+	 (delete-region (progn (beginning-of-line) (point))
+			(progn (forward-line 1) (point))))
+       (setq result (eval accept-form))
+       (kill-buffer (current-buffer))
+       result)
+     (save-excursion
+       (nnbabyl-possibly-change-newsgroup group server)
+       (set-buffer nnbabyl-mbox-buffer)
+       (goto-char (point-min))
+       (if (search-forward (nnbabyl-article-string article) nil t)
+	   (nnbabyl-delete-mail))
+       (and last (save-buffer))))
+    result))
+
+(deffoo nnbabyl-request-accept-article (group &optional server last)
+  (nnbabyl-possibly-change-newsgroup group server)
+  (nnmail-check-syntax)
+  (let ((buf (current-buffer))
+	result beg)
+    (and
+     (nnmail-activate 'nnbabyl)
+     (save-excursion
+       (goto-char (point-min))
+       (search-forward "\n\n" nil t)
+       (forward-line -1)
+       (save-excursion
+	 (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
+	   (delete-region (point) (progn (forward-line 1) (point)))))
+       (when nnmail-cache-accepted-message-ids
+	 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
+       (setq result
+	     (if (stringp group)
+		 (list (cons group (nnbabyl-active-number group)))
+	       (nnmail-article-group 'nnbabyl-active-number)))
+       (if (and (null result)
+		(yes-or-no-p "Moved to `junk' group; delete article? "))
+	   (setq result 'junk)
+	 (setq result (car (nnbabyl-save-mail result))))
+       (set-buffer nnbabyl-mbox-buffer)
+       (goto-char (point-max))
+       (search-backward "\n\^_")
+       (goto-char (match-end 0))
+       (insert-buffer-substring buf)
+       (when last
+	 (when nnmail-cache-accepted-message-ids
+	   (nnmail-cache-insert (nnmail-fetch-field "message-id")))
+	 (save-buffer)
+	 (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
+       result))))
+
+(deffoo nnbabyl-request-replace-article (article group buffer)
+  (nnbabyl-possibly-change-newsgroup group)
+  (save-excursion
+    (set-buffer nnbabyl-mbox-buffer)
+    (goto-char (point-min))
+    (if (not (search-forward (nnbabyl-article-string article) nil t))
+	nil
+      (nnbabyl-delete-mail t t)
+      (insert-buffer-substring buffer)
+      (save-buffer)
+      t)))
+
+(deffoo nnbabyl-request-delete-group (group &optional force server)
+  (nnbabyl-possibly-change-newsgroup group server)
+  ;; Delete all articles in GROUP.
+  (if (not force)
+      ()				; Don't delete the articles.
+    (save-excursion
+      (set-buffer nnbabyl-mbox-buffer)
+      (goto-char (point-min))
+      ;; Delete all articles in this group.
+      (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
+	    found)
+	(while (search-forward ident nil t)
+	  (setq found t)
+	  (nnbabyl-delete-mail))
+	(when found
+	  (save-buffer)))))
+  ;; Remove the group from all structures.
+  (setq nnbabyl-group-alist
+	(delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
+	nnbabyl-current-group nil)
+  ;; Save the active file.
+  (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
+  t)
+
+(deffoo nnbabyl-request-rename-group (group new-name &optional server)
+  (nnbabyl-possibly-change-newsgroup group server)
+  (save-excursion
+    (set-buffer nnbabyl-mbox-buffer)
+    (goto-char (point-min))
+    (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
+	  (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
+	  found)
+      (while (search-forward ident nil t)
+	(replace-match new-ident t t)
+	(setq found t))
+      (when found
+	(save-buffer))))
+  (let ((entry (assoc group nnbabyl-group-alist)))
+    (and entry (setcar entry new-name))
+    (setq nnbabyl-current-group nil)
+    ;; Save the new group alist.
+    (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
+    t))
+
+
+;;; Internal functions.
+
+;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
+;; headers there are.  If LEAVE-DELIM, don't delete the Unix mbox
+;; delimiter line.
+(defun nnbabyl-delete-mail (&optional force leave-delim)
+  ;; Delete the current X-Gnus-Newsgroup line.
+  (unless force
+    (delete-region
+     (progn (beginning-of-line) (point))
+     (progn (forward-line 1) (point))))
+  ;; Beginning of the article.
+  (save-excursion
+    (save-restriction
+      (widen)
+      (narrow-to-region
+       (save-excursion
+	(unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
+	  (goto-char (point-min))
+	  (end-of-line))
+	 (if leave-delim (progn (forward-line 1) (point))
+	   (match-beginning 0)))
+       (progn
+	 (forward-line 1)
+	 (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter)
+				     nil t)
+		  (match-beginning 0))
+	     (point-max))))
+      (goto-char (point-min))
+      ;; Only delete the article if no other groups owns it as well.
+      (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
+	(delete-region (point-min) (point-max))))))
+
+(defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server)
+  (when (and server
+	     (not (nnbabyl-server-opened server)))
+    (nnbabyl-open-server server))
+  (when (or (not nnbabyl-mbox-buffer)
+	    (not (buffer-name nnbabyl-mbox-buffer)))
+    (save-excursion (nnbabyl-read-mbox)))
+  (unless nnbabyl-group-alist
+    (nnmail-activate 'nnbabyl))
+  (if newsgroup
+      (if (assoc newsgroup nnbabyl-group-alist)
+	  (setq nnbabyl-current-group newsgroup)
+	(nnheader-report 'nnbabyl "No such group in file"))
+    t))
+
+(defun nnbabyl-article-string (article)
+  (if (numberp article)
+      (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
+	      (int-to-string article) " ")
+    (concat "\nMessage-ID: " article)))
+
+(defun nnbabyl-article-group-number ()
+  (save-excursion
+    (goto-char (point-min))
+    (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
+			     nil t)
+      (cons (buffer-substring (match-beginning 1) (match-end 1))
+	    (string-to-int
+	     (buffer-substring (match-beginning 2) (match-end 2)))))))
+
+(defun nnbabyl-insert-lines ()
+  "Insert how many lines and chars there are in the body of the mail."
+  (let (lines chars)
+    (save-excursion
+      (goto-char (point-min))
+      (when (search-forward "\n\n" nil t)
+	;; There may be an EOOH line here...
+	(when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
+	  (search-forward "\n\n" nil t))
+	(setq chars (- (point-max) (point))
+	      lines (max (- (count-lines (point) (point-max)) 1) 0))
+	;; Move back to the end of the headers.
+	(goto-char (point-min))
+	(search-forward "\n\n" nil t)
+	(forward-char -1)
+	(save-excursion
+	  (when (re-search-backward "^Lines: " nil t)
+	    (delete-region (point) (progn (forward-line 1) (point)))))
+	(insert (format "Lines: %d\n" lines))
+	chars))))
+
+(defun nnbabyl-save-mail (group-art)
+  ;; Called narrowed to an article.
+  (nnbabyl-insert-lines)
+  (nnmail-insert-xref group-art)
+  (nnbabyl-insert-newsgroup-line group-art)
+  (run-hooks 'nnbabyl-prepare-save-mail-hook)
+  group-art)
+
+(defun nnbabyl-insert-newsgroup-line (group-art)
+  (save-excursion
+    (goto-char (point-min))
+    (while (looking-at "From ")
+      (replace-match "Mail-from: From " t t)
+      (forward-line 1))
+    ;; If there is a C-l at the beginning of the narrowed region, this
+    ;; isn't really a "save", but rather a "scan".
+    (goto-char (point-min))
+    (unless (looking-at "\^L")
+      (save-excursion
+	(insert "\^L\n0, unseen,,\n*** EOOH ***\n")
+	(goto-char (point-max))
+	(insert "\^_\n")))
+    (when (search-forward "\n\n" nil t)
+      (forward-char -1)
+      (while group-art
+	(insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
+			(caar group-art) (cdar group-art)
+			(current-time-string)))
+	(setq group-art (cdr group-art))))
+    t))
+
+(defun nnbabyl-active-number (group)
+  ;; Find the next article number in GROUP.
+  (let ((active (cadr (assoc group nnbabyl-group-alist))))
+    (if active
+	(setcdr active (1+ (cdr active)))
+      ;; This group is new, so we create a new entry for it.
+      ;; This might be a bit naughty... creating groups on the drop of
+      ;; a hat, but I don't know...
+      (push (list group (setq active (cons 1 1)))
+	    nnbabyl-group-alist))
+    (cdr active)))
+
+(defun nnbabyl-create-mbox ()
+  (unless (file-exists-p nnbabyl-mbox-file)
+    ;; Create a new, empty RMAIL mbox file.
+    (save-excursion
+      (set-buffer (setq nnbabyl-mbox-buffer
+			(create-file-buffer nnbabyl-mbox-file)))
+      (setq buffer-file-name nnbabyl-mbox-file)
+      (insert "BABYL OPTIONS:\n\n\^_")
+      (nnmail-write-region
+       (point-min) (point-max) nnbabyl-mbox-file t 'nomesg))))
+
+(defun nnbabyl-read-mbox ()
+  (nnmail-activate 'nnbabyl)
+  (nnbabyl-create-mbox)
+
+  (unless (and nnbabyl-mbox-buffer
+	   (buffer-name nnbabyl-mbox-buffer)
+	   (save-excursion
+	     (set-buffer nnbabyl-mbox-buffer)
+	     (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
+    ;; This buffer has changed since we read it last.  Possibly.
+    (save-excursion
+      (let ((delim (concat "^" nnbabyl-mail-delimiter))
+	    (alist nnbabyl-group-alist)
+	    start end number)
+	(set-buffer (setq nnbabyl-mbox-buffer
+			  (nnheader-find-file-noselect
+			   nnbabyl-mbox-file nil 'raw)))
+	;; Save previous buffer mode.
+	(setq nnbabyl-previous-buffer-mode
+	      (cons (cons (point-min) (point-max))
+		    major-mode))
+
+	(buffer-disable-undo (current-buffer))
+	(widen)
+	(setq buffer-read-only nil)
+	(fundamental-mode)
+
+	;; Go through the group alist and compare against
+	;; the rmail file.
+	(while alist
+	  (goto-char (point-max))
+	  (when (and (re-search-backward
+		      (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
+			      (caar alist))
+		      nil t)
+		     (> (setq number
+			      (string-to-number
+			       (buffer-substring
+				(match-beginning 1) (match-end 1))))
+			(cdadar alist)))
+	    (setcdr (cadar alist) number))
+	  (setq alist (cdr alist)))
+
+	;; We go through the mbox and make sure that each and
+	;; every mail belongs to some group or other.
+	(goto-char (point-min))
+	(if (looking-at "\^L")
+	    (setq start (point))
+	  (re-search-forward delim nil t)
+	  (setq start (match-end 0)))
+	(while (re-search-forward delim nil t)
+	  (setq end (match-end 0))
+	  (unless (search-backward "\nX-Gnus-Newsgroup: " start t)
+	    (goto-char end)
+	    (save-excursion
+	      (save-restriction
+		(narrow-to-region (goto-char start) end)
+		(nnbabyl-save-mail
+		 (nnmail-article-group 'nnbabyl-active-number))
+		(setq end (point-max)))))
+	  (goto-char (setq start end)))
+	(when (buffer-modified-p (current-buffer))
+	  (save-buffer))
+	(nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
+
+(defun nnbabyl-remove-incoming-delims ()
+  (goto-char (point-min))
+  (while (search-forward "\^_" nil t)
+    (replace-match "?" t t)))
+
+(defun nnbabyl-check-mbox ()
+  "Go through the nnbabyl mbox and make sure that no article numbers are reused."
+  (interactive)
+  (let ((idents (make-vector 1000 0))
+	id)
+    (save-excursion
+      (when (or (not nnbabyl-mbox-buffer)
+		(not (buffer-name nnbabyl-mbox-buffer)))
+	(nnbabyl-read-mbox))
+      (set-buffer nnbabyl-mbox-buffer)
+      (goto-char (point-min))
+      (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) "  nil t)
+	(if (intern-soft (setq id (match-string 1)) idents)
+	    (progn
+	      (delete-region (progn (beginning-of-line) (point))
+			     (progn (forward-line 1) (point)))
+	      (nnheader-message 7 "Moving %s..." id)
+	      (nnbabyl-save-mail
+	       (nnmail-article-group 'nnbabyl-active-number)))
+	  (intern id idents)))
+      (when (buffer-modified-p (current-buffer))
+	(save-buffer))
+      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
+      (message ""))))
+
+(provide 'nnbabyl)
+
+;;; nnbabyl.el ends here

lisp/gnus/nndir.el

@@ -0,0 +1,99 @@
+;;; nndir.el --- single directory newsgroup access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nnmh)
+(require 'nnml)
+(require 'nnoo)
+(eval-when-compile (require 'cl))
+
+(nnoo-declare nndir
+  nnml nnmh)
+
+(defvoo nndir-directory nil
+  "Where nndir will look for groups."
+  nnml-current-directory nnmh-current-directory)
+
+(defvoo nndir-nov-is-evil nil
+  "*Non-nil means that nndir will never retrieve NOV headers."
+  nnml-nov-is-evil)
+
+
+
+(defvoo nndir-current-group "" nil nnml-current-group nnmh-current-group)
+(defvoo nndir-top-directory nil nil nnml-directory nnmh-directory)
+(defvoo nndir-get-new-mail nil nil nnml-get-new-mail nnmh-get-new-mail)
+
+(defvoo nndir-status-string "" nil nnmh-status-string)
+(defconst nndir-version "nndir 1.0")
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nndir)
+
+(deffoo nndir-open-server (server &optional defs)
+  (setq nndir-directory
+	(or (cadr (assq 'nndir-directory defs))
+	    server))
+  (unless (assq 'nndir-directory defs)
+    (push `(nndir-directory ,server) defs))
+  (push `(nndir-current-group
+	  ,(file-name-nondirectory (directory-file-name nndir-directory)))
+	defs)
+  (push `(nndir-top-directory
+	  ,(file-name-directory (directory-file-name nndir-directory)))
+	defs)
+  (nnoo-change-server 'nndir server defs)
+  (let (err)
+    (cond
+     ((not (condition-case arg
+	       (file-exists-p nndir-directory)
+	     (ftp-error (setq err (format "%s" arg)))))
+      (nndir-close-server)
+      (nnheader-report
+       'nndir (or err "No such file or directory: %s" nndir-directory)))
+     ((not (file-directory-p (file-truename nndir-directory)))
+      (nndir-close-server)
+      (nnheader-report 'nndir "Not a directory: %s" nndir-directory))
+     (t
+      (nnheader-report 'nndir "Opened server %s using directory %s"
+		       server nndir-directory)
+      t))))
+
+(nnoo-map-functions nndir
+  (nnml-retrieve-headers 0 nndir-current-group 0 0)
+  (nnmh-request-article 0 nndir-current-group 0 0)
+  (nnmh-request-group nndir-current-group 0 0)
+  (nnml-close-group nndir-current-group 0)
+  (nnmh-request-list (nnoo-current-server 'nndir) nndir-directory)
+  (nnmh-request-newsgroups (nnoo-current-server 'nndir) nndir-directory))
+
+(provide 'nndir)
+
+;;; nndir.el ends here

lisp/gnus/nndoc.el

@@ -0,0 +1,628 @@
+;;; nndoc.el --- single file access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'message)
+(require 'nnmail)
+(require 'nnoo)
+(eval-when-compile (require 'cl))
+
+(nnoo-declare nndoc)
+
+(defvoo nndoc-article-type 'guess
+  "*Type of the file.
+One of `mbox', `babyl', `digest', `news', `rnews', `mmdf', `forward',
+`rfc934', `rfc822-forward', `mime-digest', `standard-digest',
+`slack-digest', `clari-briefs' or `guess'.")
+
+(defvoo nndoc-post-type 'mail
+  "*Whether the nndoc group is `mail' or `post'.")
+
+(defvar nndoc-type-alist
+  `((mmdf
+     (article-begin .  "^\^A\^A\^A\^A\n")
+     (body-end .  "^\^A\^A\^A\^A\n"))
+    (news
+     (article-begin . "^Path:"))
+    (rnews
+     (article-begin . "^#! *rnews +\\([0-9]+\\) *\n")
+     (body-end-function . nndoc-rnews-body-end))
+    (mbox
+     (article-begin-function . nndoc-mbox-article-begin)
+     (body-end-function . nndoc-mbox-body-end))
+    (babyl
+     (article-begin . "\^_\^L *\n")
+     (body-end . "\^_")
+     (body-begin-function . nndoc-babyl-body-begin)
+     (head-begin-function . nndoc-babyl-head-begin))
+    (forward
+     (article-begin . "^-+ Start of forwarded message -+\n+")
+     (body-end . "^-+ End of forwarded message -+$")
+     (prepare-body-function . nndoc-unquote-dashes))
+    (rfc934
+     (article-begin . "^--.*\n+")
+     (body-end . "^--.*$")
+     (prepare-body-function . nndoc-unquote-dashes))
+    (clari-briefs
+     (article-begin . "^ \\*")
+     (body-end . "^\t------*[ \t]^*\n^ \\*")
+     (body-begin . "^\t")
+     (head-end . "^\t")
+     (generate-head-function . nndoc-generate-clari-briefs-head)
+     (article-transform-function . nndoc-transform-clari-briefs))
+    (mime-digest
+     (article-begin . "")
+     (head-end . "^ ?$")
+     (body-end . "")
+     (file-end . "")
+     (subtype digest guess))
+    (standard-digest
+     (first-article . ,(concat "^" (make-string 70 ?-) "\n\n+"))
+     (article-begin . ,(concat "^\n" (make-string 30 ?-) "\n\n+"))
+     (prepare-body-function . nndoc-unquote-dashes)
+     (body-end-function . nndoc-digest-body-end)
+     (head-end . "^ ?$")
+     (body-begin . "^ ?\n")
+     (file-end . "^End of .*digest.*[0-9].*\n\\*\\*\\|^End of.*Digest *$")
+     (subtype digest guess))
+    (slack-digest
+     (article-begin . "^------------------------------*[\n \t]+")
+     (head-end . "^ ?$")
+     (body-end-function . nndoc-digest-body-end)
+     (body-begin . "^ ?$")
+     (file-end . "^End of")
+     (prepare-body-function . nndoc-unquote-dashes)
+     (subtype digest guess))
+    (lanl-gov-announce
+     (article-begin . "^\\\\\\\\\n")
+     (head-begin . "^Paper.*:")
+     (head-end   . "\\(^\\\\\\\\.*\n\\|-----------------\\)")
+     (body-begin . "")
+     (body-end   . "-------------------------------------------------")
+     (file-end   . "^Title: Recent Seminal")
+     (generate-head-function . nndoc-generate-lanl-gov-head)
+     (article-transform-function . nndoc-transform-lanl-gov-announce)
+     (subtype preprints guess))
+    (rfc822-forward
+     (article-begin . "^\n")
+     (body-end-function . nndoc-rfc822-forward-body-end-function))
+    (guess
+     (guess . t)
+     (subtype nil))
+    (digest
+     (guess . t)
+     (subtype nil))
+    (preprints
+     (guess . t)
+     (subtype nil))))
+
+
+
+(defvoo nndoc-file-begin nil)
+(defvoo nndoc-first-article nil)
+(defvoo nndoc-article-end nil)
+(defvoo nndoc-article-begin nil)
+(defvoo nndoc-head-begin nil)
+(defvoo nndoc-head-end nil)
+(defvoo nndoc-file-end nil)
+(defvoo nndoc-body-begin nil)
+(defvoo nndoc-body-end-function nil)
+(defvoo nndoc-body-begin-function nil)
+(defvoo nndoc-head-begin-function nil)
+(defvoo nndoc-body-end nil)
+(defvoo nndoc-dissection-alist nil)
+(defvoo nndoc-prepare-body-function nil)
+(defvoo nndoc-generate-head-function nil)
+(defvoo nndoc-article-transform-function nil)
+(defvoo nndoc-article-begin-function nil)
+
+(defvoo nndoc-status-string "")
+(defvoo nndoc-group-alist nil)
+(defvoo nndoc-current-buffer nil
+  "Current nndoc news buffer.")
+(defvoo nndoc-address nil)
+
+(defconst nndoc-version "nndoc 1.0"
+  "nndoc version.")
+
+
+
+;;; Interface functions
+
+(nnoo-define-basics nndoc)
+
+(deffoo nndoc-retrieve-headers (articles &optional newsgroup server fetch-old)
+  (when (nndoc-possibly-change-buffer newsgroup server)
+    (save-excursion
+      (set-buffer nntp-server-buffer)
+      (erase-buffer)
+      (let (article entry)
+	(if (stringp (car articles))
+	    'headers
+	  (while articles
+	    (when (setq entry (cdr (assq (setq article (pop articles))
+					 nndoc-dissection-alist)))
+	      (insert (format "221 %d Article retrieved.\n" article))
+	      (if nndoc-generate-head-function
+		  (funcall nndoc-generate-head-function article)
+		(insert-buffer-substring
+		 nndoc-current-buffer (car entry) (nth 1 entry)))
+	      (goto-char (point-max))
+	      (unless (= (char-after (1- (point))) ?\n)
+		(insert "\n"))
+	      (insert (format "Lines: %d\n" (nth 4 entry)))
+	      (insert ".\n")))
+
+	  (nnheader-fold-continuation-lines)
+	  'headers)))))
+
+(deffoo nndoc-request-article (article &optional newsgroup server buffer)
+  (nndoc-possibly-change-buffer newsgroup server)
+  (save-excursion
+    (let ((buffer (or buffer nntp-server-buffer))
+	  (entry (cdr (assq article nndoc-dissection-alist)))
+	  beg)
+      (set-buffer buffer)
+      (erase-buffer)
+      (when entry
+	(if (stringp article)
+	    nil
+	  (insert-buffer-substring
+	   nndoc-current-buffer (car entry) (nth 1 entry))
+	  (insert "\n")
+	  (setq beg (point))
+	  (insert-buffer-substring
+	   nndoc-current-buffer (nth 2 entry) (nth 3 entry))
+	  (goto-char beg)
+	  (when nndoc-prepare-body-function
+	    (funcall nndoc-prepare-body-function))
+	  (when nndoc-article-transform-function
+	    (funcall nndoc-article-transform-function article))
+	  t)))))
+
+(deffoo nndoc-request-group (group &optional server dont-check)
+  "Select news GROUP."
+  (let (number)
+    (cond
+     ((not (nndoc-possibly-change-buffer group server))
+      (nnheader-report 'nndoc "No such file or buffer: %s"
+		       nndoc-address))
+     (dont-check
+      (nnheader-report 'nndoc "Selected group %s" group)
+      t)
+     ((zerop (setq number (length nndoc-dissection-alist)))
+      (nndoc-close-group group)
+      (nnheader-report 'nndoc "No articles in group %s" group))
+     (t
+      (nnheader-insert "211 %d %d %d %s\n" number 1 number group)))))
+
+(deffoo nndoc-request-type (group &optional article)
+  (cond ((not article) 'unknown)
+        (nndoc-post-type nndoc-post-type)
+        (t 'unknown)))
+
+(deffoo nndoc-close-group (group &optional server)
+  (nndoc-possibly-change-buffer group server)
+  (and nndoc-current-buffer
+       (buffer-name nndoc-current-buffer)
+       (kill-buffer nndoc-current-buffer))
+  (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
+				nndoc-group-alist))
+  (setq nndoc-current-buffer nil)
+  (nnoo-close-server 'nndoc server)
+  (setq nndoc-dissection-alist nil)
+  t)
+
+(deffoo nndoc-request-list (&optional server)
+  nil)
+
+(deffoo nndoc-request-newgroups (date &optional server)
+  nil)
+
+(deffoo nndoc-request-list-newsgroups (&optional server)
+  nil)
+
+
+;;; Internal functions.
+
+(defun nndoc-possibly-change-buffer (group source)
+  (let (buf)
+    (cond
+     ;; The current buffer is this group's buffer.
+     ((and nndoc-current-buffer
+	   (buffer-name nndoc-current-buffer)
+	   (eq nndoc-current-buffer
+	       (setq buf (cdr (assoc group nndoc-group-alist))))))
+     ;; We change buffers by taking an old from the group alist.
+     ;; `source' is either a string (a file name) or a buffer object.
+     (buf
+      (setq nndoc-current-buffer buf))
+     ;; It's a totally new group.
+     ((or (and (bufferp nndoc-address)
+	       (buffer-name nndoc-address))
+	  (and (stringp nndoc-address)
+	       (file-exists-p nndoc-address)
+	       (not (file-directory-p nndoc-address))))
+      (push (cons group (setq nndoc-current-buffer
+			      (get-buffer-create
+			       (concat " *nndoc " group "*"))))
+	    nndoc-group-alist)
+      (setq nndoc-dissection-alist nil)
+      (save-excursion
+	(set-buffer nndoc-current-buffer)
+	(buffer-disable-undo (current-buffer))
+	(erase-buffer)
+	(if (stringp nndoc-address)
+	    (nnheader-insert-file-contents nndoc-address)
+	  (insert-buffer-substring nndoc-address)))))
+    ;; Initialize the nndoc structures according to this new document.
+    (when (and nndoc-current-buffer
+	       (not nndoc-dissection-alist))
+      (save-excursion
+	(set-buffer nndoc-current-buffer)
+	(nndoc-set-delims)
+	(nndoc-dissect-buffer)))
+    (unless nndoc-current-buffer
+      (nndoc-close-server))
+    ;; Return whether we managed to select a file.
+    nndoc-current-buffer))
+
+;;;
+;;; Deciding what document type we have
+;;;
+
+(defun nndoc-set-delims ()
+  "Set the nndoc delimiter variables according to the type of the document."
+  (let ((vars '(nndoc-file-begin
+		nndoc-first-article
+		nndoc-article-end nndoc-head-begin nndoc-head-end
+		nndoc-file-end nndoc-article-begin
+		nndoc-body-begin nndoc-body-end-function nndoc-body-end
+		nndoc-prepare-body-function nndoc-article-transform-function
+		nndoc-generate-head-function nndoc-body-begin-function
+		nndoc-head-begin-function)))
+    (while vars
+      (set (pop vars) nil)))
+  (let (defs)
+    ;; Guess away until we find the real file type.
+    (while (assq 'guess (setq defs (cdr (assq nndoc-article-type
+					      nndoc-type-alist))))
+      (setq nndoc-article-type (nndoc-guess-type nndoc-article-type)))
+    ;; Set the nndoc variables.
+    (while defs
+      (set (intern (format "nndoc-%s" (caar defs)))
+	   (cdr (pop defs))))))
+
+(defun nndoc-guess-type (subtype)
+  (let ((alist nndoc-type-alist)
+	results result entry)
+    (while (and (not result)
+		(setq entry (pop alist)))
+      (when (memq subtype (or (cdr (assq 'subtype entry)) '(guess)))
+	(goto-char (point-min))
+	(when (numberp (setq result (funcall (intern
+					      (format "nndoc-%s-type-p"
+						      (car entry))))))
+	  (push (cons result entry) results)
+	  (setq result nil))))
+    (unless (or result results)
+      (error "Document is not of any recognized type"))
+    (if result
+	(car entry)
+      (cadar (sort results (lambda (r1 r2) (< (car r1) (car r2))))))))
+
+;;;
+;;; Built-in type predicates and functions
+;;;
+
+(defun nndoc-mbox-type-p ()
+  (when (looking-at message-unix-mail-delimiter)
+    t))
+
+(defun nndoc-mbox-article-begin ()
+  (when (re-search-forward (concat "^" message-unix-mail-delimiter) nil t)
+    (goto-char (match-beginning 0))))
+
+(defun nndoc-mbox-body-end ()
+  (let ((beg (point))
+	len end)
+    (when
+	(save-excursion
+	  (and (re-search-backward
+		(concat "^" message-unix-mail-delimiter) nil t)
+	       (setq end (point))
+	       (search-forward "\n\n" beg t)
+	       (re-search-backward
+		"^Content-Length:[ \t]*\\([0-9]+\\) *$" end t)
+	       (setq len (string-to-int (match-string 1)))
+	       (search-forward "\n\n" beg t)
+	       (unless (= (setq len (+ (point) len)) (point-max))
+		 (and (< len (point-max))
+		      (goto-char len)
+		      (looking-at message-unix-mail-delimiter)))))
+      (goto-char len))))
+
+(defun nndoc-mmdf-type-p ()
+  (when (looking-at "\^A\^A\^A\^A$")
+    t))
+
+(defun nndoc-news-type-p ()
+  (when (looking-at "^Path:.*\n")
+    t))
+
+(defun nndoc-rnews-type-p ()
+  (when (looking-at "#! *rnews")
+    t))
+
+(defun nndoc-rnews-body-end ()
+  (and (re-search-backward nndoc-article-begin nil t)
+       (forward-line 1)
+       (goto-char (+ (point) (string-to-int (match-string 1))))))
+
+(defun nndoc-babyl-type-p ()
+  (when (re-search-forward "\^_\^L *\n" nil t)
+    t))
+
+(defun nndoc-babyl-body-begin ()
+  (re-search-forward "^\n" nil t)
+  (when (looking-at "\*\*\* EOOH \*\*\*")
+    (let ((next (or (save-excursion
+		      (re-search-forward nndoc-article-begin nil t))
+		    (point-max))))
+      (unless (re-search-forward "^\n" next t)
+	(goto-char next)
+	(forward-line -1)
+	(insert "\n")
+	(forward-line -1)))))
+
+(defun nndoc-babyl-head-begin ()
+  (when (re-search-forward "^[0-9].*\n" nil t)
+    (when (looking-at "\*\*\* EOOH \*\*\*")
+      (forward-line 1))
+    t))
+
+(defun nndoc-forward-type-p ()
+  (when (and (re-search-forward "^-+ Start of forwarded message -+\n+" nil t)
+	     (not (re-search-forward "^Subject:.*digest" nil t))
+	     (not (re-search-backward "^From:" nil t 2))
+	     (not (re-search-forward "^From:" nil t 2)))
+    t))
+
+(defun nndoc-rfc934-type-p ()
+  (when (and (re-search-forward "^-+ Start of forwarded.*\n+" nil t)
+	     (not (re-search-forward "^Subject:.*digest" nil t))
+	     (not (re-search-backward "^From:" nil t 2))
+	     (not (re-search-forward "^From:" nil t 2)))
+    t))
+
+(defun nndoc-rfc822-forward-type-p ()
+  (save-restriction
+    (message-narrow-to-head)
+    (when (re-search-forward "^Content-Type: *message/rfc822" nil t)
+      t)))
+
+(defun nndoc-rfc822-forward-body-end-function ()
+  (goto-char (point-max)))
+
+(defun nndoc-clari-briefs-type-p ()
+  (when (let ((case-fold-search nil))
+	  (re-search-forward "^\t[^a-z]+ ([^a-z]+) --" nil t))
+    t))
+
+(defun nndoc-transform-clari-briefs (article)
+  (goto-char (point-min))
+  (when (looking-at " *\\*\\(.*\\)\n")
+    (replace-match "" t t))
+  (nndoc-generate-clari-briefs-head article))
+
+(defun nndoc-generate-clari-briefs-head (article)
+  (let ((entry (cdr (assq article nndoc-dissection-alist)))
+	subject from)
+    (save-excursion
+      (set-buffer nndoc-current-buffer)
+      (save-restriction
+	(narrow-to-region (car entry) (nth 3 entry))
+	(goto-char (point-min))
+	(when (looking-at " *\\*\\(.*\\)$")
+	  (setq subject (match-string 1))
+	  (when (string-match "[ \t]+$" subject)
+	    (setq subject (substring subject 0 (match-beginning 0)))))
+	(when
+	    (let ((case-fold-search nil))
+	      (re-search-forward
+	       "^\t\\([^a-z]+\\(,[^(]+\\)? ([^a-z]+)\\) --" nil t))
+	  (setq from (match-string 1)))))
+    (insert "From: " "clari@clari.net (" (or from "unknown") ")"
+	    "\nSubject: " (or subject "(no subject)") "\n")))
+
+(defun nndoc-mime-digest-type-p ()
+  (let ((case-fold-search t)
+	boundary-id b-delimiter entry)
+    (when (and
+	   (re-search-forward
+	    (concat "^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
+		    "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
+	    nil t)
+	   (match-beginning 1))
+      (setq boundary-id (match-string 1)
+	    b-delimiter (concat "\n--" boundary-id "[\n \t]+"))
+      (setq entry (assq 'mime-digest nndoc-type-alist))
+      (setcdr entry
+	      (list
+	       (cons 'head-end "^ ?$")
+	       (cons 'body-begin "^ ?\n")
+	       (cons 'article-begin b-delimiter)
+	       (cons 'body-end-function 'nndoc-digest-body-end)
+	       (cons 'file-end (concat "\n--" boundary-id "--[ \t]*$"))))
+      t)))
+
+(defun nndoc-standard-digest-type-p ()
+  (when (and (re-search-forward (concat "^" (make-string 70 ?-) "\n\n") nil t)
+	     (re-search-forward
+	      (concat "\n\n" (make-string 30 ?-) "\n\n") nil t))
+    t))
+
+(defun nndoc-digest-body-end ()
+  (and (re-search-forward nndoc-article-begin nil t)
+       (goto-char (match-beginning 0))))
+
+(defun nndoc-slack-digest-type-p ()
+  0)
+
+(defun nndoc-lanl-gov-announce-type-p ()
+  (when (let ((case-fold-search nil))
+	  (re-search-forward "^\\\\\\\\\nPaper: [a-z-]+/[0-9]+" nil t))
+    t))
+
+(defun nndoc-transform-lanl-gov-announce (article)
+  (goto-char (point-max))
+  (when (re-search-backward "^\\\\\\\\ +(\\([^ ]*\\) , *\\([^ ]*\\))" nil t)
+    (replace-match "\n\nGet it at \\1 (\\2)" t nil))
+  ;;  (when (re-search-backward "^\\\\\\\\$" nil t)
+  ;;    (replace-match "" t t))
+  )
+
+(defun nndoc-generate-lanl-gov-head (article)
+  (let ((entry (cdr (assq article nndoc-dissection-alist)))
+ 	(e-mail "no address given")
+ 	subject from)
+    (save-excursion
+      (set-buffer nndoc-current-buffer)
+      (save-restriction
+ 	(narrow-to-region (car entry) (nth 1 entry))
+ 	(goto-char (point-min))
+ 	(when (looking-at "^Paper.*: \\([a-z-]+/[0-9]+\\)")
+ 	  (setq subject (concat " (" (match-string 1) ")"))
+ 	  (when (re-search-forward "^From: \\([^ ]+\\)" nil t)
+ 	    (setq e-mail (match-string 1)))
+ 	  (when (re-search-forward "^Title: \\([^\f]*\\)\nAuthors?: \\(.*\\)"
+ 				   nil t)
+ 	    (setq subject (concat (match-string 1) subject))
+ 	    (setq from (concat (match-string 2) " <" e-mail ">"))))
+ 	))
+    (while (and from (string-match "(\[^)\]*)" from))
+      (setq from (replace-match "" t t from)))
+    (insert "From: "  (or from "unknown")
+ 	    "\nSubject: " (or subject "(no subject)") "\n")))
+
+
+
+;;;
+;;; Functions for dissecting the documents
+;;;
+
+(defun nndoc-search (regexp)
+  (prog1
+      (re-search-forward regexp nil t)
+    (beginning-of-line)))
+
+(defun nndoc-dissect-buffer ()
+  "Go through the document and partition it into heads/bodies/articles."
+  (let ((i 0)
+	(first t)
+	head-begin head-end body-begin body-end)
+    (setq nndoc-dissection-alist nil)
+    (save-excursion
+      (set-buffer nndoc-current-buffer)
+      (goto-char (point-min))
+      ;; Find the beginning of the file.
+      (when nndoc-file-begin
+	(nndoc-search nndoc-file-begin))
+      ;; Go through the file.
+      (while (if (and first nndoc-first-article)
+		 (nndoc-search nndoc-first-article)
+	       (nndoc-article-begin))
+	(setq first nil)
+	(cond (nndoc-head-begin-function
+	       (funcall nndoc-head-begin-function))
+	      (nndoc-head-begin
+	       (nndoc-search nndoc-head-begin)))
+ 	(if (or (>= (point) (point-max))
+		(and nndoc-file-end
+		     (looking-at nndoc-file-end)))
+	    (goto-char (point-max))
+	  (setq head-begin (point))
+	  (nndoc-search (or nndoc-head-end "^$"))
+	  (setq head-end (point))
+	  (if nndoc-body-begin-function
+	      (funcall nndoc-body-begin-function)
+	    (nndoc-search (or nndoc-body-begin "^\n")))
+	  (setq body-begin (point))
+	  (or (and nndoc-body-end-function
+		   (funcall nndoc-body-end-function))
+	      (and nndoc-body-end
+		   (nndoc-search nndoc-body-end))
+	      (nndoc-article-begin)
+	      (progn
+		(goto-char (point-max))
+		(when nndoc-file-end
+		  (and (re-search-backward nndoc-file-end nil t)
+		       (beginning-of-line)))))
+	  (setq body-end (point))
+	  (push (list (incf i) head-begin head-end body-begin body-end
+		      (count-lines body-begin body-end))
+		nndoc-dissection-alist))))))
+
+(defun nndoc-article-begin ()
+  (if nndoc-article-begin-function
+      (funcall nndoc-article-begin-function)
+    (ignore-errors
+      (nndoc-search nndoc-article-begin))))
+
+(defun nndoc-unquote-dashes ()
+  "Unquote quoted non-separators in digests."
+  (while (re-search-forward "^- -"nil t)
+    (replace-match "-" t t)))
+
+;;;###autoload
+(defun nndoc-add-type (definition &optional position)
+  "Add document DEFINITION to the list of nndoc document definitions.
+If POSITION is nil or `last', the definition will be added
+as the last checked definition, if t or `first', add as the
+first definition, and if any other symbol, add after that
+symbol in the alist."
+  ;; First remove any old instances.
+  (setq nndoc-type-alist
+	(delq (assq (car definition) nndoc-type-alist)
+	      nndoc-type-alist))
+  ;; Then enter the new definition in the proper place.
+  (cond
+   ((or (null position) (eq position 'last))
+    (setq nndoc-type-alist (nconc nndoc-type-alist (list definition))))
+   ((or (eq position t) (eq position 'first))
+    (push definition nndoc-type-alist))
+   (t
+    (let ((list (memq (assq position nndoc-type-alist)
+		      nndoc-type-alist)))
+      (unless list
+	(error "No such position: %s" position))
+      (setcdr list (cons definition (cdr list)))))))
+
+(provide 'nndoc)
+
+;;; nndoc.el ends here

lisp/gnus/nndraft.el

@@ -0,0 +1,248 @@
+;;; nndraft.el --- draft article access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nnmh)
+(require 'nnoo)
+(eval-and-compile (require 'cl))
+
+(nnoo-declare nndraft)
+
+(eval-and-compile
+  (autoload 'mail-send-and-exit "sendmail"))
+
+(defvoo nndraft-directory nil
+  "Where nndraft will store its directory.")
+
+
+
+(defconst nndraft-version "nndraft 1.0")
+(defvoo nndraft-status-string "")
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nndraft)
+
+(deffoo nndraft-retrieve-headers (articles &optional group server fetch-old)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (let* ((buf (get-buffer-create " *draft headers*"))
+	   article)
+      (set-buffer buf)
+      (buffer-disable-undo (current-buffer))
+      (erase-buffer)
+      ;; We don't support fetching by Message-ID.
+      (if (stringp (car articles))
+	  'headers
+	(while articles
+	  (set-buffer buf)
+	  (when (nndraft-request-article
+		 (setq article (pop articles)) group server (current-buffer))
+	    (goto-char (point-min))
+	    (if (search-forward "\n\n" nil t)
+		(forward-line -1)
+	      (goto-char (point-max)))
+	    (delete-region (point) (point-max))
+	    (set-buffer nntp-server-buffer)
+	    (goto-char (point-max))
+	    (insert (format "221 %d Article retrieved.\n" article))
+	    (insert-buffer-substring buf)
+	    (insert ".\n")))
+
+	(nnheader-fold-continuation-lines)
+	'headers))))
+
+(deffoo nndraft-open-server (server &optional defs)
+  (nnoo-change-server 'nndraft server defs)
+  (unless (assq 'nndraft-directory defs)
+    (setq nndraft-directory server))
+  (cond
+   ((not (file-exists-p nndraft-directory))
+    (nndraft-close-server)
+    (nnheader-report 'nndraft "No such file or directory: %s"
+		     nndraft-directory))
+   ((not (file-directory-p (file-truename nndraft-directory)))
+    (nndraft-close-server)
+    (nnheader-report 'nndraft "Not a directory: %s" nndraft-directory))
+   (t
+    (nnheader-report 'nndraft "Opened server %s using directory %s"
+		     server nndraft-directory)
+    t)))
+
+(deffoo nndraft-request-article (id &optional group server buffer)
+  (when (numberp id)
+    ;; We get the newest file of the auto-saved file and the
+    ;; "real" file.
+    (let* ((file (nndraft-article-filename id))
+	   (auto (nndraft-auto-save-file-name file))
+	   (newest (if (file-newer-than-file-p file auto) file auto))
+	   (nntp-server-buffer (or buffer nntp-server-buffer)))
+      (when (and (file-exists-p newest)
+		 (nnmail-find-file newest))
+	(save-excursion
+	  (set-buffer nntp-server-buffer)
+	  (goto-char (point-min))
+	  ;; If there's a mail header separator in this file,
+	  ;; we remove it.
+	  (when (re-search-forward
+		 (concat "^" mail-header-separator "$") nil t)
+	    (replace-match "" t t)))
+	t))))
+
+(deffoo nndraft-request-restore-buffer (article &optional group server)
+  "Request a new buffer that is restored to the state of ARTICLE."
+  (let ((file (nndraft-article-filename article ".state"))
+	nndraft-point nndraft-mode nndraft-buffer-name)
+    (when (file-exists-p file)
+      (load file t t t)
+      (when nndraft-buffer-name
+	(set-buffer (get-buffer-create
+		     (generate-new-buffer-name nndraft-buffer-name)))
+	(nndraft-request-article article group server (current-buffer))
+	(funcall nndraft-mode)
+	(let ((gnus-verbose-backends nil))
+	  (nndraft-request-expire-articles (list article) group server t))
+	(goto-char nndraft-point))
+      nndraft-buffer-name)))
+
+(deffoo nndraft-request-update-info (group info &optional server)
+  (setcar (cddr info) nil)
+  (when (nth 3 info)
+    (setcar (nthcdr 3 info) nil))
+  t)
+
+(deffoo nndraft-request-associate-buffer (group)
+  "Associate the current buffer with some article in the draft group."
+  (let* ((gnus-verbose-backends nil)
+	 (article (cdr (nndraft-request-accept-article
+			group (nnoo-current-server 'nndraft) t 'noinsert)))
+	 (file (nndraft-article-filename article)))
+    (setq buffer-file-name file)
+    (setq buffer-auto-save-file-name (make-auto-save-file-name))
+    (clear-visited-file-modtime)
+    article))
+
+(deffoo nndraft-request-group (group &optional server dont-check)
+  (prog1
+      (nndraft-execute-nnmh-command
+       `(nnmh-request-group group "" ,dont-check))
+    (nnheader-report 'nndraft nnmh-status-string)))
+
+(deffoo nndraft-request-list (&optional server dir)
+  (nndraft-execute-nnmh-command
+   `(nnmh-request-list nil ,dir)))
+
+(deffoo nndraft-request-newgroups (date &optional server)
+  (nndraft-execute-nnmh-command
+   `(nnmh-request-newgroups ,date ,server)))
+
+(deffoo nndraft-request-expire-articles
+  (articles group &optional server force)
+  (let ((res (nndraft-execute-nnmh-command
+	      `(nnmh-request-expire-articles
+		',articles group ,server ,force)))
+	article)
+    ;; Delete all the "state" files of articles that have been expired.
+    (while articles
+      (unless (memq (setq article (pop articles)) res)
+	(let ((file (nndraft-article-filename article ".state"))
+	      (auto (nndraft-auto-save-file-name
+		     (nndraft-article-filename article))))
+	  (when (file-exists-p file)
+	    (funcall nnmail-delete-file-function file))
+	  (when (file-exists-p auto)
+	    (funcall nnmail-delete-file-function auto)))))
+    res))
+
+(deffoo nndraft-request-accept-article (group &optional server last noinsert)
+  (let* ((point (point))
+	 (mode major-mode)
+	 (name (buffer-name))
+	 (gnus-verbose-backends nil)
+	 (gart (nndraft-execute-nnmh-command
+		`(nnmh-request-accept-article group ,server ,last noinsert)))
+	 (state
+	  (nndraft-article-filename (cdr gart) ".state")))
+    ;; Write the "state" file.
+    (save-excursion
+      (nnheader-set-temp-buffer " *draft state*")
+      (insert (format "%S\n" `(setq nndraft-mode (quote ,mode)
+				    nndraft-point ,point
+				    nndraft-buffer-name ,name)))
+      (write-region (point-min) (point-max) state nil 'silent)
+      (kill-buffer (current-buffer)))
+    gart))
+
+(deffoo nndraft-close-group (group &optional server)
+  t)
+
+(deffoo nndraft-request-create-group (group &optional server args)
+  (if (file-exists-p nndraft-directory)
+      (if (file-directory-p nndraft-directory)
+	  t
+	nil)
+    (condition-case ()
+	(progn
+	  (gnus-make-directory nndraft-directory)
+	  t)
+      (file-error nil))))
+
+
+;;; Low-Level Interface
+
+(defun nndraft-execute-nnmh-command (command)
+  (let ((dir (expand-file-name nndraft-directory)))
+    (when (string-match "/$" dir)
+      (setq dir (substring dir 0 (match-beginning 0))))
+    (string-match "/[^/]+$" dir)
+    (let ((group (substring dir (1+ (match-beginning 0))))
+          (nnmh-directory (substring dir 0 (1+ (match-beginning 0))))
+	  (nnmail-keep-last-article nil)
+	  (nnmh-get-new-mail nil))
+      (eval command))))
+
+(defun nndraft-article-filename (article &rest args)
+  (apply 'concat
+	 (file-name-as-directory nndraft-directory)
+	 (int-to-string article)
+	 args))
+
+(defun nndraft-auto-save-file-name (file)
+  (save-excursion
+    (prog1
+	(progn
+	  (set-buffer (get-buffer-create " *draft tmp*"))
+	  (setq buffer-file-name file)
+	  (make-auto-save-file-name))
+      (kill-buffer (current-buffer)))))
+
+(provide 'nndraft)
+
+;;; nndraft.el ends here

lisp/gnus/nneething.el

@@ -0,0 +1,350 @@
+;;; nneething.el --- random file access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nnmail)
+(require 'nnoo)
+(require 'gnus-util)
+(require 'cl)
+
+(nnoo-declare nneething)
+
+(defvoo nneething-map-file-directory "~/.nneething/"
+  "Where nneething stores the map files.")
+
+(defvoo nneething-map-file ".nneething"
+  "Name of the map files.")
+
+(defvoo nneething-exclude-files nil
+  "Regexp saying what files to exclude from the group.
+If this variable is nil, no files will be excluded.")
+
+
+
+;;; Internal variables.
+
+(defconst nneething-version "nneething 1.0"
+  "nneething version.")
+
+(defvoo nneething-current-directory nil
+  "Current news group directory.")
+
+(defvoo nneething-status-string "")
+
+(defvoo nneething-message-id-number 0)
+(defvoo nneething-work-buffer " *nneething work*")
+
+(defvoo nneething-group nil)
+(defvoo nneething-map nil)
+(defvoo nneething-read-only nil)
+(defvoo nneething-active nil)
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nneething)
+
+(deffoo nneething-retrieve-headers (articles &optional group server fetch-old)
+  (nneething-possibly-change-directory group)
+
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (let* ((number (length articles))
+	   (count 0)
+	   (large (and (numberp nnmail-large-newsgroup)
+		       (> number nnmail-large-newsgroup)))
+	   article file)
+
+      (if (stringp (car articles))
+	  'headers
+
+	(while (setq article (pop articles))
+	  (setq file (nneething-file-name article))
+
+	  (when (and (file-exists-p file)
+		     (or (file-directory-p file)
+			 (not (zerop (nnheader-file-size file)))))
+	    (insert (format "221 %d Article retrieved.\n" article))
+	    (nneething-insert-head file)
+	    (insert ".\n"))
+
+	  (incf count)
+
+	  (and large
+	       (zerop (% count 20))
+	       (message "nneething: Receiving headers... %d%%"
+			(/ (* count 100) number))))
+
+	(when large
+	  (message "nneething: Receiving headers...done"))
+
+	(nnheader-fold-continuation-lines)
+	'headers))))
+
+(deffoo nneething-request-article (id &optional group server buffer)
+  (nneething-possibly-change-directory group)
+  (let ((file (unless (stringp id)
+		(nneething-file-name id)))
+	(nntp-server-buffer (or buffer nntp-server-buffer)))
+    (and (stringp file)			; We did not request by Message-ID.
+	 (file-exists-p file)		; The file exists.
+	 (not (file-directory-p file))	; It's not a dir.
+	 (save-excursion
+	   (nnmail-find-file file)	; Insert the file in the nntp buf.
+	   (unless (nnheader-article-p)	; Either it's a real article...
+	     (goto-char (point-min))
+	     (nneething-make-head file (current-buffer)) ; ... or we fake some headers.
+	     (insert "\n"))
+	   t))))
+
+(deffoo nneething-request-group (group &optional server dont-check)
+  (nneething-possibly-change-directory group server)
+  (unless dont-check
+    (nneething-create-mapping)
+    (if (> (car nneething-active) (cdr nneething-active))
+	(nnheader-insert "211 0 1 0 %s\n" group)
+      (nnheader-insert
+       "211 %d %d %d %s\n"
+       (- (1+ (cdr nneething-active)) (car nneething-active))
+       (car nneething-active) (cdr nneething-active)
+       group)))
+  t)
+
+(deffoo nneething-request-list (&optional server dir)
+  (nnheader-report 'nneething "LIST is not implemented."))
+
+(deffoo nneething-request-newgroups (date &optional server)
+  (nnheader-report 'nneething "NEWSGROUPS is not implemented."))
+
+(deffoo nneething-request-type (group &optional article)
+  'unknown)
+
+(deffoo nneething-close-group (group &optional server)
+  (setq nneething-current-directory nil)
+  t)
+
+(deffoo nneething-open-server (server &optional defs)
+  (nnheader-init-server-buffer)
+  (if (nneething-server-opened server)
+      t
+    (unless (assq 'nneething-directory defs)
+      (setq defs (append defs (list (list 'nneething-directory server)))))
+    (nnoo-change-server 'nneething server defs)))
+
+
+;;; Internal functions.
+
+(defun nneething-possibly-change-directory (group &optional server)
+  (when (and server
+	     (not (nneething-server-opened server)))
+    (nneething-open-server server))
+  (when (and group
+	     (not (equal nneething-group group)))
+    (setq nneething-group group)
+    (setq nneething-map nil)
+    (setq nneething-active (cons 1 0))
+    (nneething-create-mapping)))
+
+(defun nneething-map-file ()
+  ;; We make sure that the .nneething directory exists.
+  (gnus-make-directory nneething-map-file-directory)
+  ;; We store it in a special directory under the user's home dir.
+  (concat (file-name-as-directory nneething-map-file-directory)
+	  nneething-group nneething-map-file))
+
+(defun nneething-create-mapping ()
+  ;; Read nneething-active and nneething-map.
+  (when (file-exists-p nneething-directory)
+    (let ((map-file (nneething-map-file))
+	  (files (directory-files nneething-directory))
+	  touched map-files)
+      (when (file-exists-p map-file)
+	(ignore-errors
+	  (load map-file nil t t)))
+      (unless nneething-active
+	(setq nneething-active (cons 1 0)))
+      ;; Old nneething had a different map format.
+      (when (and (cdar nneething-map)
+		 (atom (cdar nneething-map)))
+	(setq nneething-map
+	      (mapcar (lambda (n)
+			(list (cdr n) (car n)
+			      (nth 5 (file-attributes
+				      (nneething-file-name (car n))))))
+		      nneething-map)))
+      ;; Remove files matching the exclusion regexp.
+      (when nneething-exclude-files
+	(let ((f files)
+	      prev)
+	  (while f
+	    (if (string-match nneething-exclude-files (car f))
+		(if prev (setcdr prev (cdr f))
+		  (setq files (cdr files)))
+	      (setq prev f))
+	    (setq f (cdr f)))))
+      ;; Remove deleted files from the map.
+      (let ((map nneething-map)
+	    prev)
+	(while map
+	  (if (and (member (cadar map) files)
+		   ;; We also remove files that have changed mod times.
+		   (equal (nth 5 (file-attributes
+				  (nneething-file-name (cadar map))))
+			  (caddar map)))
+	      (progn
+		(push (cadar map) map-files)
+		(setq prev map))
+	    (setq touched t)
+	    (if prev
+		(setcdr prev (cdr map))
+	      (setq nneething-map (cdr nneething-map))))
+	  (setq map (cdr map))))
+      ;; Find all new files and enter them into the map.
+      (while files
+	(unless (member (car files) map-files)
+	  ;; This file is not in the map, so we enter it.
+	  (setq touched t)
+	  (setcdr nneething-active (1+ (cdr nneething-active)))
+	  (push (list (cdr nneething-active) (car files)
+		      (nth 5 (file-attributes
+			      (nneething-file-name (car files)))))
+		nneething-map))
+	(setq files (cdr files)))
+      (when (and touched
+		 (not nneething-read-only))
+	(nnheader-temp-write map-file
+	  (insert "(setq nneething-map '")
+	  (gnus-prin1 nneething-map)
+	  (insert ")\n(setq nneething-active '")
+	  (gnus-prin1 nneething-active)
+	  (insert ")\n"))))))
+
+(defun nneething-insert-head (file)
+  "Insert the head of FILE."
+  (when (nneething-get-head file)
+    (insert-buffer-substring nneething-work-buffer)
+    (goto-char (point-max))))
+
+(defun nneething-make-head (file &optional buffer)
+  "Create a head by looking at the file attributes of FILE."
+  (let ((atts (file-attributes file)))
+    (insert
+     "Subject: " (file-name-nondirectory file) "\n"
+     "Message-ID: <nneething-"
+     (int-to-string (incf nneething-message-id-number))
+     "@" (system-name) ">\n"
+     (if (equal '(0 0) (nth 5 atts)) ""
+       (concat "Date: " (current-time-string (nth 5 atts)) "\n"))
+     (or (when buffer
+	   (save-excursion
+	     (set-buffer buffer)
+	     (when (re-search-forward "<[a-zA-Z0-9_]@[-a-zA-Z0-9_]>" 1000 t)
+	       (concat "From: " (match-string 0) "\n"))))
+	 (nneething-from-line (nth 2 atts) file))
+     (if (> (string-to-int (int-to-string (nth 7 atts))) 0)
+	 (concat "Chars: " (int-to-string (nth 7 atts)) "\n")
+       "")
+     (if buffer
+	 (save-excursion
+	   (set-buffer buffer)
+	   (concat "Lines: " (int-to-string
+			      (count-lines (point-min) (point-max)))
+		   "\n"))
+       "")
+     )))
+
+(defun nneething-from-line (uid &optional file)
+  "Return a From header based of UID."
+  (let* ((login (condition-case nil
+		    (user-login-name uid)
+		  (error
+		   (cond ((= uid (user-uid)) (user-login-name))
+			 ((zerop uid) "root")
+			 (t (int-to-string uid))))))
+	 (name (condition-case nil
+		   (user-full-name uid)
+		 (error
+		  (cond ((= uid (user-uid)) (user-full-name))
+			((zerop uid) "Ms. Root")))))
+	 (host (if  (string-match "\\`/[^/@]*@\\([^:/]+\\):" file)
+		   (prog1
+		       (substring file
+				  (match-beginning 1)
+				  (match-end 1))
+		     (when (string-match "/\\(users\\|home\\)/\\([^/]+\\)/" file)
+		       (setq login (substring file
+					      (match-beginning 2)
+					      (match-end 2))
+			     name nil)))
+		 (system-name))))
+    (concat "From: " login "@" host
+	    (if name (concat " (" name ")") "") "\n")))
+
+(defun nneething-get-head (file)
+  "Either find the head in FILE or make a head for FILE."
+  (save-excursion
+    (set-buffer (get-buffer-create nneething-work-buffer))
+    (setq case-fold-search nil)
+    (buffer-disable-undo (current-buffer))
+    (erase-buffer)
+    (cond
+     ((not (file-exists-p file))
+      ;; The file do not exist.
+      nil)
+     ((or (file-directory-p file)
+	  (file-symlink-p file))
+      ;; It's a dir, so we fudge a head.
+      (nneething-make-head file) t)
+     (t
+      ;; We examine the file.
+      (nnheader-insert-head file)
+      (if (nnheader-article-p)
+	  (delete-region
+	   (progn
+	     (goto-char (point-min))
+	     (or (and (search-forward "\n\n" nil t)
+		      (1- (point)))
+		 (point-max)))
+	   (point-max))
+	(goto-char (point-min))
+	(nneething-make-head file (current-buffer))
+	(delete-region (point) (point-max)))
+      t))))
+
+(defun nneething-file-name (article)
+  "Return the file name of ARTICLE."
+  (concat (file-name-as-directory nneething-directory)
+	  (if (numberp article)
+	      (cadr (assq article nneething-map))
+	    article)))
+
+(provide 'nneething)
+
+;;; nneething.el ends here

lisp/gnus/nnfolder.el

@@ -0,0 +1,768 @@
+;;; nnfolder.el --- mail folder access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Scott Byer <byer@mv.us.adobe.com>
+;;	Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'message)
+(require 'nnmail)
+(require 'nnoo)
+(require 'cl)
+(require 'gnus-util)
+
+(nnoo-declare nnfolder)
+
+(defvoo nnfolder-directory (expand-file-name message-directory)
+  "The name of the nnfolder directory.")
+
+(defvoo nnfolder-active-file
+  (nnheader-concat nnfolder-directory "active")
+  "The name of the active file.")
+
+;; I renamed this variable to something more in keeping with the general GNU
+;; style. -SLB
+
+(defvoo nnfolder-ignore-active-file nil
+  "If non-nil, causes nnfolder to do some extra work in order to determine
+the true active ranges of an mbox file.  Note that the active file is still
+saved, but it's values are not used.  This costs some extra time when
+scanning an mbox when opening it.")
+
+(defvoo nnfolder-distrust-mbox nil
+  "If non-nil, causes nnfolder to not trust the user with respect to
+inserting unaccounted for mail in the middle of an mbox file.  This can greatly
+slow down scans, which now must scan the entire file for unmarked messages.
+When nil, scans occur forward from the last marked message, a huge
+time saver for large mailboxes.")
+
+(defvoo nnfolder-newsgroups-file
+  (concat (file-name-as-directory nnfolder-directory) "newsgroups")
+  "Mail newsgroups description file.")
+
+(defvoo nnfolder-get-new-mail t
+  "If non-nil, nnfolder will check the incoming mail file and split the mail.")
+
+(defvoo nnfolder-prepare-save-mail-hook nil
+  "Hook run narrowed to an article before saving.")
+
+(defvoo nnfolder-save-buffer-hook nil
+  "Hook run before saving the nnfolder mbox buffer.")
+
+(defvoo nnfolder-inhibit-expiry nil
+  "If non-nil, inhibit expiry.")
+
+
+
+(defconst nnfolder-version "nnfolder 1.0"
+  "nnfolder version.")
+
+(defconst nnfolder-article-marker "X-Gnus-Article-Number: "
+  "String used to demarcate what the article number for a message is.")
+
+(defvoo nnfolder-current-group nil)
+(defvoo nnfolder-current-buffer nil)
+(defvoo nnfolder-status-string "")
+(defvoo nnfolder-group-alist nil)
+(defvoo nnfolder-buffer-alist nil)
+(defvoo nnfolder-scantime-alist nil)
+(defvoo nnfolder-active-timestamp nil)
+
+
+
+;;; Interface functions
+
+(nnoo-define-basics nnfolder)
+
+(deffoo nnfolder-retrieve-headers (articles &optional group server fetch-old)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (let (article art-string start stop)
+      (nnfolder-possibly-change-group group server)
+      (when nnfolder-current-buffer
+	(set-buffer nnfolder-current-buffer)
+	(goto-char (point-min))
+	(if (stringp (car articles))
+	    'headers
+	  (while articles
+	    (setq article (car articles))
+	    (setq art-string (nnfolder-article-string article))
+	    (set-buffer nnfolder-current-buffer)
+	    (when (or (search-forward art-string nil t)
+		      ;; Don't search the whole file twice!  Also, articles
+		      ;; probably have some locality by number, so searching
+		      ;; backwards will be faster.  Especially if we're at the
+		      ;; beginning of the buffer :-). -SLB
+		      (search-backward art-string nil t))
+	      (nnmail-search-unix-mail-delim-backward)
+	      (setq start (point))
+	      (search-forward "\n\n" nil t)
+	      (setq stop (1- (point)))
+	      (set-buffer nntp-server-buffer)
+	      (insert (format "221 %d Article retrieved.\n" article))
+	      (insert-buffer-substring nnfolder-current-buffer start stop)
+	      (goto-char (point-max))
+	      (insert ".\n"))
+	    (setq articles (cdr articles)))
+
+	  (set-buffer nntp-server-buffer)
+	  (nnheader-fold-continuation-lines)
+	  'headers)))))
+
+(deffoo nnfolder-open-server (server &optional defs)
+  (nnoo-change-server 'nnfolder server defs)
+  (nnmail-activate 'nnfolder t)
+  (gnus-make-directory nnfolder-directory)
+  (cond
+   ((not (file-exists-p nnfolder-directory))
+    (nnfolder-close-server)
+    (nnheader-report 'nnfolder "Couldn't create directory: %s"
+		     nnfolder-directory))
+   ((not (file-directory-p (file-truename nnfolder-directory)))
+    (nnfolder-close-server)
+    (nnheader-report 'nnfolder "Not a directory: %s" nnfolder-directory))
+   (t
+    (nnmail-activate 'nnfolder)
+    (nnheader-report 'nnfolder "Opened server %s using directory %s"
+		     server nnfolder-directory)
+    t)))
+
+(deffoo nnfolder-request-close ()
+  (let ((alist nnfolder-buffer-alist))
+    (while alist
+      (nnfolder-close-group (caar alist) nil t)
+      (setq alist (cdr alist))))
+  (nnoo-close-server 'nnfolder)
+  (setq nnfolder-buffer-alist nil
+	nnfolder-group-alist nil))
+
+(deffoo nnfolder-request-article (article &optional group server buffer)
+  (nnfolder-possibly-change-group group server)
+  (save-excursion
+    (set-buffer nnfolder-current-buffer)
+    (goto-char (point-min))
+    (when (search-forward (nnfolder-article-string article) nil t)
+      (let (start stop)
+	(nnmail-search-unix-mail-delim-backward)
+	(setq start (point))
+	(forward-line 1)
+	(unless (and (nnmail-search-unix-mail-delim)
+		     (forward-line -1))
+	  (goto-char (point-max)))
+	(setq stop (point))
+	(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
+	  (set-buffer nntp-server-buffer)
+	  (erase-buffer)
+	  (insert-buffer-substring nnfolder-current-buffer start stop)
+	  (goto-char (point-min))
+	  (while (looking-at "From ")
+	    (delete-char 5)
+	    (insert "X-From-Line: ")
+	    (forward-line 1))
+	  (if (numberp article)
+	      (cons nnfolder-current-group article)
+	    (goto-char (point-min))
+	    (search-forward (concat "\n" nnfolder-article-marker))
+	    (cons nnfolder-current-group
+		  (string-to-int
+		   (buffer-substring
+		    (point) (progn (end-of-line) (point)))))))))))
+
+(deffoo nnfolder-request-group (group &optional server dont-check)
+  (nnfolder-possibly-change-group group server t)
+  (save-excursion
+    (if (not (assoc group nnfolder-group-alist))
+	(nnheader-report 'nnfolder "No such group: %s" group)
+      (if dont-check
+	  (progn
+	    (nnheader-report 'nnfolder "Selected group %s" group)
+	    t)
+	(let* ((active (assoc group nnfolder-group-alist))
+	       (group (car active))
+	       (range (cadr active)))
+	  (cond
+	   ((null active)
+	    (nnheader-report 'nnfolder "No such group: %s" group))
+	   ((null nnfolder-current-group)
+	    (nnheader-report 'nnfolder "Empty group: %s" group))
+	   (t
+	    (nnheader-report 'nnfolder "Selected group %s" group)
+	    (nnheader-insert "211 %d %d %d %s\n"
+			     (1+ (- (cdr range) (car range)))
+			     (car range) (cdr range) group))))))))
+
+(deffoo nnfolder-request-scan (&optional group server)
+  (nnfolder-possibly-change-group nil server)
+  (when nnfolder-get-new-mail
+    (nnfolder-possibly-change-group group server)
+    (nnmail-get-new-mail
+     'nnfolder
+     (lambda ()
+       (let ((bufs nnfolder-buffer-alist))
+	 (save-excursion
+	   (while bufs
+	     (if (not (gnus-buffer-live-p (nth 1 (car bufs))))
+		 (setq nnfolder-buffer-alist
+		       (delq (car bufs) nnfolder-buffer-alist))
+	       (set-buffer (nth 1 (car bufs)))
+	       (nnfolder-save-buffer)
+	       (kill-buffer (current-buffer)))
+	     (setq bufs (cdr bufs))))))
+     nnfolder-directory
+     group)))
+
+;; Don't close the buffer if we're not shutting down the server.  This way,
+;; we can keep the buffer in the group buffer cache, and not have to grovel
+;; over the buffer again unless we add new mail to it or modify it in some
+;; way.
+
+(deffoo nnfolder-close-group (group &optional server force)
+  ;; Make sure we _had_ the group open.
+  (when (or (assoc group nnfolder-buffer-alist)
+	    (equal group nnfolder-current-group))
+    (let ((inf (assoc group nnfolder-buffer-alist)))
+      (when inf
+	(when (and nnfolder-current-group
+		   nnfolder-current-buffer)
+	  (push (list nnfolder-current-group nnfolder-current-buffer)
+		nnfolder-buffer-alist))
+	(setq nnfolder-buffer-alist
+	      (delq inf nnfolder-buffer-alist))
+	(setq nnfolder-current-buffer (cadr inf)
+	      nnfolder-current-group (car inf))))
+    (when (and nnfolder-current-buffer
+	       (buffer-name nnfolder-current-buffer))
+      (save-excursion
+	(set-buffer nnfolder-current-buffer)
+	;; If the buffer was modified, write the file out now.
+	(nnfolder-save-buffer)
+	;; If we're shutting the server down, we need to kill the
+	;; buffer and remove it from the open buffer list.  Or, of
+	;; course, if we're trying to minimize our space impact.
+	(kill-buffer (current-buffer))
+	(setq nnfolder-buffer-alist (delq (assoc group nnfolder-buffer-alist)
+					  nnfolder-buffer-alist)))))
+  (setq nnfolder-current-group nil
+	nnfolder-current-buffer nil)
+  t)
+
+(deffoo nnfolder-request-create-group (group &optional server args)
+  (nnfolder-possibly-change-group nil server)
+  (nnmail-activate 'nnfolder)
+  (when group
+    (unless (assoc group nnfolder-group-alist)
+      (push (list group (cons 1 0)) nnfolder-group-alist)
+      (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))
+  t)
+
+(deffoo nnfolder-request-list (&optional server)
+  (nnfolder-possibly-change-group nil server)
+  (save-excursion
+    (nnmail-find-file nnfolder-active-file)
+    (setq nnfolder-group-alist (nnmail-get-active))
+    t))
+
+(deffoo nnfolder-request-newgroups (date &optional server)
+  (nnfolder-possibly-change-group nil server)
+  (nnfolder-request-list server))
+
+(deffoo nnfolder-request-list-newsgroups (&optional server)
+  (nnfolder-possibly-change-group nil server)
+  (save-excursion
+    (nnmail-find-file nnfolder-newsgroups-file)))
+
+(deffoo nnfolder-request-expire-articles
+  (articles newsgroup &optional server force)
+  (nnfolder-possibly-change-group newsgroup server)
+  (let* ((is-old t)
+	 rest)
+    (nnmail-activate 'nnfolder)
+
+    (save-excursion
+      (set-buffer nnfolder-current-buffer)
+      (while (and articles is-old)
+	(goto-char (point-min))
+	(when (search-forward (nnfolder-article-string (car articles)) nil t)
+	  (if (setq is-old
+		    (nnmail-expired-article-p
+		     newsgroup
+		     (buffer-substring
+		      (point) (progn (end-of-line) (point)))
+		     force nnfolder-inhibit-expiry))
+	      (progn
+		(nnheader-message 5 "Deleting article %d..."
+				  (car articles) newsgroup)
+		(nnfolder-delete-mail))
+	    (push (car articles) rest)))
+	(setq articles (cdr articles)))
+      (unless nnfolder-inhibit-expiry
+	(nnheader-message 5 "Deleting articles...done"))
+      (nnfolder-save-buffer)
+      (nnfolder-adjust-min-active newsgroup)
+      (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+      (nconc rest articles))))
+
+(deffoo nnfolder-request-move-article
+  (article group server accept-form &optional last)
+  (let ((buf (get-buffer-create " *nnfolder move*"))
+	result)
+    (and
+     (nnfolder-request-article article group server)
+     (save-excursion
+       (set-buffer buf)
+       (buffer-disable-undo (current-buffer))
+       (erase-buffer)
+       (insert-buffer-substring nntp-server-buffer)
+       (goto-char (point-min))
+       (while (re-search-forward
+	       (concat "^" nnfolder-article-marker)
+	       (save-excursion (search-forward "\n\n" nil t) (point)) t)
+	 (delete-region (progn (beginning-of-line) (point))
+			(progn (forward-line 1) (point))))
+       (setq result (eval accept-form))
+       (kill-buffer buf)
+       result)
+     (save-excursion
+       (nnfolder-possibly-change-group group server)
+       (set-buffer nnfolder-current-buffer)
+       (goto-char (point-min))
+       (when (search-forward (nnfolder-article-string article) nil t)
+	 (nnfolder-delete-mail))
+       (when last
+	 (nnfolder-save-buffer)
+	 (nnfolder-adjust-min-active group)
+	 (nnmail-save-active nnfolder-group-alist nnfolder-active-file))))
+    result))
+
+(deffoo nnfolder-request-accept-article (group &optional server last)
+  (nnfolder-possibly-change-group group server)
+  (nnmail-check-syntax)
+  (let ((buf (current-buffer))
+	result art-group)
+    (goto-char (point-min))
+    (when (looking-at "X-From-Line: ")
+      (replace-match "From "))
+    (and
+     (nnfolder-request-list)
+     (save-excursion
+       (set-buffer buf)
+       (goto-char (point-min))
+       (search-forward "\n\n" nil t)
+       (forward-line -1)
+       (while (re-search-backward (concat "^" nnfolder-article-marker) nil t)
+	 (delete-region (point) (progn (forward-line 1) (point))))
+       (when nnmail-cache-accepted-message-ids
+	 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
+       (setq result (if (stringp group)
+			(list (cons group (nnfolder-active-number group)))
+		      (setq art-group
+			    (nnmail-article-group 'nnfolder-active-number))))
+       (if (and (null result)
+		(yes-or-no-p "Moved to `junk' group; delete article? "))
+	   (setq result 'junk)
+	 (setq result
+	       (car (nnfolder-save-mail result)))))
+     (when last
+       (save-excursion
+	 (nnfolder-possibly-change-folder (or (caar art-group) group))
+	 (nnfolder-save-buffer)
+	 (when nnmail-cache-accepted-message-ids
+	   (nnmail-cache-close)))))
+    (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+    (unless result
+      (nnheader-report 'nnfolder "Couldn't store article"))
+    result))
+
+(deffoo nnfolder-request-replace-article (article group buffer)
+  (nnfolder-possibly-change-group group)
+  (save-excursion
+    (set-buffer nnfolder-current-buffer)
+    (goto-char (point-min))
+    (if (not (search-forward (nnfolder-article-string article) nil t))
+	nil
+      (nnfolder-delete-mail t t)
+      (insert-buffer-substring buffer)
+      (nnfolder-save-buffer)
+      t)))
+
+(deffoo nnfolder-request-delete-group (group &optional force server)
+  (nnfolder-close-group group server t)
+  ;; Delete all articles in GROUP.
+  (if (not force)
+      ()				; Don't delete the articles.
+    ;; Delete the file that holds the group.
+    (ignore-errors
+      (delete-file (nnfolder-group-pathname group))))
+  ;; Remove the group from all structures.
+  (setq nnfolder-group-alist
+	(delq (assoc group nnfolder-group-alist) nnfolder-group-alist)
+	nnfolder-current-group nil
+	nnfolder-current-buffer nil)
+  ;; Save the active file.
+  (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+  t)
+
+(deffoo nnfolder-request-rename-group (group new-name &optional server)
+  (nnfolder-possibly-change-group group server)
+  (save-excursion
+    (set-buffer nnfolder-current-buffer)
+    (and (file-writable-p buffer-file-name)
+	 (ignore-errors
+	   (rename-file
+	    buffer-file-name
+	    (nnfolder-group-pathname new-name))
+	   t)
+	 ;; That went ok, so we change the internal structures.
+	 (let ((entry (assoc group nnfolder-group-alist)))
+	   (and entry (setcar entry new-name))
+	   (setq nnfolder-current-buffer nil
+		 nnfolder-current-group nil)
+	   ;; Save the new group alist.
+	   (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+	   ;; We kill the buffer instead of renaming it and stuff.
+	   (kill-buffer (current-buffer))
+	   t))))
+
+
+;;; Internal functions.
+
+(defun nnfolder-adjust-min-active (group)
+  ;; Find the lowest active article in this group.
+  (let* ((active (cadr (assoc group nnfolder-group-alist)))
+	 (marker (concat "\n" nnfolder-article-marker))
+	 (number "[0-9]+")
+	 (activemin (cdr active)))
+    (save-excursion
+      (set-buffer nnfolder-current-buffer)
+      (goto-char (point-min))
+      (while (and (search-forward marker nil t)
+		  (re-search-forward number nil t))
+	(setq activemin (min activemin
+			     (string-to-number (buffer-substring
+						(match-beginning 0)
+						(match-end 0))))))
+      (setcar active activemin))))
+
+(defun nnfolder-article-string (article)
+  (if (numberp article)
+      (concat "\n" nnfolder-article-marker (int-to-string article) " ")
+    (concat "\nMessage-ID: " article)))
+
+(defun nnfolder-delete-mail (&optional force leave-delim)
+  "Delete the message that point is in."
+  (save-excursion
+    (delete-region
+     (save-excursion
+       (nnmail-search-unix-mail-delim-backward)
+       (if leave-delim (progn (forward-line 1) (point))
+	 (point)))
+     (progn
+       (forward-line 1)
+       (if (nnmail-search-unix-mail-delim)
+	   (if (and (not (bobp)) leave-delim)
+	       (progn (forward-line -2) (point))
+	     (point))
+	 (point-max))))))
+
+(defun nnfolder-possibly-change-group (group &optional server dont-check)
+  ;; Change servers.
+  (when (and server
+	     (not (nnfolder-server-opened server)))
+    (nnfolder-open-server server))
+  (unless (gnus-buffer-live-p nnfolder-current-buffer)
+    (setq nnfolder-current-buffer nil
+	  nnfolder-current-group nil))
+  ;; Change group.
+  (when (and group
+	     (not (equal group nnfolder-current-group)))
+    (nnmail-activate 'nnfolder)
+    (when (and (not (assoc group nnfolder-group-alist))
+	       (not (file-exists-p
+		     (nnfolder-group-pathname group))))
+      ;; The group doesn't exist, so we create a new entry for it.
+      (push (list group (cons 1 0)) nnfolder-group-alist)
+      (nnmail-save-active nnfolder-group-alist nnfolder-active-file))
+
+    (if dont-check
+	(setq nnfolder-current-group group)
+      (let (inf file)
+	;; If we have to change groups, see if we don't already have the
+	;; folder in memory.  If we do, verify the modtime and destroy
+	;; the folder if needed so we can rescan it.
+	(when (setq inf (assoc group nnfolder-buffer-alist))
+	  (setq nnfolder-current-buffer (nth 1 inf)))
+
+	;; If the buffer is not live, make sure it isn't in the alist.  If it
+	;; is live, verify that nobody else has touched the file since last
+	;; time.
+	(when (and nnfolder-current-buffer
+		   (not (gnus-buffer-live-p nnfolder-current-buffer)))
+	  (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist)
+		nnfolder-current-buffer nil))
+
+	(setq nnfolder-current-group group)
+
+	(when (or (not nnfolder-current-buffer)
+		  (not (verify-visited-file-modtime nnfolder-current-buffer)))
+	  (save-excursion
+	    (setq file (nnfolder-group-pathname group))
+	    ;; See whether we need to create the new file.
+	    (unless (file-exists-p file)
+	      (gnus-make-directory (file-name-directory file))
+	      (nnmail-write-region 1 1 file t 'nomesg))
+	    (when (setq nnfolder-current-buffer (nnfolder-read-folder group))
+	      (set-buffer nnfolder-current-buffer)
+	      (push (list group nnfolder-current-buffer)
+		    nnfolder-buffer-alist))))))))
+
+(defun nnfolder-save-mail (group-art-list)
+  "Called narrowed to an article."
+  (let* (save-list group-art)
+    (goto-char (point-min))
+    ;; The From line may have been quoted by movemail.
+    (when (looking-at (concat ">" message-unix-mail-delimiter))
+      (delete-char 1))
+    ;; This might come from somewhere else.
+    (unless (looking-at message-unix-mail-delimiter)
+      (insert "From nobody " (current-time-string) "\n")
+      (goto-char (point-min)))
+    ;; Quote all "From " lines in the article.
+    (forward-line 1)
+    (let (case-fold-search)
+      (while (re-search-forward "^From " nil t)
+	(beginning-of-line)
+	(insert "> ")))
+    (setq save-list group-art-list)
+    (nnmail-insert-lines)
+    (nnmail-insert-xref group-art-list)
+    (run-hooks 'nnmail-prepare-save-mail-hook)
+    (run-hooks 'nnfolder-prepare-save-mail-hook)
+
+    ;; Insert the mail into each of the destination groups.
+    (while (setq group-art (pop group-art-list))
+      ;; Kill any previous newsgroup markers.
+      (goto-char (point-min))
+      (search-forward "\n\n" nil t)
+      (forward-line -1)
+      (while (search-backward (concat "\n" nnfolder-article-marker) nil t)
+	(delete-region (1+ (point)) (progn (forward-line 2) (point))))
+
+      ;; Insert the new newsgroup marker.
+      (nnfolder-insert-newsgroup-line group-art)
+
+      (save-excursion
+	(let ((beg (point-min))
+	      (end (point-max))
+	      (obuf (current-buffer)))
+	  (nnfolder-possibly-change-folder (car group-art))
+	  (let ((buffer-read-only nil))
+	    (goto-char (point-max))
+	    (unless (eolp)
+	      (insert "\n"))
+	    (unless (bobp)
+	      (insert "\n"))
+	    (insert-buffer-substring obuf beg end)))))
+
+    ;; Did we save it anywhere?
+    save-list))
+
+(defun nnfolder-insert-newsgroup-line (group-art)
+  (save-excursion
+    (goto-char (point-min))
+    (when (search-forward "\n\n" nil t)
+      (forward-char -1)
+      (insert (format (concat nnfolder-article-marker "%d   %s\n")
+		      (cdr group-art) (current-time-string))))))
+
+(defun nnfolder-active-number (group)
+  ;; Find the next article number in GROUP.
+  (let ((active (cadr (assoc group nnfolder-group-alist))))
+    (if active
+	(setcdr active (1+ (cdr active)))
+      ;; This group is new, so we create a new entry for it.
+      ;; This might be a bit naughty... creating groups on the drop of
+      ;; a hat, but I don't know...
+      (push (list group (setq active (cons 1 1)))
+	    nnfolder-group-alist))
+    (cdr active)))
+
+(defun nnfolder-possibly-change-folder (group)
+  (let ((inf (assoc group nnfolder-buffer-alist)))
+    (if (and inf
+	     (gnus-buffer-live-p (cadr inf)))
+	(set-buffer (cadr inf))
+      (when inf
+	(setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist)))
+      (when nnfolder-group-alist
+	(nnmail-save-active nnfolder-group-alist nnfolder-active-file))
+      (push (list group (nnfolder-read-folder group))
+	    nnfolder-buffer-alist))))
+
+;; This method has a problem if you've accidentally let the active list get
+;; out of sync with the files.  This could happen, say, if you've
+;; accidentally gotten new mail with something other than Gnus (but why
+;; would _that_ ever happen? :-).  In that case, we will be in the middle of
+;; processing the file, ready to add new X-Gnus article number markers, and
+;; we'll run across a message with no ID yet - the active list _may_not_ be
+;; ready for us yet.
+
+;; To handle this, I'm modifying this routine to maintain the maximum ID seen
+;; so far, and when we hit a message with no ID, we will _manually_ scan the
+;; rest of the message looking for any more, possibly higher IDs.  We'll
+;; assume the maximum that we find is the highest active.  Note that this
+;; shouldn't cost us much extra time at all, but will be a lot less
+;; vulnerable to glitches between the mbox and the active file.
+
+(defun nnfolder-read-folder (group)
+  (let* ((file (nnfolder-group-pathname group))
+	 (buffer (set-buffer (nnheader-find-file-noselect file))))
+    (if (equal (cadr (assoc group nnfolder-scantime-alist))
+	       (nth 5 (file-attributes file)))
+	;; This looks up-to-date, so we don't do any scanning.
+	buffer
+      ;; Parse the damn thing.
+      (save-excursion
+	(nnmail-activate 'nnfolder)
+	;; Read in the file.
+	(let ((delim (concat "^" message-unix-mail-delimiter))
+	      (marker (concat "\n" nnfolder-article-marker))
+	      (number "[0-9]+")
+	      (active (or (cadr (assoc group nnfolder-group-alist))
+			  (cons 1 0)))
+	      (scantime (assoc group nnfolder-scantime-alist))
+	      (minid (lsh -1 -1))
+	      maxid start end newscantime
+	      buffer-read-only)
+	  (buffer-disable-undo (current-buffer))
+	  (setq maxid (cdr active))
+	  (goto-char (point-min))
+
+	  ;; Anytime the active number is 1 or 0, it is suspect.  In that
+	  ;; case, search the file manually to find the active number.  Or,
+	  ;; of course, if we're being paranoid.  (This would also be the
+	  ;; place to build other lists from the header markers, such as
+	  ;; expunge lists, etc., if we ever desired to abandon the active
+	  ;; file entirely for mboxes.)
+	  (when (or nnfolder-ignore-active-file
+		    (< maxid 2))
+	    (while (and (search-forward marker nil t)
+			(re-search-forward number nil t))
+	      (let ((newnum (string-to-number (match-string 0))))
+		(setq maxid (max maxid newnum))
+		(setq minid (min minid newnum))))
+	    (setcar active (max 1 (min minid maxid)))
+	    (setcdr active (max maxid (cdr active)))
+	    (goto-char (point-min)))
+
+	  ;; As long as we trust that the user will only insert unmarked mail
+	  ;; at the end, go to the end and search backwards for the last
+	  ;; marker.  Find the start of that message, and begin to search for
+	  ;; unmarked messages from there.
+	  (when (not (or nnfolder-distrust-mbox
+			 (< maxid 2)))
+	    (goto-char (point-max))
+	    (unless (re-search-backward marker nil t)
+	      (goto-char (point-min)))
+	    (when (nnmail-search-unix-mail-delim)
+	      (goto-char (point-min))))
+
+	  ;; Keep track of the active number on our own, and insert it back
+	  ;; into the active list when we're done.  Also, prime the pump to
+	  ;; cut down on the number of searches we do.
+	  (unless (nnmail-search-unix-mail-delim)
+	    (goto-char (point-max)))
+	  (setq end (point-marker))
+	  (while (not (= end (point-max)))
+	    (setq start (marker-position end))
+	    (goto-char end)
+	    ;; There may be more than one "From " line, so we skip past
+	    ;; them.
+	    (while (looking-at delim)
+	      (forward-line 1))
+	    (set-marker end (if (nnmail-search-unix-mail-delim)
+				(point)
+			      (point-max)))
+	    (goto-char start)
+	    (when (not (search-forward marker end t))
+	      (narrow-to-region start end)
+	      (nnmail-insert-lines)
+	      (nnfolder-insert-newsgroup-line
+	       (cons nil (nnfolder-active-number nnfolder-current-group)))
+	      (widen)))
+
+	  (set-marker end nil)
+	  ;; Make absolutely sure that the active list reflects reality!
+	  (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+	  ;; Set the scantime for this group.
+	  (setq newscantime (visited-file-modtime))
+	  (if scantime
+	      (setcdr scantime (list newscantime))
+	    (push (list nnfolder-current-group newscantime)
+		  nnfolder-scantime-alist))
+	  (current-buffer))))))
+
+;;;###autoload
+(defun nnfolder-generate-active-file ()
+  "Look for mbox folders in the nnfolder directory and make them into groups."
+  (interactive)
+  (nnmail-activate 'nnfolder)
+  (let ((files (directory-files nnfolder-directory))
+        file)
+    (while (setq file (pop files))
+      (when (and (not (backup-file-name-p file))
+                 (message-mail-file-mbox-p
+		  (nnheader-concat nnfolder-directory file)))
+        (let ((oldgroup (assoc file nnfolder-group-alist)))
+          (if oldgroup
+              (nnheader-message 5 "Refreshing group %s..." file)
+            (nnheader-message 5 "Adding group %s..." file))
+          (setq nnfolder-group-alist (remove oldgroup nnfolder-group-alist))
+          (push (list file (cons 1 0)) nnfolder-group-alist)
+          (nnfolder-possibly-change-folder file)
+          (nnfolder-possibly-change-group file)
+          (nnfolder-close-group file))))
+    (message "")))
+
+(defun nnfolder-group-pathname (group)
+  "Make pathname for GROUP."
+  (let ((dir (file-name-as-directory (expand-file-name nnfolder-directory))))
+    ;; If this file exists, we use it directly.
+    (if (or nnmail-use-long-file-names
+	    (file-exists-p (concat dir group)))
+	(concat dir group)
+      ;; If not, we translate dots into slashes.
+      (concat dir (nnheader-replace-chars-in-string group ?. ?/)))))
+
+(defun nnfolder-save-buffer ()
+  "Save the buffer."
+  (when (buffer-modified-p)
+    (run-hooks 'nnfolder-save-buffer-hook)
+    (save-buffer)))
+
+(provide 'nnfolder)
+
+;;; nnfolder.el ends here

lisp/gnus/nngateway.el

@@ -0,0 +1,80 @@
+;;; nngateway.el --- posting news via mail gateways
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnoo)
+(require 'message)
+
+(nnoo-declare nngateway)
+
+(defvoo nngateway-address nil
+  "Address of the mail-to-news gateway.")
+
+(defvoo nngateway-header-transformation 'nngateway-simple-header-transformation
+  "Function to be called to rewrite the news headers into mail headers.
+It is called narrowed to the headers to be transformed with one
+parameter -- the gateway address.")
+
+;;; Interface functions
+
+(nnoo-define-basics nngateway)
+
+(deffoo nngateway-open-server (server &optional defs)
+  (if (nngateway-server-opened server)
+      t
+    (unless (assq 'nngateway-address defs)
+      (setq defs (append defs (list (list 'nngateway-address server)))))
+    (nnoo-change-server 'nngateway server defs)))
+
+(deffoo nngateway-request-post (&optional server)
+  (when (or (nngateway-server-opened server)
+	    (nngateway-open-server server))
+    ;; Rewrite the header.
+    (let ((buf (current-buffer)))
+      (nnheader-temp-write nil
+	(insert-buffer-substring buf)
+	(message-narrow-to-head)
+	(funcall nngateway-header-transformation nngateway-address)
+	(widen)
+	(let (message-required-mail-headers)
+	  (message-send-mail))))))
+
+;;; Internal functions
+
+(defun nngateway-simple-header-transformation (gateway)
+  "Transform the headers to use GATEWAY."
+  (let ((newsgroups (mail-fetch-field "newsgroups")))
+    (message-remove-header "to")
+    (message-remove-header "cc")
+    (goto-char (point-min))
+    (insert "To: " (nnheader-replace-chars-in-string newsgroups ?. ?-)
+	    "@" gateway "\n")))
+
+(nnoo-define-skeleton nngateway)
+
+(provide 'nngateway)
+
+;;; nngateway.el ends here

lisp/gnus/nnheader.el

@@ -0,0 +1,820 @@
+;;; nnheader.el --- header access macros for Gnus and its backends
+;; Copyright (C) 1987,88,89,90,93,94,95,96,97 Free Software Foundation, Inc.
+
+;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; 	Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; These macros may look very much like the ones in GNUS 4.1.  They
+;; are, in a way, but you should note that the indices they use have
+;; been changed from the internal GNUS format to the NOV format.  The
+;; makes it possible to read headers from XOVER much faster.
+;;
+;; The format of a header is now:
+;; [number subject from date id references chars lines xref]
+;;
+;; (That last entry is defined as "misc" in the NOV format, but Gnus
+;; uses it for xrefs.)
+
+;;; Code:
+
+(require 'mail-utils)
+
+(defvar nnheader-max-head-length 4096
+  "*Max length of the head of articles.")
+
+(defvar nnheader-head-chop-length 2048
+  "*Length of each read operation when trying to fetch HEAD headers.")
+
+(defvar nnheader-file-name-translation-alist nil
+  "*Alist that says how to translate characters in file names.
+For instance, if \":\" is illegal as a file character in file names
+on your system, you could say something like:
+
+\(setq nnheader-file-name-translation-alist '((?: . ?_)))")
+
+(eval-and-compile
+ (autoload 'nnmail-message-id "nnmail")
+ (autoload 'mail-position-on-field "sendmail")
+ (autoload 'message-remove-header "message")
+ (autoload 'cancel-function-timers "timers")
+ (autoload 'gnus-point-at-eol "gnus-util"))
+
+;;; Header access macros.
+
+(defmacro mail-header-number (header)
+  "Return article number in HEADER."
+  `(aref ,header 0))
+
+(defmacro mail-header-set-number (header number)
+  "Set article number of HEADER to NUMBER."
+  `(aset ,header 0 ,number))
+
+(defmacro mail-header-subject (header)
+  "Return subject string in HEADER."
+  `(aref ,header 1))
+
+(defmacro mail-header-set-subject (header subject)
+  "Set article subject of HEADER to SUBJECT."
+  `(aset ,header 1 ,subject))
+
+(defmacro mail-header-from (header)
+  "Return author string in HEADER."
+  `(aref ,header 2))
+
+(defmacro mail-header-set-from (header from)
+  "Set article author of HEADER to FROM."
+  `(aset ,header 2 ,from))
+
+(defmacro mail-header-date (header)
+  "Return date in HEADER."
+  `(aref ,header 3))
+
+(defmacro mail-header-set-date (header date)
+  "Set article date of HEADER to DATE."
+  `(aset ,header 3 ,date))
+
+(defalias 'mail-header-message-id 'mail-header-id)
+(defmacro mail-header-id (header)
+  "Return Id in HEADER."
+  `(aref ,header 4))
+
+(defalias 'mail-header-set-message-id 'mail-header-set-id)
+(defmacro mail-header-set-id (header id)
+  "Set article Id of HEADER to ID."
+  `(aset ,header 4 ,id))
+
+(defmacro mail-header-references (header)
+  "Return references in HEADER."
+  `(aref ,header 5))
+
+(defmacro mail-header-set-references (header ref)
+  "Set article references of HEADER to REF."
+  `(aset ,header 5 ,ref))
+
+(defmacro mail-header-chars (header)
+  "Return number of chars of article in HEADER."
+  `(aref ,header 6))
+
+(defmacro mail-header-set-chars (header chars)
+  "Set number of chars in article of HEADER to CHARS."
+  `(aset ,header 6 ,chars))
+
+(defmacro mail-header-lines (header)
+  "Return lines in HEADER."
+  `(aref ,header 7))
+
+(defmacro mail-header-set-lines (header lines)
+  "Set article lines of HEADER to LINES."
+  `(aset ,header 7 ,lines))
+
+(defmacro mail-header-xref (header)
+  "Return xref string in HEADER."
+  `(aref ,header 8))
+
+(defmacro mail-header-set-xref (header xref)
+  "Set article xref of HEADER to xref."
+  `(aset ,header 8 ,xref))
+
+(defun make-mail-header (&optional init)
+  "Create a new mail header structure initialized with INIT."
+  (make-vector 9 init))
+
+(defun make-full-mail-header (&optional number subject from date id
+					references chars lines xref)
+  "Create a new mail header structure initialized with the parameters given."
+  (vector number subject from date id references chars lines xref))
+
+;; fake message-ids: generation and detection
+
+(defvar nnheader-fake-message-id 1)
+
+(defsubst nnheader-generate-fake-message-id ()
+  (concat "fake+none+" (int-to-string (incf nnheader-fake-message-id))))
+
+(defsubst nnheader-fake-message-id-p (id)
+  (save-match-data			; regular message-id's are <.*>
+    (string-match "\\`fake\\+none\\+[0-9]+\\'" id)))
+
+;; Parsing headers and NOV lines.
+
+(defsubst nnheader-header-value ()
+  (buffer-substring (match-end 0) (gnus-point-at-eol)))
+
+(defun nnheader-parse-head (&optional naked)
+  (let ((case-fold-search t)
+	(cur (current-buffer))
+	(buffer-read-only nil)
+	in-reply-to lines p)
+    (goto-char (point-min))
+    (when naked
+      (insert "\n"))
+    ;; Search to the beginning of the next header.  Error messages
+    ;; do not begin with 2 or 3.
+    (prog1
+	(when (or naked (re-search-forward "^[23][0-9]+ " nil t))
+	  ;; This implementation of this function, with nine
+	  ;; search-forwards instead of the one re-search-forward and
+	  ;; a case (which basically was the old function) is actually
+	  ;; about twice as fast, even though it looks messier.	 You
+	  ;; can't have everything, I guess.  Speed and elegance
+	  ;; don't always go hand in hand.
+	  (vector
+	   ;; Number.
+	   (if naked
+	       (progn
+		 (setq p (point-min))
+		 0)
+	     (prog1
+		 (read cur)
+	       (end-of-line)
+	       (setq p (point))
+	       (narrow-to-region (point)
+				 (or (and (search-forward "\n.\n" nil t)
+					  (- (point) 2))
+				     (point)))))
+	   ;; Subject.
+	   (progn
+	     (goto-char p)
+	     (if (search-forward "\nsubject: " nil t)
+		 (nnheader-header-value) "(none)"))
+	   ;; From.
+	   (progn
+	     (goto-char p)
+	     (if (search-forward "\nfrom: " nil t)
+		 (nnheader-header-value) "(nobody)"))
+	   ;; Date.
+	   (progn
+	     (goto-char p)
+	     (if (search-forward "\ndate: " nil t)
+		 (nnheader-header-value) ""))
+	   ;; Message-ID.
+	   (progn
+	     (goto-char p)
+	     (if (search-forward "\nmessage-id:" nil t)
+		 (buffer-substring
+		  (1- (or (search-forward "<" nil t) (point)))
+		  (or (search-forward ">" nil t) (point)))
+	       ;; If there was no message-id, we just fake one to make
+	       ;; subsequent routines simpler.
+	       (nnheader-generate-fake-message-id)))
+	   ;; References.
+	   (progn
+	     (goto-char p)
+	     (if (search-forward "\nreferences: " nil t)
+		 (nnheader-header-value)
+	       ;; Get the references from the in-reply-to header if there
+	       ;; were no references and the in-reply-to header looks
+	       ;; promising.
+	       (if (and (search-forward "\nin-reply-to: " nil t)
+			(setq in-reply-to (nnheader-header-value))
+			(string-match "<[^>]+>" in-reply-to))
+		   (substring in-reply-to (match-beginning 0)
+			      (match-end 0))
+		 "")))
+	   ;; Chars.
+	   0
+	   ;; Lines.
+	   (progn
+	     (goto-char p)
+	     (if (search-forward "\nlines: " nil t)
+		 (if (numberp (setq lines (read cur)))
+		     lines 0)
+	       0))
+	   ;; Xref.
+	   (progn
+	     (goto-char p)
+	     (and (search-forward "\nxref: " nil t)
+		  (nnheader-header-value)))))
+      (when naked
+	(goto-char (point-min))
+	(delete-char 1)))))
+
+(defmacro nnheader-nov-skip-field ()
+  '(search-forward "\t" eol 'move))
+
+(defmacro nnheader-nov-field ()
+  '(buffer-substring (point) (if (nnheader-nov-skip-field) (1- (point)) eol)))
+
+(defmacro nnheader-nov-read-integer ()
+  '(prog1
+       (if (= (following-char) ?\t)
+	   0
+	 (let ((num (ignore-errors (read (current-buffer)))))
+	   (if (numberp num) num 0)))
+     (or (eobp) (forward-char 1))))
+
+;; (defvar nnheader-none-counter 0)
+
+(defun nnheader-parse-nov ()
+  (let ((eol (gnus-point-at-eol)))
+    (vector
+     (nnheader-nov-read-integer)	; number
+     (nnheader-nov-field)		; subject
+     (nnheader-nov-field)		; from
+     (nnheader-nov-field)		; date
+     (or (nnheader-nov-field)
+	 (nnheader-generate-fake-message-id)) ; id
+     (nnheader-nov-field)		; refs
+     (nnheader-nov-read-integer)	; chars
+     (nnheader-nov-read-integer)	; lines
+     (if (= (following-char) ?\n)
+	 nil
+       (nnheader-nov-field))		; misc
+     )))
+
+(defun nnheader-insert-nov (header)
+  (princ (mail-header-number header) (current-buffer))
+  (insert
+   "\t"
+   (or (mail-header-subject header) "(none)") "\t"
+   (or (mail-header-from header) "(nobody)") "\t"
+   (or (mail-header-date header) "") "\t"
+   (or (mail-header-id header)
+       (nnmail-message-id))
+   "\t"
+   (or (mail-header-references header) "") "\t")
+  (princ (or (mail-header-chars header) 0) (current-buffer))
+  (insert "\t")
+  (princ (or (mail-header-lines header) 0) (current-buffer))
+  (insert "\t")
+  (when (mail-header-xref header)
+    (insert "Xref: " (mail-header-xref header) "\t"))
+  (insert "\n"))
+
+(defun nnheader-insert-article-line (article)
+  (goto-char (point-min))
+  (insert "220 ")
+  (princ article (current-buffer))
+  (insert " Article retrieved.\n")
+  (search-forward "\n\n" nil 'move)
+  (delete-region (point) (point-max))
+  (forward-char -1)
+  (insert "."))
+
+(defun nnheader-nov-delete-outside-range (beg end)
+  "Delete all NOV lines that lie outside the BEG to END range."
+  ;; First we find the first wanted line.
+  (nnheader-find-nov-line beg)
+  (delete-region (point-min) (point))
+  ;; Then we find the last wanted line.
+  (when (nnheader-find-nov-line end)
+    (forward-line 1))
+  (delete-region (point) (point-max)))
+
+(defun nnheader-find-nov-line (article)
+  "Put point at the NOV line that start with ARTICLE.
+If ARTICLE doesn't exist, put point where that line
+would have been.  The function will return non-nil if
+the line could be found."
+  ;; This function basically does a binary search.
+  (let ((max (point-max))
+	(min (goto-char (point-min)))
+	(cur (current-buffer))
+	(prev (point-min))
+	num found)
+    (while (not found)
+      (goto-char (/ (+ max min) 2))
+      (beginning-of-line)
+      (if (or (= (point) prev)
+	      (eobp))
+	  (setq found t)
+	(setq prev (point))
+	(cond ((> (setq num (read cur)) article)
+	       (setq max (point)))
+	      ((< num article)
+	       (setq min (point)))
+	      (t
+	       (setq found 'yes)))))
+    ;; We may be at the first line.
+    (when (and (not num)
+	       (not (eobp)))
+      (setq num (read cur)))
+    ;; Now we may have found the article we're looking for, or we
+    ;; may be somewhere near it.
+    (when (and (not (eq found 'yes))
+	       (not (eq num article)))
+      (setq found (point))
+      (while (and (< (point) max)
+		  (or (not (numberp num))
+		      (< num article)))
+	(forward-line 1)
+	(setq found (point))
+	(or (eobp)
+	    (= (setq num (read cur)) article)))
+      (unless (eq num article)
+	(goto-char found)))
+    (beginning-of-line)
+    (eq num article)))
+
+;; Various cruft the backends and Gnus need to communicate.
+
+(defvar nntp-server-buffer nil)
+(defvar gnus-verbose-backends 7
+  "*A number that says how talkative the Gnus backends should be.")
+(defvar gnus-nov-is-evil nil
+  "If non-nil, Gnus backends will never output headers in the NOV format.")
+(defvar news-reply-yank-from nil)
+(defvar news-reply-yank-message-id nil)
+
+(defvar nnheader-callback-function nil)
+
+(defun nnheader-init-server-buffer ()
+  "Initialize the Gnus-backend communication buffer."
+  (save-excursion
+    (unless (gnus-buffer-live-p nntp-server-buffer)
+      (setq nntp-server-buffer (get-buffer-create " *nntpd*")))
+    (set-buffer nntp-server-buffer)
+    (buffer-disable-undo (current-buffer))
+    (erase-buffer)
+    (kill-all-local-variables)
+    (setq case-fold-search t)		;Should ignore case.
+    t))
+
+;;; Various functions the backends use.
+
+(defun nnheader-file-error (file)
+  "Return a string that says what is wrong with FILE."
+  (format
+   (cond
+    ((not (file-exists-p file))
+     "%s does not exist")
+    ((file-directory-p file)
+     "%s is a directory")
+    ((not (file-readable-p file))
+     "%s is not readable"))
+   file))
+
+(defun nnheader-insert-head (file)
+  "Insert the head of the article."
+  (when (file-exists-p file)
+    (if (eq nnheader-max-head-length t)
+	;; Just read the entire file.
+	(nnheader-insert-file-contents file)
+      ;; Read 1K blocks until we find a separator.
+      (let ((beg 0)
+	    format-alist)
+	(while (and (eq nnheader-head-chop-length
+			(nth 1 (nnheader-insert-file-contents
+				file nil beg
+				(incf beg nnheader-head-chop-length))))
+		    (prog1 (not (search-forward "\n\n" nil t))
+		      (goto-char (point-max)))
+		    (or (null nnheader-max-head-length)
+			(< beg nnheader-max-head-length))))))
+    t))
+
+(defun nnheader-article-p ()
+  "Say whether the current buffer looks like an article."
+  (goto-char (point-min))
+  (if (not (search-forward "\n\n" nil t))
+      nil
+    (narrow-to-region (point-min) (1- (point)))
+    (goto-char (point-min))
+    (while (looking-at "[A-Z][^ \t]+:.*\n\\([ \t].*\n\\)*\\|From .*\n")
+      (goto-char (match-end 0)))
+    (prog1
+	(eobp)
+      (widen))))
+
+(defun nnheader-insert-references (references message-id)
+  "Insert a References header based on REFERENCES and MESSAGE-ID."
+  (if (and (not references) (not message-id))
+      ()				; This is illegal, but not all articles have Message-IDs.
+    (mail-position-on-field "References")
+    (let ((begin (save-excursion (beginning-of-line) (point)))
+	  (fill-column 78)
+	  (fill-prefix "\t"))
+      (when references
+	(insert references))
+      (when (and references message-id)
+	(insert " "))
+      (when message-id
+	(insert message-id))
+      ;; Fold long References lines to conform to RFC1036 (sort of).
+      ;; The region must end with a newline to fill the region
+      ;; without inserting extra newline.
+      (fill-region-as-paragraph begin (1+ (point))))))
+
+(defun nnheader-replace-header (header new-value)
+  "Remove HEADER and insert the NEW-VALUE."
+  (save-excursion
+    (save-restriction
+      (nnheader-narrow-to-headers)
+      (prog1
+	  (message-remove-header header)
+	(goto-char (point-max))
+	(insert header ": " new-value "\n")))))
+
+(defun nnheader-narrow-to-headers ()
+  "Narrow to the head of an article."
+  (widen)
+  (narrow-to-region
+   (goto-char (point-min))
+   (if (search-forward "\n\n" nil t)
+       (1- (point))
+     (point-max)))
+  (goto-char (point-min)))
+
+(defun nnheader-set-temp-buffer (name &optional noerase)
+  "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled."
+  (set-buffer (get-buffer-create name))
+  (buffer-disable-undo (current-buffer))
+  (unless noerase
+    (erase-buffer))
+  (current-buffer))
+
+(defmacro nnheader-temp-write (file &rest forms)
+  "Create a new buffer, evaluate FORMS there, and write the buffer to FILE.
+Return the value of FORMS.
+If FILE is nil, just evaluate FORMS and don't save anything.
+If FILE is t, return the buffer contents as a string."
+  (let ((temp-file (make-symbol "temp-file"))
+	(temp-buffer (make-symbol "temp-buffer"))
+	(temp-results (make-symbol "temp-results")))
+    `(save-excursion
+       (let* ((,temp-file ,file)
+	      (default-major-mode 'fundamental-mode)
+	      (,temp-buffer
+	       (set-buffer
+		(get-buffer-create
+		 (generate-new-buffer-name " *nnheader temp*"))))
+	      ,temp-results)
+	 (unwind-protect
+	     (progn
+	       (setq ,temp-results (progn ,@forms))
+	       (cond
+		;; Don't save anything.
+		((null ,temp-file)
+		 ,temp-results)
+		;; Return the buffer contents.
+		((eq ,temp-file t)
+		 (set-buffer ,temp-buffer)
+		 (buffer-string))
+		;; Save a file.
+		(t
+		 (set-buffer ,temp-buffer)
+		 ;; Make sure the directory where this file is
+		 ;; to be saved exists.
+		 (when (not (file-directory-p
+			     (file-name-directory ,temp-file)))
+		   (make-directory (file-name-directory ,temp-file) t))
+		 ;; Save the file.
+		 (write-region (point-min) (point-max)
+			       ,temp-file nil 'nomesg)
+		 ,temp-results)))
+	   ;; Kill the buffer.
+	   (when (buffer-name ,temp-buffer)
+	     (kill-buffer ,temp-buffer)))))))
+
+(put 'nnheader-temp-write 'lisp-indent-function 1)
+(put 'nnheader-temp-write 'edebug-form-spec '(form body))
+
+(defvar jka-compr-compression-info-list)
+(defvar nnheader-numerical-files
+  (if (boundp 'jka-compr-compression-info-list)
+      (concat "\\([0-9]+\\)\\("
+	      (mapconcat (lambda (i) (aref i 0))
+			 jka-compr-compression-info-list "\\|")
+	      "\\)?")
+    "[0-9]+$")
+  "Regexp that match numerical files.")
+
+(defvar nnheader-numerical-short-files (concat "^" nnheader-numerical-files)
+  "Regexp that matches numerical file names.")
+
+(defvar nnheader-numerical-full-files (concat "/" nnheader-numerical-files)
+  "Regexp that matches numerical full file paths.")
+
+(defsubst nnheader-file-to-number (file)
+  "Take a file name and return the article number."
+  (if (not (boundp 'jka-compr-compression-info-list))
+      (string-to-int file)
+    (string-match nnheader-numerical-short-files file)
+    (string-to-int (match-string 0 file))))
+
+(defun nnheader-directory-files-safe (&rest args)
+  ;; It has been reported numerous times that `directory-files'
+  ;; fails with an alarming frequency on NFS mounted file systems.
+  ;; This function executes that function twice and returns
+  ;; the longest result.
+  (let ((first (apply 'directory-files args))
+	(second (apply 'directory-files args)))
+    (if (> (length first) (length second))
+	first
+      second)))
+
+(defun nnheader-directory-articles (dir)
+  "Return a list of all article files in a directory."
+  (mapcar 'nnheader-file-to-number
+	  (nnheader-directory-files-safe
+	   dir nil nnheader-numerical-short-files t)))
+
+(defun nnheader-article-to-file-alist (dir)
+  "Return an alist of article/file pairs in DIR."
+  (mapcar (lambda (file) (cons (nnheader-file-to-number file) file))
+	  (nnheader-directory-files-safe
+	   dir nil nnheader-numerical-short-files t)))
+
+(defun nnheader-fold-continuation-lines ()
+  "Fold continuation lines in the current buffer."
+  (nnheader-replace-regexp "\\(\r?\n[ \t]+\\)+" " "))
+
+(defun nnheader-translate-file-chars (file)
+  (if (null nnheader-file-name-translation-alist)
+      ;; No translation is necessary.
+      file
+    ;; We translate -- but only the file name.  We leave the directory
+    ;; alone.
+    (let* ((i 0)
+	   trans leaf path len)
+      (if (string-match "/[^/]+\\'" file)
+	  ;; This is needed on NT's and stuff.
+	  (setq leaf (substring file (1+ (match-beginning 0)))
+		path (substring file 0 (1+ (match-beginning 0))))
+	;; Fall back on this.
+	(setq leaf (file-name-nondirectory file)
+	      path (file-name-directory file)))
+      (setq len (length leaf))
+      (while (< i len)
+	(when (setq trans (cdr (assq (aref leaf i)
+				     nnheader-file-name-translation-alist)))
+	  (aset leaf i trans))
+	(incf i))
+      (concat path leaf))))
+
+(defun nnheader-report (backend &rest args)
+  "Report an error from the BACKEND.
+The first string in ARGS can be a format string."
+  (set (intern (format "%s-status-string" backend))
+       (if (< (length args) 2)
+	   (car args)
+	 (apply 'format args)))
+  nil)
+
+(defun nnheader-get-report (backend)
+  "Get the most recent report from BACKEND."
+  (condition-case ()
+      (message "%s" (symbol-value (intern (format "%s-status-string"
+						  backend))))
+    (error (message ""))))
+
+(defun nnheader-insert (format &rest args)
+  "Clear the communication buffer and insert FORMAT and ARGS into the buffer.
+If FORMAT isn't a format string, it and all ARGS will be inserted
+without formatting."
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (if (string-match "%" format)
+	(insert (apply 'format format args))
+      (apply 'insert format args))
+    t))
+
+(defun nnheader-replace-chars-in-string (string from to)
+  "Replace characters in STRING from FROM to TO."
+  (let ((string (substring string 0))	;Copy string.
+	(len (length string))
+	(idx 0))
+    ;; Replace all occurrences of FROM with TO.
+    (while (< idx len)
+      (when (= (aref string idx) from)
+	(aset string idx to))
+      (setq idx (1+ idx)))
+    string))
+
+(defun nnheader-file-to-group (file &optional top)
+  "Return a group name based on FILE and TOP."
+  (nnheader-replace-chars-in-string
+   (if (not top)
+       file
+     (condition-case ()
+	 (substring (expand-file-name file)
+		    (length
+		     (expand-file-name
+		      (file-name-as-directory top))))
+       (error "")))
+   ?/ ?.))
+
+(defun nnheader-message (level &rest args)
+  "Message if the Gnus backends are talkative."
+  (if (or (not (numberp gnus-verbose-backends))
+	  (<= level gnus-verbose-backends))
+      (apply 'message args)
+    (apply 'format args)))
+
+(defun nnheader-be-verbose (level)
+  "Return whether the backends should be verbose on LEVEL."
+  (or (not (numberp gnus-verbose-backends))
+      (<= level gnus-verbose-backends)))
+
+(defun nnheader-group-pathname (group dir &optional file)
+  "Make pathname for GROUP."
+  (concat
+   (let ((dir (file-name-as-directory (expand-file-name dir))))
+     ;; If this directory exists, we use it directly.
+     (if (file-directory-p (concat dir group))
+	 (concat dir group "/")
+       ;; If not, we translate dots into slashes.
+       (concat dir (nnheader-replace-chars-in-string group ?. ?/) "/")))
+   (cond ((null file) "")
+	 ((numberp file) (int-to-string file))
+	 (t file))))
+
+(defun nnheader-functionp (form)
+  "Return non-nil if FORM is funcallable."
+  (or (and (symbolp form) (fboundp form))
+      (and (listp form) (eq (car form) 'lambda))))
+
+(defun nnheader-concat (dir &rest files)
+  "Concat DIR as directory to FILE."
+  (apply 'concat (file-name-as-directory dir) files))
+
+(defun nnheader-ms-strip-cr ()
+  "Strip ^M from the end of all lines."
+  (save-excursion
+    (goto-char (point-min))
+    (while (re-search-forward "\r$" nil t)
+      (delete-backward-char 1))))
+
+(defun nnheader-file-size (file)
+  "Return the file size of FILE or 0."
+  (or (nth 7 (file-attributes file)) 0))
+
+(defun nnheader-find-etc-directory (package &optional file)
+  "Go through the path and find the \".../etc/PACKAGE\" directory.
+If FILE, find the \".../etc/PACKAGE\" file instead."
+  (let ((path load-path)
+	dir result)
+    ;; We try to find the dir by looking at the load path,
+    ;; stripping away the last component and adding "etc/".
+    (while path
+      (if (and (car path)
+	       (file-exists-p
+		(setq dir (concat
+			   (file-name-directory
+			    (directory-file-name (car path)))
+			   "etc/" package
+			   (if file "" "/"))))
+	       (or file (file-directory-p dir)))
+	  (setq result dir
+		path nil)
+	(setq path (cdr path))))
+    result))
+
+(defvar ange-ftp-path-format)
+(defvar efs-path-regexp)
+(defun nnheader-re-read-dir (path)
+  "Re-read directory PATH if PATH is on a remote system."
+  (if (and (fboundp 'efs-re-read-dir) (boundp 'efs-path-regexp))
+      (when (string-match efs-path-regexp path)
+	(efs-re-read-dir path))
+    (when (and (fboundp 'ange-ftp-re-read-dir) (boundp 'ange-ftp-path-format))
+      (when (string-match (car ange-ftp-path-format) path)
+	(ange-ftp-re-read-dir path)))))
+
+(defun nnheader-insert-file-contents (filename &optional visit beg end replace)
+  "Like `insert-file-contents', q.v., but only reads in the file.
+A buffer may be modified in several ways after reading into the buffer due
+to advanced Emacs features, such as file-name-handlers, format decoding,
+find-file-hooks, etc.
+  This function ensures that none of these modifications will take place."
+  (let ((format-alist nil)
+	(auto-mode-alist (nnheader-auto-mode-alist))
+	(default-major-mode 'fundamental-mode)
+        (after-insert-file-functions nil))
+    (insert-file-contents filename visit beg end replace)))
+
+(defun nnheader-find-file-noselect (&rest args)
+  (let ((format-alist nil)
+	(auto-mode-alist (nnheader-auto-mode-alist))
+	(default-major-mode 'fundamental-mode)
+	(enable-local-variables nil)
+        (after-insert-file-functions nil))
+    (apply 'find-file-noselect args)))
+
+(defun nnheader-auto-mode-alist ()
+  "Return an `auto-mode-alist' with only the .gz (etc) thingies."
+  (let ((alist auto-mode-alist)
+	out)
+    (while alist
+      (when (listp (cdar alist))
+	(push (car alist) out))
+      (pop alist))
+    (nreverse out)))
+
+(defun nnheader-directory-regular-files (dir)
+  "Return a list of all regular files in DIR."
+  (let ((files (directory-files dir t))
+	out)
+    (while files
+      (when (file-regular-p (car files))
+	(push (car files) out))
+      (pop files))
+    (nreverse out)))
+
+(defmacro nnheader-skeleton-replace (from &optional to regexp)
+  `(let ((new (generate-new-buffer " *nnheader replace*"))
+	 (cur (current-buffer))
+	 (start (point-min)))
+     (set-buffer new)
+     (buffer-disable-undo (current-buffer))
+     (set-buffer cur)
+     (goto-char (point-min))
+     (while (,(if regexp 're-search-forward 'search-forward)
+	     ,from nil t)
+       (insert-buffer-substring
+	cur start (prog1 (match-beginning 0) (set-buffer new)))
+       (goto-char (point-max))
+       ,(when to `(insert ,to))
+       (set-buffer cur)
+       (setq start (point)))
+     (insert-buffer-substring
+      cur start (prog1 (point-max) (set-buffer new)))
+     (copy-to-buffer cur (point-min) (point-max))
+     (kill-buffer (current-buffer))
+     (set-buffer cur)))
+
+(defun nnheader-replace-string (from to)
+  "Do a fast replacement of FROM to TO from point to point-max."
+  (nnheader-skeleton-replace from to))
+
+(defun nnheader-replace-regexp (from to)
+  "Do a fast regexp replacement of FROM to TO from point to point-max."
+  (nnheader-skeleton-replace from to t))
+
+(defun nnheader-strip-cr ()
+  "Strip all \r's from the current buffer."
+  (nnheader-skeleton-replace "\r"))
+
+(fset 'nnheader-run-at-time 'run-at-time)
+(fset 'nnheader-cancel-timer 'cancel-timer)
+(fset 'nnheader-cancel-function-timers 'cancel-function-timers)
+
+(when (string-match "XEmacs\\|Lucid" emacs-version)
+  (require 'nnheaderxm))
+
+(run-hooks 'nnheader-load-hook)
+
+(provide 'nnheader)
+
+;;; nnheader.el ends here

lisp/gnus/nnheaderxm.el

@@ -0,0 +1,156 @@
+;;; nnheaderxm.el --- making Gnus backends work under XEmacs
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(eval-and-compile
+  (autoload 'nnheader-insert-file-contents "nnheader"))
+
+(defun nnheader-xmas-run-at-time (time repeat function &rest args)
+  (start-itimer
+   "nnheader-run-at-time"
+   `(lambda ()
+      (,function ,@args))
+   time repeat))
+
+(defun nnheader-xmas-cancel-timer (timer)
+  (delete-itimer timer))
+
+(defun nnheader-xmas-cancel-function-timers (function)
+  )
+
+(defun nnheader-xmas-find-file-noselect (filename &optional nowarn rawfile)
+  "Read file FILENAME into a buffer and return the buffer.
+If a buffer exists visiting FILENAME, return that one, but
+verify that the file has not changed since visited or saved.
+The buffer is not selected, just returned to the caller."
+  (setq filename
+	(abbreviate-file-name
+	 (expand-file-name filename)))
+  (if (file-directory-p filename)
+      (if find-file-run-dired
+	  (dired-noselect filename)
+	(error "%s is a directory." filename))
+    (let* ((buf (get-file-buffer filename))
+	   (truename (abbreviate-file-name (file-truename filename)))
+	   (number (nthcdr 10 (file-attributes truename)))
+	   ;; Find any buffer for a file which has same truename.
+	   (other (and (not buf)
+		       (get-file-buffer filename)))
+	   error)
+      ;; Let user know if there is a buffer with the same truename.
+      (when other
+	(or nowarn
+	    (string-equal filename (buffer-file-name other))
+	    (message "%s and %s are the same file"
+		     filename (buffer-file-name other)))
+	;; Optionally also find that buffer.
+	(when (or (and (boundp 'find-file-existing-other-name)
+		       find-file-existing-other-name)
+		  find-file-visit-truename)
+	  (setq buf other)))
+      (if buf
+	  (or nowarn
+	      (verify-visited-file-modtime buf)
+	      (cond ((not (file-exists-p filename))
+		     (error "File %s no longer exists!" filename))
+		    ((yes-or-no-p
+		      (if (string= (file-name-nondirectory filename)
+				   (buffer-name buf))
+			  (format
+			   (if (buffer-modified-p buf)
+			       "File %s changed on disk.  Discard your edits? "
+			     "File %s changed on disk.  Reread from disk? ")
+			   (file-name-nondirectory filename))
+			(format
+			 (if (buffer-modified-p buf)
+			     "File %s changed on disk.  Discard your edits in %s? "
+			   "File %s changed on disk.  Reread from disk into %s? ")
+			 (file-name-nondirectory filename)
+			 (buffer-name buf))))
+		     (save-excursion
+		       (set-buffer buf)
+		       (revert-buffer t t)))))
+	(save-excursion
+;;; The truename stuff makes this obsolete.
+;;;	  (let* ((link-name (car (file-attributes filename)))
+;;;		 (linked-buf (and (stringp link-name)
+;;;				  (get-file-buffer link-name))))
+;;;	    (if (bufferp linked-buf)
+;;;		(message "Symbolic link to file in buffer %s"
+;;;			 (buffer-name linked-buf))))
+	  (setq buf (create-file-buffer filename))
+	  ;;	  (set-buffer-major-mode buf)
+	  (set-buffer buf)
+	  (erase-buffer)
+	  (if rawfile
+	      (condition-case ()
+		  (nnheader-insert-file-contents filename t)
+		(file-error
+		 ;; Unconditionally set error
+		 (setq error t)))
+	    (condition-case ()
+		(insert-file-contents filename t)
+	      (file-error
+	       ;; Run find-file-not-found-hooks until one returns non-nil.
+	       (or t			; (run-hook-with-args-until-success 'find-file-not-found-hooks)
+		   ;; If they fail too, set error.
+		   (setq error t)))))
+	  ;; Find the file's truename, and maybe use that as visited name.
+	  (setq buffer-file-truename truename)
+	  (setq buffer-file-number number)
+	  ;; On VMS, we may want to remember which directory in a search list
+	  ;; the file was found in.
+	  (and (eq system-type 'vax-vms)
+	       (let (logical)
+		 (when (string-match ":" (file-name-directory filename))
+		   (setq logical (substring (file-name-directory filename)
+					    0 (match-beginning 0))))
+		 (not (member logical find-file-not-true-dirname-list)))
+	       (setq buffer-file-name buffer-file-truename))
+	  (when find-file-visit-truename
+	    (setq buffer-file-name
+		  (setq filename
+			(expand-file-name buffer-file-truename))))
+	  ;; Set buffer's default directory to that of the file.
+	  (setq default-directory (file-name-directory filename))
+	  ;; Turn off backup files for certain file names.  Since
+	  ;; this is a permanent local, the major mode won't eliminate it.
+	  (when (not (funcall backup-enable-predicate buffer-file-name))
+	    (make-local-variable 'backup-inhibited)
+	    (setq backup-inhibited t))
+	  (if rawfile
+	      nil
+	    (after-find-file error (not nowarn)))))
+      buf)))
+
+(fset 'nnheader-run-at-time 'nnheader-xmas-run-at-time)
+(fset 'nnheader-cancel-timer 'nnheader-xmas-cancel-timer)
+(fset 'nnheader-cancel-function-timers 'nnheader-xmas-cancel-function-timers)
+(fset 'nnheader-find-file-noselect 'nnheader-xmas-find-file-noselect)
+
+(provide 'nnheaderxm)
+
+;;; nnheaderxm.el ends here.

lisp/gnus/nnkiboze.el

@@ -0,0 +1,349 @@
+;;; nnkiboze.el --- select virtual news access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; The other access methods (nntp, nnspool, etc) are general news
+;; access methods.  This module relies on Gnus and can't be used
+;; separately.
+
+;;; Code:
+
+(require 'nntp)
+(require 'nnheader)
+(require 'gnus)
+(require 'gnus-score)
+(require 'nnoo)
+(eval-when-compile (require 'cl))
+
+(nnoo-declare nnkiboze)
+(defvoo nnkiboze-directory (nnheader-concat gnus-directory "kiboze/")
+  "nnkiboze will put its files in this directory.")
+
+(defvoo nnkiboze-level 9
+  "The maximum level to be searched for articles.")
+
+(defvoo nnkiboze-remove-read-articles t
+  "If non-nil, nnkiboze will remove read articles from the kiboze group.")
+
+(defvoo nnkiboze-ephemeral nil
+  "If non-nil, don't store any data anywhere.")
+
+(defvoo nnkiboze-scores nil
+  "Score rules for generating the nnkiboze group.")
+
+(defvoo nnkiboze-regexp nil
+  "Regexp for matching component groups.")
+
+
+
+(defconst nnkiboze-version "nnkiboze 1.0")
+
+(defvoo nnkiboze-current-group nil)
+(defvoo nnkiboze-status-string "")
+
+(defvoo nnkiboze-headers nil)
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nnkiboze)
+
+(deffoo nnkiboze-retrieve-headers (articles &optional group server fetch-old)
+  (nnkiboze-possibly-change-group group)
+  (unless gnus-nov-is-evil
+    (if (stringp (car articles))
+	'headers
+      (let ((nov (nnkiboze-nov-file-name)))
+	(when (file-exists-p nov)
+	  (save-excursion
+	    (set-buffer nntp-server-buffer)
+	    (erase-buffer)
+	    (nnheader-insert-file-contents nov)
+	    (nnheader-nov-delete-outside-range
+	     (car articles) (car (last articles)))
+	    'nov))))))
+
+(deffoo nnkiboze-request-article (article &optional newsgroup server buffer)
+  (nnkiboze-possibly-change-group newsgroup)
+  (if (not (numberp article))
+      ;; This is a real kludge.  It might not work at times, but it
+      ;; does no harm I think.  The only alternative is to offer no
+      ;; article fetching by message-id at all.
+      (nntp-request-article article newsgroup gnus-nntp-server buffer)
+    (let* ((header (gnus-summary-article-header article))
+	   (xref (mail-header-xref header)))
+      (unless xref
+	(error "nnkiboze: No xref"))
+      (unless (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref)
+	(error "nnkiboze: Malformed xref"))
+      (gnus-request-article (string-to-int (match-string 2 xref))
+			    (match-string 1 xref)
+			    buffer))))
+
+(deffoo nnkiboze-request-scan (&optional group server)
+  (nnkiboze-generate-group (concat "nnkiboze:" group)))
+
+(deffoo nnkiboze-request-group (group &optional server dont-check)
+  "Make GROUP the current newsgroup."
+  (nnkiboze-possibly-change-group group)
+  (if dont-check
+      t
+    (let ((nov-file (nnkiboze-nov-file-name))
+	  beg end total)
+      (save-excursion
+	(set-buffer nntp-server-buffer)
+	(erase-buffer)
+	(if (not (file-exists-p nov-file))
+	    (nnheader-report 'nnkiboze "Can't select group %s" group)
+	  (nnheader-insert-file-contents nov-file)
+	  (if (zerop (buffer-size))
+	      (nnheader-insert "211 0 0 0 %s\n" group)
+	    (goto-char (point-min))
+	    (when (looking-at "[0-9]+")
+	      (setq beg (read (current-buffer))))
+	    (goto-char (point-max))
+	    (when (re-search-backward "^[0-9]" nil t)
+	      (setq end (read (current-buffer))))
+	    (setq total (count-lines (point-min) (point-max)))
+	    (nnheader-insert "211 %d %d %d %s\n" total beg end group)))))))
+
+(deffoo nnkiboze-close-group (group &optional server)
+  (nnkiboze-possibly-change-group group)
+  ;; Remove NOV lines of articles that are marked as read.
+  (when (and (file-exists-p (nnkiboze-nov-file-name))
+	     nnkiboze-remove-read-articles)
+    (nnheader-temp-write (nnkiboze-nov-file-name)
+      (let ((cur (current-buffer)))
+	(nnheader-insert-file-contents (nnkiboze-nov-file-name))
+	(goto-char (point-min))
+	(while (not (eobp))
+	  (if (not (gnus-article-read-p (read cur)))
+	      (forward-line 1)
+	    (gnus-delete-line))))))
+  (setq nnkiboze-current-group nil))
+
+(deffoo nnkiboze-open-server (server &optional defs)
+  (unless (assq 'nnkiboze-regexp defs)
+    (push `(nnkiboze-regexp ,server)
+	  defs))
+  (nnoo-change-server 'nnkiboze server defs))
+
+(deffoo nnkiboze-request-delete-group (group &optional force server)
+  (nnkiboze-possibly-change-group group)
+  (when force
+     (let ((files (list (nnkiboze-nov-file-name)
+			(concat nnkiboze-directory group ".newsrc")
+			(nnkiboze-score-file group))))
+       (while files
+	 (and (file-exists-p (car files))
+	      (file-writable-p (car files))
+	      (delete-file (car files)))
+	 (setq files (cdr files)))))
+  (setq nnkiboze-current-group nil))
+
+(nnoo-define-skeleton nnkiboze)
+
+
+;;; Internal functions.
+
+(defun nnkiboze-possibly-change-group (group)
+  (setq nnkiboze-current-group group))
+
+(defun nnkiboze-prefixed-name (group)
+  (gnus-group-prefixed-name group '(nnkiboze "")))
+
+;;;###autoload
+(defun nnkiboze-generate-groups ()
+  "Usage: emacs -batch -l nnkiboze -f nnkiboze-generate-groups
+Finds out what articles are to be part of the nnkiboze groups."
+  (interactive)
+  (let ((nnmail-spool-file nil)
+	(gnus-use-dribble-file nil)
+	(gnus-read-active-file t)
+	(gnus-expert-user t))
+    (gnus))
+  (let* ((gnus-newsrc-alist (gnus-copy-sequence gnus-newsrc-alist))
+	 (newsrc (cdr gnus-newsrc-alist))
+	 gnus-newsrc-hashtb info)
+    (gnus-make-hashtable-from-newsrc-alist)
+    ;; We have copied all the newsrc alist info over to local copies
+    ;; so that we can mess all we want with these lists.
+    (while (setq info (pop newsrc))
+      (when (string-match "nnkiboze" (gnus-info-group info))
+	;; For each kiboze group, we call this function to generate
+	;; it.
+	(nnkiboze-generate-group (gnus-info-group info))))))
+
+(defun nnkiboze-score-file (group)
+  (list (expand-file-name
+	 (concat (file-name-as-directory gnus-kill-files-directory)
+		 (nnheader-translate-file-chars
+		  (concat (nnkiboze-prefixed-name nnkiboze-current-group)
+			  "." gnus-score-file-suffix))))))
+
+(defun nnkiboze-generate-group (group)
+  (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
+	 (newsrc-file (concat nnkiboze-directory group ".newsrc"))
+	 (nov-file (concat nnkiboze-directory group ".nov"))
+	 method nnkiboze-newsrc gname newsrc active
+	 ginfo lowest glevel orig-info nov-buffer
+	 ;; Bind various things to nil to make group entry faster.
+	 (gnus-expert-user t)
+	 (gnus-large-newsgroup nil)
+	 (gnus-score-find-score-files-function 'nnkiboze-score-file)
+	 (gnus-verbose (min gnus-verbose 3))
+ 	 gnus-select-group-hook gnus-summary-prepare-hook
+	 gnus-thread-sort-functions gnus-show-threads
+	 gnus-visual gnus-suppress-duplicates)
+    (unless info
+      (error "No such group: %s" group))
+    ;; Load the kiboze newsrc file for this group.
+    (when (file-exists-p newsrc-file)
+      (load newsrc-file))
+    (nnheader-temp-write nov-file
+      (when (file-exists-p nov-file)
+	(insert-file-contents nov-file))
+      (setq nov-buffer (current-buffer))
+      ;; Go through the active hashtb and add new all groups that match the
+      ;; kiboze regexp.
+      (mapatoms
+       (lambda (group)
+	 (and (string-match nnkiboze-regexp
+			    (setq gname (symbol-name group))) ; Match
+	      (not (assoc gname nnkiboze-newsrc)) ; It isn't registered
+	      (numberp (car (symbol-value group))) ; It is active
+	      (or (> nnkiboze-level 7)
+		  (and (setq glevel (nth 1 (nth 2 (gnus-gethash
+						   gname gnus-newsrc-hashtb))))
+		       (>= nnkiboze-level glevel)))
+	      (not (string-match "^nnkiboze:" gname)) ; Exclude kibozes
+	      (push (cons gname (1- (car (symbol-value group))))
+		    nnkiboze-newsrc)))
+       gnus-active-hashtb)
+      ;; `newsrc' is set to the list of groups that possibly are
+      ;; component groups to this kiboze group.  This list has elements
+      ;; on the form `(GROUP . NUMBER)', where NUMBER is the highest
+      ;; number that has been kibozed in GROUP in this kiboze group.
+      (setq newsrc nnkiboze-newsrc)
+      (while newsrc
+	(if (not (setq active (gnus-gethash
+			       (caar newsrc) gnus-active-hashtb)))
+	    ;; This group isn't active after all, so we remove it from
+	    ;; the list of component groups.
+	    (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
+	  (setq lowest (cdar newsrc))
+	  ;; Ok, we have a valid component group, so we jump to it.
+	  (switch-to-buffer gnus-group-buffer)
+	  (gnus-group-jump-to-group (caar newsrc))
+	  (gnus-message 3 "nnkiboze: Checking %s..." (caar newsrc))
+	  (setq ginfo (gnus-get-info (gnus-group-group-name))
+		orig-info (gnus-copy-sequence ginfo))
+	  (unwind-protect
+	      (progn
+		;; We set all list of article marks to nil.  Since we operate
+		;; on copies of the real lists, we can destroy anything we
+		;; want here.
+		(when (nth 3 ginfo)
+		  (setcar (nthcdr 3 ginfo) nil))
+		;; We set the list of read articles to be what we expect for
+		;; this kiboze group -- either nil or `(1 . LOWEST)'.
+		(when ginfo
+		  (setcar (nthcdr 2 ginfo)
+			  (and (not (= lowest 1)) (cons 1 lowest))))
+		(when (and (or (not ginfo)
+			       (> (length (gnus-list-of-unread-articles
+					   (car ginfo)))
+				  0))
+			   (progn
+			     (gnus-group-select-group nil)
+			     (eq major-mode 'gnus-summary-mode)))
+		  ;; We are now in the group where we want to be.
+		  (setq method (gnus-find-method-for-group
+				gnus-newsgroup-name))
+		  (when (eq method gnus-select-method)
+		    (setq method nil))
+		  ;; We go through the list of scored articles.
+		  (while gnus-newsgroup-scored
+		    (when (> (caar gnus-newsgroup-scored) lowest)
+		      ;; If it has a good score, then we enter this article
+		      ;; into the kiboze group.
+		      (nnkiboze-enter-nov
+		       nov-buffer
+		       (gnus-summary-article-header
+			(caar gnus-newsgroup-scored))
+		       gnus-newsgroup-name))
+		    (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
+		  ;; That's it.  We exit this group.
+		  (gnus-summary-exit-no-update)))
+	    ;; Restore the proper info.
+	    (when ginfo
+	      (setcdr ginfo (cdr orig-info)))))
+	(setcdr (car newsrc) (car active))
+	(gnus-message 3 "nnkiboze: Checking %s...done" (caar newsrc))
+	(setq newsrc (cdr newsrc))))
+    ;; We save the kiboze newsrc for this group.
+    (nnheader-temp-write newsrc-file
+      (insert "(setq nnkiboze-newsrc '")
+      (gnus-prin1 nnkiboze-newsrc)
+      (insert ")\n"))
+    t))
+
+(defun nnkiboze-enter-nov (buffer header group)
+  (save-excursion
+    (set-buffer buffer)
+    (goto-char (point-max))
+    (let ((xref (mail-header-xref header))
+	  (prefix (gnus-group-real-prefix group))
+	  (oheader (copy-sequence header))
+	  (first t)
+	  article)
+      (if (zerop (forward-line -1))
+	  (progn
+	    (setq article (1+ (read (current-buffer))))
+	    (forward-line 1))
+	(setq article 1))
+      (mail-header-set-number oheader article)
+      (nnheader-insert-nov oheader)
+      (search-backward "\t" nil t 2)
+      (if (re-search-forward " [^ ]+:[0-9]+" nil t)
+	  (goto-char (match-beginning 0))
+	(forward-char 1))
+      ;; The first Xref has to be the group this article
+      ;; really came for - this is the article nnkiboze
+      ;; will request when it is asked for the article.
+      (insert group ":"
+	      (int-to-string (mail-header-number header)) " ")
+      (while (re-search-forward " [^ ]+:[0-9]+" nil t)
+	(goto-char (1+ (match-beginning 0)))
+	(insert prefix)))))
+
+(defun nnkiboze-nov-file-name ()
+  (concat (file-name-as-directory nnkiboze-directory)
+	  (nnheader-translate-file-chars
+	   (concat (nnkiboze-prefixed-name nnkiboze-current-group) ".nov"))))
+
+(provide 'nnkiboze)
+
+;;; nnkiboze.el ends here

lisp/gnus/nnmbox.el

@@ -0,0 +1,552 @@
+;;; nnmbox.el --- mail mbox access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; For an overview of what the interface functions do, please see the
+;; Gnus sources.
+
+;;; Code:
+
+(require 'nnheader)
+(require 'message)
+(require 'nnmail)
+(require 'nnoo)
+(eval-when-compile (require 'cl))
+
+(nnoo-declare nnmbox)
+
+(defvoo nnmbox-mbox-file (expand-file-name "~/mbox")
+  "The name of the mail box file in the user's home directory.")
+
+(defvoo nnmbox-active-file (expand-file-name "~/.mbox-active")
+  "The name of the active file for the mail box.")
+
+(defvoo nnmbox-get-new-mail t
+  "If non-nil, nnmbox will check the incoming mail file and split the mail.")
+
+(defvoo nnmbox-prepare-save-mail-hook nil
+  "Hook run narrowed to an article before saving.")
+
+
+
+(defconst nnmbox-version "nnmbox 1.0"
+  "nnmbox version.")
+
+(defvoo nnmbox-current-group nil
+  "Current nnmbox news group directory.")
+
+(defconst nnmbox-mbox-buffer nil)
+
+(defvoo nnmbox-status-string "")
+
+(defvoo nnmbox-group-alist nil)
+(defvoo nnmbox-active-timestamp nil)
+
+
+
+;;; Interface functions
+
+(nnoo-define-basics nnmbox)
+
+(deffoo nnmbox-retrieve-headers (sequence &optional newsgroup server fetch-old)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (let ((number (length sequence))
+	  (count 0)
+	  article art-string start stop)
+      (nnmbox-possibly-change-newsgroup newsgroup server)
+      (while sequence
+	(setq article (car sequence))
+	(setq art-string (nnmbox-article-string article))
+	(set-buffer nnmbox-mbox-buffer)
+	(when (or (search-forward art-string nil t)
+		  (progn (goto-char (point-min))
+			 (search-forward art-string nil t)))
+	  (setq start
+		(save-excursion
+		  (re-search-backward
+		   (concat "^" message-unix-mail-delimiter) nil t)
+		  (point)))
+	  (search-forward "\n\n" nil t)
+	  (setq stop (1- (point)))
+	  (set-buffer nntp-server-buffer)
+	  (insert (format "221 %d Article retrieved.\n" article))
+	  (insert-buffer-substring nnmbox-mbox-buffer start stop)
+	  (goto-char (point-max))
+	  (insert ".\n"))
+	(setq sequence (cdr sequence))
+	(setq count (1+ count))
+	(and (numberp nnmail-large-newsgroup)
+	     (> number nnmail-large-newsgroup)
+	     (zerop (% count 20))
+	     (nnheader-message 5 "nnmbox: Receiving headers... %d%%"
+			       (/ (* count 100) number))))
+
+      (and (numberp nnmail-large-newsgroup)
+	   (> number nnmail-large-newsgroup)
+	   (nnheader-message 5 "nnmbox: Receiving headers...done"))
+
+      (set-buffer nntp-server-buffer)
+      (nnheader-fold-continuation-lines)
+      'headers)))
+
+(deffoo nnmbox-open-server (server &optional defs)
+  (nnoo-change-server 'nnmbox server defs)
+  (nnmbox-create-mbox)
+  (cond
+   ((not (file-exists-p nnmbox-mbox-file))
+    (nnmbox-close-server)
+    (nnheader-report 'nnmbox "No such file: %s" nnmbox-mbox-file))
+   ((file-directory-p nnmbox-mbox-file)
+    (nnmbox-close-server)
+    (nnheader-report 'nnmbox "Not a regular file: %s" nnmbox-mbox-file))
+   (t
+    (nnheader-report 'nnmbox "Opened server %s using mbox %s" server
+		     nnmbox-mbox-file)
+    t)))
+
+(deffoo nnmbox-close-server (&optional server)
+  (when (and nnmbox-mbox-buffer
+	     (buffer-name nnmbox-mbox-buffer))
+    (kill-buffer nnmbox-mbox-buffer))
+  (nnoo-close-server 'nnmbox server)
+  t)
+
+(deffoo nnmbox-server-opened (&optional server)
+  (and (nnoo-current-server-p 'nnmbox server)
+       nnmbox-mbox-buffer
+       (buffer-name nnmbox-mbox-buffer)
+       nntp-server-buffer
+       (buffer-name nntp-server-buffer)))
+
+(deffoo nnmbox-request-article (article &optional newsgroup server buffer)
+  (nnmbox-possibly-change-newsgroup newsgroup server)
+  (save-excursion
+    (set-buffer nnmbox-mbox-buffer)
+    (goto-char (point-min))
+    (when (search-forward (nnmbox-article-string article) nil t)
+      (let (start stop)
+	(re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
+	(setq start (point))
+	(forward-line 1)
+	(or (and (re-search-forward
+		  (concat "^" message-unix-mail-delimiter) nil t)
+		 (forward-line -1))
+	    (goto-char (point-max)))
+	(setq stop (point))
+	(let ((nntp-server-buffer (or buffer nntp-server-buffer)))
+	  (set-buffer nntp-server-buffer)
+	  (erase-buffer)
+	  (insert-buffer-substring nnmbox-mbox-buffer start stop)
+	  (goto-char (point-min))
+	  (while (looking-at "From ")
+	    (delete-char 5)
+	    (insert "X-From-Line: ")
+	    (forward-line 1))
+	  (if (numberp article)
+	      (cons nnmbox-current-group article)
+	    (nnmbox-article-group-number)))))))
+
+(deffoo nnmbox-request-group (group &optional server dont-check)
+  (let ((active (cadr (assoc group nnmbox-group-alist))))
+    (cond
+     ((or (null active)
+	  (null (nnmbox-possibly-change-newsgroup group server)))
+      (nnheader-report 'nnmbox "No such group: %s" group))
+     (dont-check
+      (nnheader-report 'nnmbox "Selected group %s" group)
+      (nnheader-insert ""))
+     (t
+      (nnheader-report 'nnmbox "Selected group %s" group)
+      (nnheader-insert "211 %d %d %d %s\n"
+		       (1+ (- (cdr active) (car active)))
+		       (car active) (cdr active) group)))))
+
+(deffoo nnmbox-request-scan (&optional group server)
+  (nnmbox-possibly-change-newsgroup group server)
+  (nnmbox-read-mbox)
+  (nnmail-get-new-mail
+   'nnmbox
+   (lambda ()
+     (save-excursion
+       (set-buffer nnmbox-mbox-buffer)
+       (save-buffer)))
+   (file-name-directory nnmbox-mbox-file)
+   group
+   (lambda ()
+     (save-excursion
+       (let ((in-buf (current-buffer)))
+	 (set-buffer nnmbox-mbox-buffer)
+	 (goto-char (point-max))
+	 (insert-buffer-substring in-buf)))
+     (nnmail-save-active nnmbox-group-alist nnmbox-active-file))))
+
+(deffoo nnmbox-close-group (group &optional server)
+  t)
+
+(deffoo nnmbox-request-list (&optional server)
+  (save-excursion
+    (nnmail-find-file nnmbox-active-file)
+    (setq nnmbox-group-alist (nnmail-get-active))
+    t))
+
+(deffoo nnmbox-request-newgroups (date &optional server)
+  (nnmbox-request-list server))
+
+(deffoo nnmbox-request-list-newsgroups (&optional server)
+  (nnheader-report 'nnmbox "LIST NEWSGROUPS is not implemented."))
+
+(deffoo nnmbox-request-expire-articles
+  (articles newsgroup &optional server force)
+  (nnmbox-possibly-change-newsgroup newsgroup server)
+  (let* ((is-old t)
+	 rest)
+    (nnmail-activate 'nnmbox)
+
+    (save-excursion
+      (set-buffer nnmbox-mbox-buffer)
+      (while (and articles is-old)
+	(goto-char (point-min))
+	(when (search-forward (nnmbox-article-string (car articles)) nil t)
+	  (if (setq is-old
+		    (nnmail-expired-article-p
+		     newsgroup
+		     (buffer-substring
+		      (point) (progn (end-of-line) (point))) force))
+	      (progn
+		(nnheader-message 5 "Deleting article %d in %s..."
+				  (car articles) newsgroup)
+		(nnmbox-delete-mail))
+	    (push (car articles) rest)))
+	(setq articles (cdr articles)))
+      (save-buffer)
+      ;; Find the lowest active article in this group.
+      (let ((active (nth 1 (assoc newsgroup nnmbox-group-alist))))
+	(goto-char (point-min))
+	(while (and (not (search-forward
+			  (nnmbox-article-string (car active)) nil t))
+		    (<= (car active) (cdr active)))
+	  (setcar active (1+ (car active)))
+	  (goto-char (point-min))))
+      (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
+      (nconc rest articles))))
+
+(deffoo nnmbox-request-move-article
+  (article group server accept-form &optional last)
+  (let ((buf (get-buffer-create " *nnmbox move*"))
+	result)
+    (and
+     (nnmbox-request-article article group server)
+     (save-excursion
+       (set-buffer buf)
+       (buffer-disable-undo (current-buffer))
+       (erase-buffer)
+       (insert-buffer-substring nntp-server-buffer)
+       (goto-char (point-min))
+       (while (re-search-forward
+	       "^X-Gnus-Newsgroup:"
+	       (save-excursion (search-forward "\n\n" nil t) (point)) t)
+	 (delete-region (progn (beginning-of-line) (point))
+			(progn (forward-line 1) (point))))
+       (setq result (eval accept-form))
+       (kill-buffer buf)
+       result)
+     (save-excursion
+       (nnmbox-possibly-change-newsgroup group server)
+       (set-buffer nnmbox-mbox-buffer)
+       (goto-char (point-min))
+       (when (search-forward (nnmbox-article-string article) nil t)
+	 (nnmbox-delete-mail))
+       (and last (save-buffer))))
+    result))
+
+(deffoo nnmbox-request-accept-article (group &optional server last)
+  (nnmbox-possibly-change-newsgroup group server)
+  (nnmail-check-syntax)
+  (let ((buf (current-buffer))
+	result)
+    (goto-char (point-min))
+    ;; The From line may have been quoted by movemail.
+    (when (looking-at (concat ">" message-unix-mail-delimiter))
+      (delete-char 1))
+    (if (looking-at "X-From-Line: ")
+	(replace-match "From ")
+      (insert "From nobody " (current-time-string) "\n"))
+    (and
+     (nnmail-activate 'nnmbox)
+     (progn
+       (set-buffer buf)
+       (goto-char (point-min))
+       (search-forward "\n\n" nil t)
+       (forward-line -1)
+       (while (re-search-backward "^X-Gnus-Newsgroup: " nil t)
+	 (delete-region (point) (progn (forward-line 1) (point))))
+       (when nnmail-cache-accepted-message-ids
+	 (nnmail-cache-insert (nnmail-fetch-field "message-id")))
+       (setq result (if (stringp group)
+			(list (cons group (nnmbox-active-number group)))
+		      (nnmail-article-group 'nnmbox-active-number)))
+       (if (and (null result)
+		(yes-or-no-p "Moved to `junk' group; delete article? "))
+	   (setq result 'junk)
+	 (setq result (car (nnmbox-save-mail result)))))
+     (save-excursion
+       (set-buffer nnmbox-mbox-buffer)
+       (goto-char (point-max))
+       (insert-buffer-substring buf)
+       (when last
+	 (when nnmail-cache-accepted-message-ids
+	   (nnmail-cache-close))
+	 (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
+	 (save-buffer))))
+    result))
+
+(deffoo nnmbox-request-replace-article (article group buffer)
+  (nnmbox-possibly-change-newsgroup group)
+  (save-excursion
+    (set-buffer nnmbox-mbox-buffer)
+    (goto-char (point-min))
+    (if (not (search-forward (nnmbox-article-string article) nil t))
+	nil
+      (nnmbox-delete-mail t t)
+      (insert-buffer-substring buffer)
+      (save-buffer)
+      t)))
+
+(deffoo nnmbox-request-delete-group (group &optional force server)
+  (nnmbox-possibly-change-newsgroup group server)
+  ;; Delete all articles in GROUP.
+  (if (not force)
+      ()				; Don't delete the articles.
+    (save-excursion
+      (set-buffer nnmbox-mbox-buffer)
+      (goto-char (point-min))
+      ;; Delete all articles in this group.
+      (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
+	    found)
+	(while (search-forward ident nil t)
+	  (setq found t)
+	  (nnmbox-delete-mail))
+	(when found
+	  (save-buffer)))))
+  ;; Remove the group from all structures.
+  (setq nnmbox-group-alist
+	(delq (assoc group nnmbox-group-alist) nnmbox-group-alist)
+	nnmbox-current-group nil)
+  ;; Save the active file.
+  (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
+  t)
+
+(deffoo nnmbox-request-rename-group (group new-name &optional server)
+  (nnmbox-possibly-change-newsgroup group server)
+  (save-excursion
+    (set-buffer nnmbox-mbox-buffer)
+    (goto-char (point-min))
+    (let ((ident (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"))
+	  (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
+	  found)
+      (while (search-forward ident nil t)
+	(replace-match new-ident t t)
+	(setq found t))
+      (when found
+	(save-buffer))))
+  (let ((entry (assoc group nnmbox-group-alist)))
+    (when entry
+      (setcar entry new-name))
+    (setq nnmbox-current-group nil)
+    ;; Save the new group alist.
+    (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
+    t))
+
+
+;;; Internal functions.
+
+;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
+;; headers there are.  If LEAVE-DELIM, don't delete the Unix mbox
+;; delimiter line.
+(defun nnmbox-delete-mail (&optional force leave-delim)
+  ;; Delete the current X-Gnus-Newsgroup line.
+  (or force
+      (delete-region
+       (progn (beginning-of-line) (point))
+       (progn (forward-line 1) (point))))
+  ;; Beginning of the article.
+  (save-excursion
+    (save-restriction
+      (narrow-to-region
+       (save-excursion
+	 (re-search-backward (concat "^" message-unix-mail-delimiter) nil t)
+	 (if leave-delim (progn (forward-line 1) (point))
+	   (match-beginning 0)))
+       (progn
+	 (forward-line 1)
+	 (or (and (re-search-forward (concat "^" message-unix-mail-delimiter)
+				     nil t)
+		  (if (and (not (bobp)) leave-delim)
+		      (progn (forward-line -2) (point))
+		    (match-beginning 0)))
+	     (point-max))))
+      (goto-char (point-min))
+      ;; Only delete the article if no other groups owns it as well.
+      (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
+	(delete-region (point-min) (point-max))))))
+
+(defun nnmbox-possibly-change-newsgroup (newsgroup &optional server)
+  (when (and server
+	     (not (nnmbox-server-opened server)))
+    (nnmbox-open-server server))
+  (when (or (not nnmbox-mbox-buffer)
+	    (not (buffer-name nnmbox-mbox-buffer)))
+    (save-excursion
+      (set-buffer (setq nnmbox-mbox-buffer
+			(nnheader-find-file-noselect
+			 nnmbox-mbox-file nil 'raw)))
+      (buffer-disable-undo (current-buffer))))
+  (when (not nnmbox-group-alist)
+    (nnmail-activate 'nnmbox))
+  (if newsgroup
+      (when (assoc newsgroup nnmbox-group-alist)
+	(setq nnmbox-current-group newsgroup))
+    t))
+
+(defun nnmbox-article-string (article)
+  (if (numberp article)
+      (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
+	      (int-to-string article) " ")
+    (concat "\nMessage-ID: " article)))
+
+(defun nnmbox-article-group-number ()
+  (save-excursion
+    (goto-char (point-min))
+    (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
+			     nil t)
+      (cons (buffer-substring (match-beginning 1) (match-end 1))
+	    (string-to-int
+	     (buffer-substring (match-beginning 2) (match-end 2)))))))
+
+(defun nnmbox-save-mail (group-art)
+  "Called narrowed to an article."
+  (let ((delim (concat "^" message-unix-mail-delimiter)))
+    (goto-char (point-min))
+    ;; This might come from somewhere else.
+    (unless (looking-at delim)
+      (insert "From nobody " (current-time-string) "\n")
+      (goto-char (point-min)))
+    ;; Quote all "From " lines in the article.
+    (forward-line 1)
+    (while (re-search-forward delim nil t)
+      (beginning-of-line)
+      (insert "> "))
+    (nnmail-insert-lines)
+    (nnmail-insert-xref group-art)
+    (nnmbox-insert-newsgroup-line group-art)
+    (run-hooks 'nnmail-prepare-save-mail-hook)
+    (run-hooks 'nnmbox-prepare-save-mail-hook)
+    group-art))
+
+(defun nnmbox-insert-newsgroup-line (group-art)
+  (save-excursion
+    (goto-char (point-min))
+    (when (search-forward "\n\n" nil t)
+      (forward-char -1)
+      (while group-art
+	(insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
+			(caar group-art) (cdar group-art)
+			(current-time-string)))
+	(setq group-art (cdr group-art))))
+    t))
+
+(defun nnmbox-active-number (group)
+  ;; Find the next article number in GROUP.
+  (let ((active (cadr (assoc group nnmbox-group-alist))))
+    (if active
+	(setcdr active (1+ (cdr active)))
+      ;; This group is new, so we create a new entry for it.
+      ;; This might be a bit naughty... creating groups on the drop of
+      ;; a hat, but I don't know...
+      (push (list group (setq active (cons 1 1)))
+	    nnmbox-group-alist))
+    (cdr active)))
+
+(defun nnmbox-create-mbox ()
+  (when (not (file-exists-p nnmbox-mbox-file))
+    (nnmail-write-region 1 1 nnmbox-mbox-file t 'nomesg)))
+
+(defun nnmbox-read-mbox ()
+  (nnmail-activate 'nnmbox)
+  (nnmbox-create-mbox)
+  (if (and nnmbox-mbox-buffer
+	   (buffer-name nnmbox-mbox-buffer)
+	   (save-excursion
+	     (set-buffer nnmbox-mbox-buffer)
+	     (= (buffer-size) (nnheader-file-size nnmbox-mbox-file))))
+      ()
+    (save-excursion
+      (let ((delim (concat "^" message-unix-mail-delimiter))
+	    (alist nnmbox-group-alist)
+	    start end number)
+	(set-buffer (setq nnmbox-mbox-buffer
+			  (nnheader-find-file-noselect
+			   nnmbox-mbox-file nil 'raw)))
+	(buffer-disable-undo (current-buffer))
+
+	;; Go through the group alist and compare against
+	;; the mbox file.
+	(while alist
+	  (goto-char (point-max))
+	  (when (and (re-search-backward
+		      (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
+			      (caar alist)) nil t)
+		     (>= (setq number
+			       (string-to-number
+				(buffer-substring
+				 (match-beginning 1) (match-end 1))))
+			 (cdadar alist)))
+	    (setcdr (cadar alist) (1+ number)))
+	  (setq alist (cdr alist)))
+
+	(goto-char (point-min))
+	(while (re-search-forward delim nil t)
+	  (setq start (match-beginning 0))
+	  (when (not (search-forward "\nX-Gnus-Newsgroup: "
+				     (save-excursion
+				       (setq end
+					     (or
+					      (and
+					       (re-search-forward delim nil t)
+					       (match-beginning 0))
+					      (point-max))))
+				     t))
+	    (save-excursion
+	      (save-restriction
+		(narrow-to-region start end)
+		(nnmbox-save-mail
+		 (nnmail-article-group 'nnmbox-active-number)))))
+	  (goto-char end))))))
+
+(provide 'nnmbox)
+
+;;; nnmbox.el ends here

lisp/gnus/nnmh.el

@@ -0,0 +1,547 @@
+;;; nnmh.el --- mhspool access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
+;; For an overview of what the interface functions do, please see the
+;; Gnus sources.
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nnmail)
+(require 'gnus-start)
+(require 'nnoo)
+(require 'cl)
+
+(nnoo-declare nnmh)
+
+(defvoo nnmh-directory message-directory
+  "*Mail spool directory.")
+
+(defvoo nnmh-get-new-mail t
+  "*If non-nil, nnmh will check the incoming mail file and split the mail.")
+
+(defvoo nnmh-prepare-save-mail-hook nil
+  "*Hook run narrowed to an article before saving.")
+
+(defvoo nnmh-be-safe nil
+  "*If non-nil, nnmh will check all articles to make sure whether they are new or not.")
+
+
+
+(defconst nnmh-version "nnmh 1.0"
+  "nnmh version.")
+
+(defvoo nnmh-current-directory nil
+  "Current news group directory.")
+
+(defvoo nnmh-status-string "")
+(defvoo nnmh-group-alist nil)
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nnmh)
+
+(deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (let* ((file nil)
+	   (number (length articles))
+	   (large (and (numberp nnmail-large-newsgroup)
+		       (> number nnmail-large-newsgroup)))
+	   (count 0)
+	   beg article)
+      (nnmh-possibly-change-directory newsgroup server)
+      ;; We don't support fetching by Message-ID.
+      (if (stringp (car articles))
+	  'headers
+	(while articles
+	  (when (and (file-exists-p
+		      (setq file (concat (file-name-as-directory
+					  nnmh-current-directory)
+					 (int-to-string
+					  (setq article (pop articles))))))
+		     (not (file-directory-p file)))
+	    (insert (format "221 %d Article retrieved.\n" article))
+	    (setq beg (point))
+	    (nnheader-insert-head file)
+	    (goto-char beg)
+	    (if (search-forward "\n\n" nil t)
+		(forward-char -1)
+	      (goto-char (point-max))
+	      (insert "\n\n"))
+	    (insert ".\n")
+	    (delete-region (point) (point-max)))
+	  (setq count (1+ count))
+
+	  (and large
+	       (zerop (% count 20))
+	       (message "nnmh: Receiving headers... %d%%"
+			(/ (* count 100) number))))
+
+	(when large
+	  (message "nnmh: Receiving headers...done"))
+
+	(nnheader-fold-continuation-lines)
+	'headers))))
+
+(deffoo nnmh-open-server (server &optional defs)
+  (nnoo-change-server 'nnmh server defs)
+  (when (not (file-exists-p nnmh-directory))
+    (condition-case ()
+	(make-directory nnmh-directory t)
+      (error t)))
+  (cond
+   ((not (file-exists-p nnmh-directory))
+    (nnmh-close-server)
+    (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory))
+   ((not (file-directory-p (file-truename nnmh-directory)))
+    (nnmh-close-server)
+    (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))
+   (t
+    (nnheader-report 'nnmh "Opened server %s using directory %s"
+		     server nnmh-directory)
+    t)))
+
+(deffoo nnmh-request-article (id &optional newsgroup server buffer)
+  (nnmh-possibly-change-directory newsgroup server)
+  (let ((file (if (stringp id)
+		  nil
+		(concat nnmh-current-directory (int-to-string id))))
+	(nntp-server-buffer (or buffer nntp-server-buffer)))
+    (and (stringp file)
+	 (file-exists-p file)
+	 (not (file-directory-p file))
+	 (save-excursion (nnmail-find-file file))
+	 (string-to-int (file-name-nondirectory file)))))
+
+(deffoo nnmh-request-group (group &optional server dont-check)
+  (let ((pathname (nnmail-group-pathname group nnmh-directory))
+	dir)
+    (cond
+     ((not (file-directory-p pathname))
+      (nnheader-report
+       'nnmh "Can't select group (no such directory): %s" group))
+     (t
+      (setq nnmh-current-directory pathname)
+      (and nnmh-get-new-mail
+	   nnmh-be-safe
+	   (nnmh-update-gnus-unreads group))
+      (cond
+       (dont-check
+	(nnheader-report 'nnmh "Selected group %s" group)
+	t)
+       (t
+	;; Re-scan the directory if it's on a foreign system.
+	(nnheader-re-read-dir pathname)
+	(setq dir
+	      (sort
+	       (mapcar (lambda (name) (string-to-int name))
+		       (directory-files pathname nil "^[0-9]+$" t))
+	       '<))
+	  (cond
+	   (dir
+	    (nnheader-report 'nnmh "Selected group %s" group)
+	    (nnheader-insert
+	     "211 %d %d %d %s\n" (length dir) (car dir)
+	     (progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
+	     group))
+	   (t
+	    (nnheader-report 'nnmh "Empty group %s" group)
+	    (nnheader-insert (format "211 0 1 0 %s\n" group))))))))))
+
+(deffoo nnmh-request-scan (&optional group server)
+  (nnmail-get-new-mail 'nnmh nil nnmh-directory group))
+
+(deffoo nnmh-request-list (&optional server dir)
+  (nnheader-insert "")
+  (let ((nnmh-toplev
+	 (or dir (file-truename (file-name-as-directory nnmh-directory)))))
+    (nnmh-request-list-1 nnmh-toplev))
+  (setq nnmh-group-alist (nnmail-get-active))
+  t)
+
+(defvar nnmh-toplev)
+(defun nnmh-request-list-1 (dir)
+  (setq dir (expand-file-name dir))
+  ;; Recurse down all directories.
+  (let ((dirs (and (file-readable-p dir)
+		   (> (nth 1 (file-attributes (file-chase-links dir))) 2)
+		   (directory-files dir t nil t)))
+	dir)
+    ;; Recurse down directories.
+    (while (setq dir (pop dirs))
+      (when (and (not (member (file-name-nondirectory dir) '("." "..")))
+		 (file-directory-p dir)
+		 (file-readable-p dir))
+	(nnmh-request-list-1 dir))))
+  ;; For each directory, generate an active file line.
+  (unless (string= (expand-file-name nnmh-toplev) dir)
+    (let ((files (mapcar
+		  (lambda (name) (string-to-int name))
+		  (directory-files dir nil "^[0-9]+$" t))))
+      (when files
+	(save-excursion
+	  (set-buffer nntp-server-buffer)
+	  (goto-char (point-max))
+	  (insert
+	   (format
+	    "%s %d %d y\n"
+	    (progn
+	      (string-match
+	       (regexp-quote
+		(file-truename (file-name-as-directory
+				(expand-file-name nnmh-toplev))))
+	       dir)
+	      (nnheader-replace-chars-in-string
+	       (substring dir (match-end 0)) ?/ ?.))
+	    (apply 'max files)
+	    (apply 'min files)))))))
+  t)
+
+(deffoo nnmh-request-newgroups (date &optional server)
+  (nnmh-request-list server))
+
+(deffoo nnmh-request-expire-articles (articles newsgroup
+					       &optional server force)
+  (nnmh-possibly-change-directory newsgroup server)
+  (let* ((active-articles
+	  (mapcar
+	   (function
+	    (lambda (name)
+	      (string-to-int name)))
+	   (directory-files nnmh-current-directory nil "^[0-9]+$" t)))
+	 (is-old t)
+	 article rest mod-time)
+    (nnmail-activate 'nnmh)
+
+    (while (and articles is-old)
+      (setq article (concat nnmh-current-directory
+			    (int-to-string (car articles))))
+      (when (setq mod-time (nth 5 (file-attributes article)))
+	(if (and (nnmh-deletable-article-p newsgroup (car articles))
+		 (setq is-old
+		       (nnmail-expired-article-p newsgroup mod-time force)))
+	    (progn
+	      (nnheader-message 5 "Deleting article %s in %s..."
+				article newsgroup)
+	      (condition-case ()
+		  (funcall nnmail-delete-file-function article)
+		(file-error
+		 (nnheader-message 1 "Couldn't delete article %s in %s"
+				   article newsgroup)
+		 (push (car articles) rest))))
+	  (push (car articles) rest)))
+      (setq articles (cdr articles)))
+    (message "")
+    (nconc rest articles)))
+
+(deffoo nnmh-close-group (group &optional server)
+  t)
+
+(deffoo nnmh-request-move-article
+  (article group server accept-form &optional last)
+  (let ((buf (get-buffer-create " *nnmh move*"))
+	result)
+    (and
+     (nnmh-deletable-article-p group article)
+     (nnmh-request-article article group server)
+     (save-excursion
+       (set-buffer buf)
+       (erase-buffer)
+       (insert-buffer-substring nntp-server-buffer)
+       (setq result (eval accept-form))
+       (kill-buffer (current-buffer))
+       result)
+     (progn
+       (nnmh-possibly-change-directory group server)
+       (condition-case ()
+	   (funcall nnmail-delete-file-function
+		    (concat nnmh-current-directory (int-to-string article)))
+	 (file-error nil))))
+    result))
+
+(deffoo nnmh-request-accept-article (group &optional server last noinsert)
+  (nnmh-possibly-change-directory group server)
+  (nnmail-check-syntax)
+  (when nnmail-cache-accepted-message-ids
+    (nnmail-cache-insert (nnmail-fetch-field "message-id")))
+  (prog1
+      (if (stringp group)
+	  (and
+	   (nnmail-activate 'nnmh)
+	   (car (nnmh-save-mail
+		 (list (cons group (nnmh-active-number group)))
+		 noinsert)))
+	(and
+	 (nnmail-activate 'nnmh)
+	 (let ((res (nnmail-article-group 'nnmh-active-number)))
+	   (if (and (null res)
+		    (yes-or-no-p "Moved to `junk' group; delete article? "))
+	       'junk
+	     (car (nnmh-save-mail res noinsert))))))
+    (when (and last nnmail-cache-accepted-message-ids)
+      (nnmail-cache-close))))
+
+(deffoo nnmh-request-replace-article (article group buffer)
+  (nnmh-possibly-change-directory group)
+  (save-excursion
+    (set-buffer buffer)
+    (nnmh-possibly-create-directory group)
+    (ignore-errors
+      (nnmail-write-region
+       (point-min) (point-max)
+       (concat nnmh-current-directory (int-to-string article))
+       nil (if (nnheader-be-verbose 5) nil 'nomesg))
+      t)))
+
+(deffoo nnmh-request-create-group (group &optional server args)
+  (nnmail-activate 'nnmh)
+  (unless (assoc group nnmh-group-alist)
+    (let (active)
+      (push (list group (setq active (cons 1 0)))
+	    nnmh-group-alist)
+      (nnmh-possibly-create-directory group)
+      (nnmh-possibly-change-directory group server)
+      (let ((articles (mapcar
+		       (lambda (file)
+			 (string-to-int file))
+		       (directory-files
+			nnmh-current-directory nil "^[0-9]+$"))))
+	(when articles
+	  (setcar active (apply 'min articles))
+	  (setcdr active (apply 'max articles))))))
+  t)
+
+(deffoo nnmh-request-delete-group (group &optional force server)
+  (nnmh-possibly-change-directory group server)
+  ;; Delete all articles in GROUP.
+  (if (not force)
+      ()				; Don't delete the articles.
+    (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$")))
+      (while articles
+	(when (file-writable-p (car articles))
+	  (nnheader-message 5 "Deleting article %s in %s..."
+			    (car articles) group)
+	  (funcall nnmail-delete-file-function (car articles)))
+	(setq articles (cdr articles))))
+    ;; Try to delete the directory itself.
+    (ignore-errors
+      (delete-directory nnmh-current-directory)))
+  ;; Remove the group from all structures.
+  (setq nnmh-group-alist
+	(delq (assoc group nnmh-group-alist) nnmh-group-alist)
+	nnmh-current-directory nil)
+  t)
+
+(deffoo nnmh-request-rename-group (group new-name &optional server)
+  (nnmh-possibly-change-directory group server)
+  (let ((new-dir (nnmail-group-pathname new-name nnmh-directory))
+	(old-dir (nnmail-group-pathname group nnmh-directory)))
+    (when (ignore-errors
+	    (make-directory new-dir t)
+	    t)
+      ;; We move the articles file by file instead of renaming
+      ;; the directory -- there may be subgroups in this group.
+      ;; One might be more clever, I guess.
+      (let ((files (nnheader-article-to-file-alist old-dir)))
+	(while files
+	  (rename-file
+	   (concat old-dir (cdar files))
+	   (concat new-dir (cdar files)))
+	  (pop files)))
+      (when (<= (length (directory-files old-dir)) 2)
+	(ignore-errors
+	  (delete-directory old-dir)))
+      ;; That went ok, so we change the internal structures.
+      (let ((entry (assoc group nnmh-group-alist)))
+	(when entry
+	  (setcar entry new-name))
+	(setq nnmh-current-directory nil)
+	t))))
+
+(nnoo-define-skeleton nnmh)
+
+
+;;; Internal functions.
+
+(defun nnmh-possibly-change-directory (newsgroup &optional server)
+  (when (and server
+	     (not (nnmh-server-opened server)))
+    (nnmh-open-server server))
+  (when newsgroup
+    (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory)))
+      (if (file-directory-p pathname)
+	  (setq nnmh-current-directory pathname)
+	(error "No such newsgroup: %s" newsgroup)))))
+
+(defun nnmh-possibly-create-directory (group)
+  (let (dir dirs)
+    (setq dir (nnmail-group-pathname group nnmh-directory))
+    (while (not (file-directory-p dir))
+      (push dir dirs)
+      (setq dir (file-name-directory (directory-file-name dir))))
+    (while dirs
+      (when (make-directory (directory-file-name (car dirs)))
+	(error "Could not create directory %s" (car dirs)))
+      (nnheader-message 5 "Creating mail directory %s" (car dirs))
+      (setq dirs (cdr dirs)))))
+
+(defun nnmh-save-mail (group-art &optional noinsert)
+  "Called narrowed to an article."
+  (unless noinsert
+    (nnmail-insert-lines)
+    (nnmail-insert-xref group-art))
+  (run-hooks 'nnmail-prepare-save-mail-hook)
+  (run-hooks 'nnmh-prepare-save-mail-hook)
+  (goto-char (point-min))
+  (while (looking-at "From ")
+    (replace-match "X-From-Line: ")
+    (forward-line 1))
+  ;; We save the article in all the newsgroups it belongs in.
+  (let ((ga group-art)
+	first)
+    (while ga
+      (nnmh-possibly-create-directory (caar ga))
+      (let ((file (concat (nnmail-group-pathname
+			   (caar ga) nnmh-directory)
+			  (int-to-string (cdar ga)))))
+	(if first
+	    ;; It was already saved, so we just make a hard link.
+	    (funcall nnmail-crosspost-link-function first file t)
+	  ;; Save the article.
+	  (nnmail-write-region (point-min) (point-max) file nil nil)
+	  (setq first file)))
+      (setq ga (cdr ga))))
+  group-art)
+
+(defun nnmh-active-number (group)
+  "Compute the next article number in GROUP."
+  (let ((active (cadr (assoc group nnmh-group-alist)))
+	(dir (nnmail-group-pathname group nnmh-directory)))
+    (unless active
+      ;; The group wasn't known to nnmh, so we just create an active
+      ;; entry for it.
+      (setq active (cons 1 0))
+      (push (list group active) nnmh-group-alist)
+      (unless (file-exists-p dir)
+	(make-directory dir))
+      ;; Find the highest number in the group.
+      (let ((files (sort
+		    (mapcar
+		     (lambda (f)
+		       (string-to-int f))
+		     (directory-files dir nil "^[0-9]+$"))
+		    '>)))
+	(when files
+	  (setcdr active (car files)))))
+    (setcdr active (1+ (cdr active)))
+    (while (file-exists-p
+	    (concat (nnmail-group-pathname group nnmh-directory)
+		    (int-to-string (cdr active))))
+      (setcdr active (1+ (cdr active))))
+    (cdr active)))
+
+(defun nnmh-update-gnus-unreads (group)
+  ;; Go through the .nnmh-articles file and compare with the actual
+  ;; articles in this folder.  The articles that are "new" will be
+  ;; marked as unread by Gnus.
+  (let* ((dir nnmh-current-directory)
+	 (files (sort (mapcar (function (lambda (name) (string-to-int name)))
+			      (directory-files nnmh-current-directory
+					       nil "^[0-9]+$" t))
+		      '<))
+	 (nnmh-file (concat dir ".nnmh-articles"))
+	 new articles)
+    ;; Load the .nnmh-articles file.
+    (when (file-exists-p nnmh-file)
+      (setq articles
+	    (let (nnmh-newsgroup-articles)
+	      (ignore-errors (load nnmh-file nil t t))
+	      nnmh-newsgroup-articles)))
+    ;; Add all new articles to the `new' list.
+    (let ((art files))
+      (while art
+	(unless (assq (car art) articles)
+	  (push (car art) new))
+	(setq art (cdr art))))
+    ;; Remove all deleted articles.
+    (let ((art articles))
+      (while art
+	(unless (memq (caar art) files)
+	  (setq articles (delq (car art) articles)))
+	(setq art (cdr art))))
+    ;; Check whether the articles really are the ones that Gnus thinks
+    ;; they are by looking at the time-stamps.
+    (let ((arts articles)
+	  art)
+      (while (setq art (pop arts))
+	(when (not (equal
+		    (nth 5 (file-attributes
+			    (concat dir (int-to-string (car art)))))
+		    (cdr art)))
+	  (setq articles (delq art articles))
+	  (push (car art) new))))
+    ;; Go through all the new articles and add them, and their
+    ;; time-stamps, to the list.
+    (setq articles
+	  (nconc articles
+		 (mapcar
+		  (lambda (art)
+		    (cons art
+			  (nth 5 (file-attributes
+				  (concat dir (int-to-string art))))))
+		  new)))
+    ;; Make Gnus mark all new articles as unread.
+    (when new
+      (gnus-make-articles-unread
+       (gnus-group-prefixed-name group (list 'nnmh ""))
+       (setq new (sort new '<))))
+    ;; Sort the article list with highest numbers first.
+    (setq articles (sort articles (lambda (art1 art2)
+				    (> (car art1) (car art2)))))
+    ;; Finally write this list back to the .nnmh-articles file.
+    (nnheader-temp-write nnmh-file
+      (insert ";; Gnus article active file for " group "\n\n")
+      (insert "(setq nnmh-newsgroup-articles '")
+      (gnus-prin1 articles)
+      (insert ")\n"))))
+
+(defun nnmh-deletable-article-p (group article)
+  "Say whether ARTICLE in GROUP can be deleted."
+  (let ((path (concat nnmh-current-directory (int-to-string article))))
+    ;; Writable.
+    (and (file-writable-p path)
+	 ;; We can never delete the last article in the group.
+	 (not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
+		  article)))))
+
+(provide 'nnmh)
+
+;;; nnmh.el ends here

lisp/gnus/nnml.el

@@ -0,0 +1,793 @@
+;;; nnml.el --- mail spool access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
+;; For an overview of what the interface functions do, please see the
+;; Gnus sources.
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nnmail)
+(require 'nnoo)
+(require 'cl)
+
+(nnoo-declare nnml)
+
+(defvoo nnml-directory message-directory
+  "Mail spool directory.")
+
+(defvoo nnml-active-file
+  (concat (file-name-as-directory nnml-directory) "active")
+  "Mail active file.")
+
+(defvoo nnml-newsgroups-file
+  (concat (file-name-as-directory nnml-directory) "newsgroups")
+  "Mail newsgroups description file.")
+
+(defvoo nnml-get-new-mail t
+  "If non-nil, nnml will check the incoming mail file and split the mail.")
+
+(defvoo nnml-nov-is-evil nil
+  "If non-nil, Gnus will never generate and use nov databases for mail groups.
+Using nov databases will speed up header fetching considerably.
+This variable shouldn't be flipped much.  If you have, for some reason,
+set this to t, and want to set it to nil again, you should always run
+the `nnml-generate-nov-databases' command.  The function will go
+through all nnml directories and generate nov databases for them
+all.  This may very well take some time.")
+
+(defvoo nnml-prepare-save-mail-hook nil
+  "Hook run narrowed to an article before saving.")
+
+(defvoo nnml-inhibit-expiry nil
+  "If non-nil, inhibit expiry.")
+
+
+
+
+(defconst nnml-version "nnml 1.0"
+  "nnml version.")
+
+(defvoo nnml-nov-file-name ".overview")
+
+(defvoo nnml-current-directory nil)
+(defvoo nnml-current-group nil)
+(defvoo nnml-status-string "")
+(defvoo nnml-nov-buffer-alist nil)
+(defvoo nnml-group-alist nil)
+(defvoo nnml-active-timestamp nil)
+(defvoo nnml-article-file-alist nil)
+
+(defvoo nnml-generate-active-function 'nnml-generate-active-info)
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nnml)
+
+(deffoo nnml-retrieve-headers (sequence &optional group server fetch-old)
+  (when (nnml-possibly-change-directory group server)
+    (save-excursion
+      (set-buffer nntp-server-buffer)
+      (erase-buffer)
+      (let ((file nil)
+	    (number (length sequence))
+	    (count 0)
+	    beg article)
+	(if (stringp (car sequence))
+	    'headers
+	  (if (nnml-retrieve-headers-with-nov sequence fetch-old)
+	      'nov
+	    (while sequence
+	      (setq article (car sequence))
+	      (setq file (nnml-article-to-file article))
+	      (when (and file
+			 (file-exists-p file)
+			 (not (file-directory-p file)))
+		(insert (format "221 %d Article retrieved.\n" article))
+		(setq beg (point))
+		(nnheader-insert-head file)
+		(goto-char beg)
+		(if (search-forward "\n\n" nil t)
+		    (forward-char -1)
+		  (goto-char (point-max))
+		  (insert "\n\n"))
+		(insert ".\n")
+		(delete-region (point) (point-max)))
+	      (setq sequence (cdr sequence))
+	      (setq count (1+ count))
+	      (and (numberp nnmail-large-newsgroup)
+		   (> number nnmail-large-newsgroup)
+		   (zerop (% count 20))
+		   (nnheader-message 6 "nnml: Receiving headers... %d%%"
+				     (/ (* count 100) number))))
+
+	    (and (numberp nnmail-large-newsgroup)
+		 (> number nnmail-large-newsgroup)
+		 (nnheader-message 6 "nnml: Receiving headers...done"))
+
+	    (nnheader-fold-continuation-lines)
+	    'headers))))))
+
+(deffoo nnml-open-server (server &optional defs)
+  (nnoo-change-server 'nnml server defs)
+  (when (not (file-exists-p nnml-directory))
+    (condition-case ()
+	(make-directory nnml-directory t)
+      (error)))
+  (cond
+   ((not (file-exists-p nnml-directory))
+    (nnml-close-server)
+    (nnheader-report 'nnml "Couldn't create directory: %s" nnml-directory))
+   ((not (file-directory-p (file-truename nnml-directory)))
+    (nnml-close-server)
+    (nnheader-report 'nnml "Not a directory: %s" nnml-directory))
+   (t
+    (nnheader-report 'nnml "Opened server %s using directory %s"
+		     server nnml-directory)
+    t)))
+
+(defun nnml-request-regenerate (server)
+  (nnml-possibly-change-directory nil server)
+  (nnml-generate-nov-databases)
+  t)
+
+(deffoo nnml-request-article (id &optional group server buffer)
+  (nnml-possibly-change-directory group server)
+  (let* ((nntp-server-buffer (or buffer nntp-server-buffer))
+	 path gpath group-num)
+    (if (stringp id)
+	(when (and (setq group-num (nnml-find-group-number id))
+		   (cdr
+		    (assq (cdr group-num)
+			  (nnheader-article-to-file-alist
+			   (setq gpath
+				 (nnmail-group-pathname
+				  (car group-num)
+				  nnml-directory))))))
+	  (setq path (concat gpath (int-to-string (cdr group-num)))))
+      (setq path (nnml-article-to-file id)))
+    (cond
+     ((not path)
+      (nnheader-report 'nnml "No such article: %s" id))
+     ((not (file-exists-p path))
+      (nnheader-report 'nnml "No such file: %s" path))
+     ((file-directory-p path)
+      (nnheader-report 'nnml "File is a directory: %s" path))
+     ((not (save-excursion (nnmail-find-file path)))
+      (nnheader-report 'nnml "Couldn't read file: %s" path))
+     (t
+      (nnheader-report 'nnml "Article %s retrieved" id)
+      ;; We return the article number.
+      (cons (if group-num (car group-num) group)
+	    (string-to-int (file-name-nondirectory path)))))))
+
+(deffoo nnml-request-group (group &optional server dont-check)
+  (cond
+   ((not (nnml-possibly-change-directory group server))
+    (nnheader-report 'nnml "Invalid group (no such directory)"))
+   ((not (file-exists-p nnml-current-directory))
+    (nnheader-report 'nnml "Directory %s does not exist"
+		     nnml-current-directory))
+   ((not (file-directory-p nnml-current-directory))
+    (nnheader-report 'nnml "%s is not a directory" nnml-current-directory))
+   (dont-check
+    (nnheader-report 'nnml "Group %s selected" group)
+    t)
+   (t
+    (nnheader-re-read-dir nnml-current-directory)
+    (nnmail-activate 'nnml)
+    (let ((active (nth 1 (assoc group nnml-group-alist))))
+      (if (not active)
+	  (nnheader-report 'nnml "No such group: %s" group)
+	(nnheader-report 'nnml "Selected group %s" group)
+	(nnheader-insert "211 %d %d %d %s\n"
+			 (max (1+ (- (cdr active) (car active))) 0)
+			 (car active) (cdr active) group))))))
+
+(deffoo nnml-request-scan (&optional group server)
+  (setq nnml-article-file-alist nil)
+  (nnml-possibly-change-directory group server)
+  (nnmail-get-new-mail 'nnml 'nnml-save-nov nnml-directory group))
+
+(deffoo nnml-close-group (group &optional server)
+  (setq nnml-article-file-alist nil)
+  t)
+
+(deffoo nnml-request-create-group (group &optional server args)
+  (nnmail-activate 'nnml)
+  (unless (assoc group nnml-group-alist)
+    (let (active)
+      (push (list group (setq active (cons 1 0)))
+	    nnml-group-alist)
+      (nnml-possibly-create-directory group)
+      (nnml-possibly-change-directory group server)
+      (let ((articles (nnheader-directory-articles nnml-current-directory)))
+	(when articles
+	  (setcar active (apply 'min articles))
+	  (setcdr active (apply 'max articles))))
+      (nnmail-save-active nnml-group-alist nnml-active-file)))
+  t)
+
+(deffoo nnml-request-list (&optional server)
+  (save-excursion
+    (nnmail-find-file nnml-active-file)
+    (setq nnml-group-alist (nnmail-get-active))
+    t))
+
+(deffoo nnml-request-newgroups (date &optional server)
+  (nnml-request-list server))
+
+(deffoo nnml-request-list-newsgroups (&optional server)
+  (save-excursion
+    (nnmail-find-file nnml-newsgroups-file)))
+
+(deffoo nnml-request-expire-articles (articles group
+					       &optional server force)
+  (nnml-possibly-change-directory group server)
+  (let* ((active-articles
+	  (nnheader-directory-articles nnml-current-directory))
+	 (is-old t)
+	 article rest mod-time number)
+    (nnmail-activate 'nnml)
+
+    (while (and articles is-old)
+      (when (setq article (nnml-article-to-file (setq number (pop articles))))
+	(when (setq mod-time (nth 5 (file-attributes article)))
+	  (if (and (nnml-deletable-article-p group number)
+		   (setq is-old
+			 (nnmail-expired-article-p group mod-time force
+						   nnml-inhibit-expiry)))
+	      (progn
+		(nnheader-message 5 "Deleting article %s in %s"
+				  article group)
+		(condition-case ()
+		    (funcall nnmail-delete-file-function article)
+		  (file-error
+		   (push number rest)))
+		(setq active-articles (delq number active-articles))
+		(nnml-nov-delete-article group number))
+	    (push number rest)))))
+    (let ((active (nth 1 (assoc group nnml-group-alist))))
+      (when active
+	(setcar active (or (and active-articles
+				(apply 'min active-articles))
+			   (1+ (cdr active)))))
+      (nnmail-save-active nnml-group-alist nnml-active-file))
+    (nnml-save-nov)
+    (nconc rest articles)))
+
+(deffoo nnml-request-move-article
+  (article group server accept-form &optional last)
+  (let ((buf (get-buffer-create " *nnml move*"))
+	result)
+    (nnml-possibly-change-directory group server)
+    (nnml-update-file-alist)
+    (and
+     (nnml-deletable-article-p group article)
+     (nnml-request-article article group server)
+     (save-excursion
+       (set-buffer buf)
+       (insert-buffer-substring nntp-server-buffer)
+       (setq result (eval accept-form))
+       (kill-buffer (current-buffer))
+       result)
+     (progn
+       (nnml-possibly-change-directory group server)
+       (condition-case ()
+	   (funcall nnmail-delete-file-function
+		    (nnml-article-to-file  article))
+	 (file-error nil))
+       (nnml-nov-delete-article group article)
+       (when last
+	 (nnml-save-nov)
+	 (nnmail-save-active nnml-group-alist nnml-active-file))))
+    result))
+
+(deffoo nnml-request-accept-article (group &optional server last)
+  (nnml-possibly-change-directory group server)
+  (nnmail-check-syntax)
+  (let (result)
+    (when nnmail-cache-accepted-message-ids
+      (nnmail-cache-insert (nnmail-fetch-field "message-id")))
+    (if (stringp group)
+	(and
+	 (nnmail-activate 'nnml)
+	 (setq result (car (nnml-save-mail
+			    (list (cons group (nnml-active-number group))))))
+	 (progn
+	   (nnmail-save-active nnml-group-alist nnml-active-file)
+	   (and last (nnml-save-nov))))
+      (and
+       (nnmail-activate 'nnml)
+       (if (and (not (setq result (nnmail-article-group 'nnml-active-number)))
+		(yes-or-no-p "Moved to `junk' group; delete article? "))
+	   (setq result 'junk)
+	 (setq result (car (nnml-save-mail result))))
+       (when last
+	 (nnmail-save-active nnml-group-alist nnml-active-file)
+	 (when nnmail-cache-accepted-message-ids
+	   (nnmail-cache-close))
+	 (nnml-save-nov))))
+    result))
+
+(deffoo nnml-request-replace-article (article group buffer)
+  (nnml-possibly-change-directory group)
+  (save-excursion
+    (set-buffer buffer)
+    (nnml-possibly-create-directory group)
+    (let ((chars (nnmail-insert-lines))
+	  (art (concat (int-to-string article) "\t"))
+	  headers)
+      (when (condition-case ()
+		(progn
+		  (nnmail-write-region
+		   (point-min) (point-max)
+		   (or (nnml-article-to-file article)
+		       (concat nnml-current-directory
+			       (int-to-string article)))
+		   nil (if (nnheader-be-verbose 5) nil 'nomesg))
+		  t)
+	      (error nil))
+	(setq headers (nnml-parse-head chars article))
+	;; Replace the NOV line in the NOV file.
+	(save-excursion
+	  (set-buffer (nnml-open-nov group))
+	  (goto-char (point-min))
+	  (if (or (looking-at art)
+		  (search-forward (concat "\n" art) nil t))
+	      ;; Delete the old NOV line.
+	      (delete-region (progn (beginning-of-line) (point))
+			     (progn (forward-line 1) (point)))
+	    ;; The line isn't here, so we have to find out where
+	    ;; we should insert it.  (This situation should never
+	    ;; occur, but one likes to make sure...)
+	    (while (and (looking-at "[0-9]+\t")
+			(< (string-to-int
+			    (buffer-substring
+			     (match-beginning 0) (match-end 0)))
+			   article)
+			(zerop (forward-line 1)))))
+	  (beginning-of-line)
+	  (nnheader-insert-nov headers)
+	  (nnml-save-nov)
+	  t)))))
+
+(deffoo nnml-request-delete-group (group &optional force server)
+  (nnml-possibly-change-directory group server)
+  (when force
+    ;; Delete all articles in GROUP.
+    (let ((articles
+	   (directory-files
+	    nnml-current-directory t
+	    (concat nnheader-numerical-short-files
+		    "\\|" (regexp-quote nnml-nov-file-name) "$")))
+	  article)
+      (while articles
+	(setq article (pop articles))
+	(when (file-writable-p article)
+	  (nnheader-message 5 "Deleting article %s in %s..." article group)
+	  (funcall nnmail-delete-file-function article))))
+    ;; Try to delete the directory itself.
+    (condition-case ()
+	(delete-directory nnml-current-directory)
+      (error nil)))
+  ;; Remove the group from all structures.
+  (setq nnml-group-alist
+	(delq (assoc group nnml-group-alist) nnml-group-alist)
+	nnml-current-group nil
+	nnml-current-directory nil)
+  ;; Save the active file.
+  (nnmail-save-active nnml-group-alist nnml-active-file)
+  t)
+
+(deffoo nnml-request-rename-group (group new-name &optional server)
+  (nnml-possibly-change-directory group server)
+  (let ((new-dir (nnmail-group-pathname new-name nnml-directory))
+	(old-dir (nnmail-group-pathname group nnml-directory)))
+    (when (condition-case ()
+	      (progn
+		(make-directory new-dir t)
+		t)
+	    (error nil))
+      ;; We move the articles file by file instead of renaming
+      ;; the directory -- there may be subgroups in this group.
+      ;; One might be more clever, I guess.
+      (let ((files (nnheader-article-to-file-alist old-dir)))
+	(while files
+	  (rename-file
+	   (concat old-dir (cdar files))
+	   (concat new-dir (cdar files)))
+	  (pop files)))
+      ;; Move .overview file.
+      (let ((overview (concat old-dir nnml-nov-file-name)))
+	(when (file-exists-p overview)
+	  (rename-file overview (concat new-dir nnml-nov-file-name))))
+      (when (<= (length (directory-files old-dir)) 2)
+	(condition-case ()
+	    (delete-directory old-dir)
+	  (error nil)))
+      ;; That went ok, so we change the internal structures.
+      (let ((entry (assoc group nnml-group-alist)))
+	(when entry
+	  (setcar entry new-name))
+	(setq nnml-current-directory nil
+	      nnml-current-group nil)
+	;; Save the new group alist.
+	(nnmail-save-active nnml-group-alist nnml-active-file)
+	t))))
+
+(deffoo nnml-set-status (article name value &optional group server)
+  (nnml-possibly-change-directory group server)
+  (let ((file (nnml-article-to-file article)))
+    (cond
+     ((not (file-exists-p file))
+      (nnheader-report 'nnml "File %s does not exist" file))
+     (t
+      (nnheader-temp-write file
+	(nnheader-insert-file-contents file)
+	(nnmail-replace-status name value))
+      t))))
+
+
+;;; Internal functions.
+
+(defun nnml-article-to-file (article)
+  (nnml-update-file-alist)
+  (let (file)
+    (when (setq file (cdr (assq article nnml-article-file-alist)))
+      (concat nnml-current-directory file))))
+
+(defun nnml-deletable-article-p (group article)
+  "Say whether ARTICLE in GROUP can be deleted."
+  (let (path)
+    (when (setq path (nnml-article-to-file article))
+      (when (file-writable-p path)
+	(or (not nnmail-keep-last-article)
+	    (not (eq (cdr (nth 1 (assoc group nnml-group-alist)))
+		     article)))))))
+
+;; Find an article number in the current group given the Message-ID.
+(defun nnml-find-group-number (id)
+  (save-excursion
+    (set-buffer (get-buffer-create " *nnml id*"))
+    (buffer-disable-undo (current-buffer))
+    (let ((alist nnml-group-alist)
+	  number)
+      ;; We want to look through all .overview files, but we want to
+      ;; start with the one in the current directory.  It seems most
+      ;; likely that the article we are looking for is in that group.
+      (if (setq number (nnml-find-id nnml-current-group id))
+	  (cons nnml-current-group number)
+	;; It wasn't there, so we look through the other groups as well.
+	(while (and (not number)
+		    alist)
+	  (or (string= (caar alist) nnml-current-group)
+	      (setq number (nnml-find-id (caar alist) id)))
+	  (or number
+	      (setq alist (cdr alist))))
+	(and number
+	     (cons (caar alist) number))))))
+
+(defun nnml-find-id (group id)
+  (erase-buffer)
+  (let ((nov (concat (nnmail-group-pathname group nnml-directory)
+		     nnml-nov-file-name))
+	number found)
+    (when (file-exists-p nov)
+      (nnheader-insert-file-contents nov)
+      (while (and (not found)
+		  (search-forward id nil t)) ; We find the ID.
+	;; And the id is in the fourth field.
+	(if (not (and (search-backward "\t" nil t 4)
+		      (not (search-backward"\t" (gnus-point-at-bol) t))))
+	    (forward-line 1)
+	  (beginning-of-line)
+	  (setq found t)
+	  ;; We return the article number.
+	  (setq number
+		(condition-case ()
+		    (read (current-buffer))
+		  (error nil)))))
+      number)))
+
+(defun nnml-retrieve-headers-with-nov (articles &optional fetch-old)
+  (if (or gnus-nov-is-evil nnml-nov-is-evil)
+      nil
+    (let ((nov (concat nnml-current-directory nnml-nov-file-name)))
+      (when (file-exists-p nov)
+	(save-excursion
+	  (set-buffer nntp-server-buffer)
+	  (erase-buffer)
+	  (nnheader-insert-file-contents nov)
+	  (if (and fetch-old
+		   (not (numberp fetch-old)))
+	      t				; Don't remove anything.
+	    (nnheader-nov-delete-outside-range
+	     (if fetch-old (max 1 (- (car articles) fetch-old))
+	       (car articles))
+	     (car (last articles)))
+	    t))))))
+
+(defun nnml-possibly-change-directory (group &optional server)
+  (when (and server
+	     (not (nnml-server-opened server)))
+    (nnml-open-server server))
+  (if (not group)
+      t
+    (let ((pathname (nnmail-group-pathname group nnml-directory)))
+      (when (not (equal pathname nnml-current-directory))
+	(setq nnml-current-directory pathname
+	      nnml-current-group group
+	      nnml-article-file-alist nil))
+      (file-exists-p nnml-current-directory))))
+
+(defun nnml-possibly-create-directory (group)
+  (let (dir dirs)
+    (setq dir (nnmail-group-pathname group nnml-directory))
+    (while (not (file-directory-p dir))
+      (push dir dirs)
+      (setq dir (file-name-directory (directory-file-name dir))))
+    (while dirs
+      (make-directory (directory-file-name (car dirs)))
+      (nnheader-message 5 "Creating mail directory %s" (car dirs))
+      (setq dirs (cdr dirs)))))
+
+(defun nnml-save-mail (group-art)
+  "Called narrowed to an article."
+  (let (chars headers)
+    (setq chars (nnmail-insert-lines))
+    (nnmail-insert-xref group-art)
+    (run-hooks 'nnmail-prepare-save-mail-hook)
+    (run-hooks 'nnml-prepare-save-mail-hook)
+    (goto-char (point-min))
+    (while (looking-at "From ")
+      (replace-match "X-From-Line: ")
+      (forward-line 1))
+    ;; We save the article in all the groups it belongs in.
+    (let ((ga group-art)
+	  first)
+      (while ga
+	(nnml-possibly-create-directory (caar ga))
+	(let ((file (concat (nnmail-group-pathname
+			     (caar ga) nnml-directory)
+			    (int-to-string (cdar ga)))))
+	  (if first
+	      ;; It was already saved, so we just make a hard link.
+	      (funcall nnmail-crosspost-link-function first file t)
+	    ;; Save the article.
+	    (nnmail-write-region (point-min) (point-max) file nil
+				 (if (nnheader-be-verbose 5) nil 'nomesg))
+	    (setq first file)))
+	(setq ga (cdr ga))))
+    ;; Generate a nov line for this article.  We generate the nov
+    ;; line after saving, because nov generation destroys the
+    ;; header.
+    (setq headers (nnml-parse-head chars))
+    ;; Output the nov line to all nov databases that should have it.
+    (let ((ga group-art))
+      (while ga
+	(nnml-add-nov (caar ga) (cdar ga) headers)
+	(setq ga (cdr ga))))
+    group-art))
+
+(defun nnml-active-number (group)
+  "Compute the next article number in GROUP."
+  (let ((active (cadr (assoc group nnml-group-alist))))
+    ;; The group wasn't known to nnml, so we just create an active
+    ;; entry for it.
+    (unless active
+      ;; Perhaps the active file was corrupt?  See whether
+      ;; there are any articles in this group.
+      (nnml-possibly-create-directory group)
+      (nnml-possibly-change-directory group)
+      (unless nnml-article-file-alist
+	(setq nnml-article-file-alist
+	      (sort
+	       (nnheader-article-to-file-alist nnml-current-directory)
+	       (lambda (a1 a2) (< (car a1) (car a2))))))
+      (setq active
+	    (if nnml-article-file-alist
+		(cons (caar nnml-article-file-alist)
+		      (caar (last nnml-article-file-alist)))
+	      (cons 1 0)))
+      (push (list group active) nnml-group-alist))
+    (setcdr active (1+ (cdr active)))
+    (while (file-exists-p
+	    (concat (nnmail-group-pathname group nnml-directory)
+		    (int-to-string (cdr active))))
+      (setcdr active (1+ (cdr active))))
+    (cdr active)))
+
+(defun nnml-add-nov (group article headers)
+  "Add a nov line for the GROUP base."
+  (save-excursion
+    (set-buffer (nnml-open-nov group))
+    (goto-char (point-max))
+    (mail-header-set-number headers article)
+    (nnheader-insert-nov headers)))
+
+(defsubst nnml-header-value ()
+  (buffer-substring (match-end 0) (progn (end-of-line) (point))))
+
+(defun nnml-parse-head (chars &optional number)
+  "Parse the head of the current buffer."
+  (save-excursion
+    (save-restriction
+      (goto-char (point-min))
+      (narrow-to-region
+       (point)
+       (1- (or (search-forward "\n\n" nil t) (point-max))))
+      ;; Fold continuation lines.
+      (goto-char (point-min))
+      (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+	(replace-match " " t t))
+      ;; Remove any tabs; they are too confusing.
+      (subst-char-in-region (point-min) (point-max) ?\t ? )
+      (let ((headers (nnheader-parse-head t)))
+	(mail-header-set-chars headers chars)
+	(mail-header-set-number headers number)
+	headers))))
+
+(defun nnml-open-nov (group)
+  (or (cdr (assoc group nnml-nov-buffer-alist))
+      (let ((buffer (nnheader-find-file-noselect
+		     (concat (nnmail-group-pathname group nnml-directory)
+			     nnml-nov-file-name))))
+	(save-excursion
+	  (set-buffer buffer)
+	  (buffer-disable-undo (current-buffer)))
+	(push (cons group buffer) nnml-nov-buffer-alist)
+	buffer)))
+
+(defun nnml-save-nov ()
+  (save-excursion
+    (while nnml-nov-buffer-alist
+      (when (buffer-name (cdar nnml-nov-buffer-alist))
+	(set-buffer (cdar nnml-nov-buffer-alist))
+	(when (buffer-modified-p)
+	  (nnmail-write-region 1 (point-max) (buffer-file-name) nil 'nomesg))
+	(set-buffer-modified-p nil)
+	(kill-buffer (current-buffer)))
+      (setq nnml-nov-buffer-alist (cdr nnml-nov-buffer-alist)))))
+
+;;;###autoload
+(defun nnml-generate-nov-databases ()
+  "Generate NOV databases in all nnml directories."
+  (interactive)
+  ;; Read the active file to make sure we don't re-use articles
+  ;; numbers in empty groups.
+  (nnmail-activate 'nnml)
+  (nnml-open-server (or (nnoo-current-server 'nnml) ""))
+  (setq nnml-directory (expand-file-name nnml-directory))
+  ;; Recurse down the directories.
+  (nnml-generate-nov-databases-1 nnml-directory nil t)
+  ;; Save the active file.
+  (nnmail-save-active nnml-group-alist nnml-active-file))
+
+(defun nnml-generate-nov-databases-1 (dir &optional seen no-active)
+  "Regenerate the NOV database in DIR."
+  (interactive "DRegenerate NOV in: ")
+  (setq dir (file-name-as-directory dir))
+  ;; Only scan this sub-tree if we haven't been here yet.
+  (unless (member (file-truename dir) seen)
+    (push (file-truename dir) seen)
+    ;; We descend recursively
+    (let ((dirs (directory-files dir t nil t))
+	  dir)
+      (while (setq dir (pop dirs))
+	(when (and (not (member (file-name-nondirectory dir) '("." "..")))
+		   (file-directory-p dir))
+	  (nnml-generate-nov-databases-1 dir seen))))
+    ;; Do this directory.
+    (let ((files (sort (nnheader-article-to-file-alist dir)
+		       (lambda (a b) (< (car a) (car b))))))
+      (when files
+	(funcall nnml-generate-active-function dir)
+	;; Generate the nov file.
+	(nnml-generate-nov-file dir files)
+	(unless no-active
+	  (nnmail-save-active nnml-group-alist nnml-active-file))))))
+
+(defvar files)
+(defun nnml-generate-active-info (dir)
+  ;; Update the active info for this group.
+  (let ((group (nnheader-file-to-group
+		(directory-file-name dir) nnml-directory)))
+    (setq nnml-group-alist
+	  (delq (assoc group nnml-group-alist) nnml-group-alist))
+    (push (list group
+		(cons (caar files)
+		      (let ((f files))
+			(while (cdr f) (setq f (cdr f)))
+			(caar f))))
+	  nnml-group-alist)))
+
+(defun nnml-generate-nov-file (dir files)
+  (let* ((dir (file-name-as-directory dir))
+	 (nov (concat dir nnml-nov-file-name))
+	 (nov-buffer (get-buffer-create " *nov*"))
+	 chars file headers)
+    (save-excursion
+      ;; Init the nov buffer.
+      (set-buffer nov-buffer)
+      (buffer-disable-undo (current-buffer))
+      (erase-buffer)
+      (set-buffer nntp-server-buffer)
+      ;; Delete the old NOV file.
+      (when (file-exists-p nov)
+	(funcall nnmail-delete-file-function nov))
+      (while files
+	(unless (file-directory-p (setq file (concat dir (cdar files))))
+	  (erase-buffer)
+	  (nnheader-insert-file-contents file)
+	  (narrow-to-region
+	   (goto-char (point-min))
+	   (progn
+	     (search-forward "\n\n" nil t)
+	     (setq chars (- (point-max) (point)))
+	     (max 1 (1- (point)))))
+	  (when (and (not (= 0 chars))	; none of them empty files...
+		     (not (= (point-min) (point-max))))
+	    (goto-char (point-min))
+	    (setq headers (nnml-parse-head chars (caar files)))
+	    (save-excursion
+	      (set-buffer nov-buffer)
+	      (goto-char (point-max))
+	      (nnheader-insert-nov headers)))
+	  (widen))
+	(setq files (cdr files)))
+      (save-excursion
+	(set-buffer nov-buffer)
+	(nnmail-write-region 1 (point-max) nov nil 'nomesg)
+	(kill-buffer (current-buffer))))))
+
+(defun nnml-nov-delete-article (group article)
+  (save-excursion
+    (set-buffer (nnml-open-nov group))
+    (when (nnheader-find-nov-line article)
+      (delete-region (point) (progn (forward-line 1) (point)))
+      (when (bobp)
+	(let ((active (cadr (assoc group nnml-group-alist)))
+	      num)
+	  (when active
+	    (if (eobp)
+		(setf (car active) (1+ (cdr active)))
+	      (when (and (setq num (ignore-errors (read (current-buffer))))
+			 (numberp num))
+		(setf (car active) num)))))))
+    t))
+
+(defun nnml-update-file-alist ()
+  (unless nnml-article-file-alist
+    (setq nnml-article-file-alist
+	  (nnheader-article-to-file-alist nnml-current-directory))))
+
+(provide 'nnml)
+
+;;; nnml.el ends here

lisp/gnus/nnoo.el

@@ -0,0 +1,279 @@
+;;; nnoo.el --- OO Gnus Backends
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'cl)
+
+(defvar nnoo-definition-alist nil)
+(defvar nnoo-state-alist nil)
+
+(defmacro defvoo (var init &optional doc &rest map)
+  "The same as `defvar', only takes list of variables to MAP to."
+  `(prog1
+       ,(if doc
+	    `(defvar ,var ,init ,doc)
+	  `(defvar ,var ,init))
+     (nnoo-define ',var ',map)))
+(put 'defvoo 'lisp-indent-function 2)
+(put 'defvoo 'edebug-form-spec '(var init &optional doc &rest map))
+
+(defmacro deffoo (func args &rest forms)
+  "The same as `defun', only register FUNC."
+  `(prog1
+       (defun ,func ,args ,@forms)
+     (nnoo-register-function ',func)))
+(put 'deffoo 'lisp-indent-function 2)
+(put 'deffoo 'edebug-form-spec '(&define name lambda-list def-body))
+
+(defun nnoo-register-function (func)
+  (let ((funcs (nthcdr 3 (assoc (nnoo-backend func)
+				nnoo-definition-alist))))
+    (unless funcs
+      (error "%s belongs to a backend that hasn't been declared" func))
+    (setcar funcs (cons func (car funcs)))))
+
+(defmacro nnoo-declare (backend &rest parents)
+  `(eval-and-compile
+     (push (list ',backend
+		 (mapcar (lambda (p) (list p)) ',parents)
+		 nil nil)
+	   nnoo-definition-alist)
+     (push (list ',backend "*internal-non-initialized-backend*")
+	   nnoo-state-alist)))
+(put 'nnoo-declare 'lisp-indent-function 1)
+
+(defun nnoo-parents (backend)
+  (nth 1 (assoc backend nnoo-definition-alist)))
+
+(defun nnoo-variables (backend)
+  (nth 2 (assoc backend nnoo-definition-alist)))
+
+(defun nnoo-functions (backend)
+  (nth 3 (assoc backend nnoo-definition-alist)))
+
+(defmacro nnoo-import (backend &rest imports)
+  `(nnoo-import-1 ',backend ',imports))
+(put 'nnoo-import 'lisp-indent-function 1)
+
+(defun nnoo-import-1 (backend imports)
+  (let ((call-function
+	 (if (symbolp (car imports)) (pop imports) 'nnoo-parent-function))
+	imp functions function)
+    (while (setq imp (pop imports))
+      (setq functions
+	    (or (cdr imp)
+		(nnoo-functions (car imp))))
+      (while functions
+	(unless (fboundp (setq function
+			       (nnoo-symbol backend (nnoo-rest-symbol
+						     (car functions)))))
+	  (eval `(deffoo ,function (&rest args)
+		   (,call-function ',backend ',(car functions) args))))
+	(pop functions)))))
+
+(defun nnoo-parent-function (backend function args)
+  (let* ((pbackend (nnoo-backend function)))
+    (nnoo-change-server pbackend (nnoo-current-server backend)
+			(cdr (assq pbackend (nnoo-parents backend))))
+    (apply function args)))
+
+(defun nnoo-execute (backend function &rest args)
+  "Execute FUNCTION on behalf of BACKEND."
+  (let* ((pbackend (nnoo-backend function)))
+    (nnoo-change-server pbackend (nnoo-current-server backend)
+			(cdr (assq pbackend (nnoo-parents backend))))
+    (apply function args)))
+
+(defmacro nnoo-map-functions (backend &rest maps)
+  `(nnoo-map-functions-1 ',backend ',maps))
+(put 'nnoo-map-functions 'lisp-indent-function 1)
+
+(defun nnoo-map-functions-1 (backend maps)
+  (let (m margs i)
+    (while (setq m (pop maps))
+      (setq i 0
+	    margs nil)
+      (while (< i (length (cdr m)))
+	(if (numberp (nth i (cdr m)))
+	    (push `(nth ,i args) margs)
+	  (push (nth i (cdr m)) margs))
+	(incf i))
+      (eval `(deffoo ,(nnoo-symbol backend (nnoo-rest-symbol (car m)))
+		 (&rest args)
+	       (nnoo-parent-function ',backend ',(car m)
+				     ,(cons 'list (nreverse margs))))))))
+
+(defun nnoo-backend (symbol)
+  (string-match "^[^-]+-" (symbol-name symbol))
+  (intern (substring (symbol-name symbol) 0 (1- (match-end 0)))))
+
+(defun nnoo-rest-symbol (symbol)
+  (string-match "^[^-]+-" (symbol-name symbol))
+  (intern (substring (symbol-name symbol) (match-end 0))))
+
+(defun nnoo-symbol (backend symbol)
+  (intern (format "%s-%s" backend symbol)))
+
+(defun nnoo-define (var map)
+  (let* ((backend (nnoo-backend var))
+	 (def (assq backend nnoo-definition-alist))
+	 (parents (nth 1 def)))
+    (unless def
+      (error "%s belongs to a backend that hasn't been declared." var))
+    (setcar (nthcdr 2 def)
+	    (delq (assq var (nth 2 def)) (nth 2 def)))
+    (setcar (nthcdr 2 def)
+	    (cons (cons var (symbol-value var))
+		  (nth 2 def)))
+    (while map
+      (nconc (assq (nnoo-backend (car map)) parents)
+	     (list (list (pop map) var))))))
+
+(defun nnoo-change-server (backend server defs)
+  (let* ((bstate (cdr (assq backend nnoo-state-alist)))
+	 (current (car bstate))
+	 (parents (nnoo-parents backend))
+	 (bvariables (nnoo-variables backend))
+	 state def)
+    (unless bstate
+      (push (setq bstate (list backend nil))
+	    nnoo-state-alist)
+      (pop bstate))
+    (if (equal server current)
+	t
+      (nnoo-push-server backend current)
+      (setq state (or (cdr (assoc server (cddr bstate)))
+		      (nnoo-variables backend)))
+      (while state
+	(set (caar state) (cdar state))
+	(pop state))
+      (setcar bstate server)
+      (unless (cdr (assoc server (cddr bstate)))
+	(while (setq def (pop defs))
+	  (unless (assq (car def) bvariables)
+	    (nconc bvariables
+ 		   (list (cons (car def) (and (boundp (car def))
+ 					      (symbol-value (car def)))))))
+	  (set (car def) (cadr def))))
+      (while parents
+	(nnoo-change-server
+	 (caar parents) server
+	 (mapcar (lambda (def) (list (car def) (symbol-value (cadr def))))
+		 (cdar parents)))
+	(pop parents))))
+  t)
+
+(defun nnoo-push-server (backend current)
+  (let ((bstate (assq backend nnoo-state-alist))
+	(defs (nnoo-variables backend)))
+    ;; Remove the old definition.
+    (setcdr (cdr bstate) (delq (assoc current (cddr bstate)) (cddr bstate)))
+    ;; If this is the first time we push the server (i. e., this is
+    ;; the nil server), then we update the default values of
+    ;; all the variables to reflect the current values.
+    (when (equal current "*internal-non-initialized-backend*")
+      (let ((defaults (nnoo-variables backend))
+	    def)
+	(while (setq def (pop defaults))
+	  (setcdr def (symbol-value (car def))))))
+    (let (state)
+      (while defs
+	(push (cons (caar defs) (symbol-value (caar defs)))
+	      state)
+	(pop defs))
+      (nconc bstate (list (cons current state))))))
+
+(defsubst nnoo-current-server-p (backend server)
+  (equal (nnoo-current-server backend) server))
+
+(defun nnoo-current-server (backend)
+  (nth 1 (assq backend nnoo-state-alist)))
+
+(defun nnoo-close-server (backend &optional server)
+  (unless server
+    (setq server (nnoo-current-server backend)))
+  (when server
+    (let* ((bstate (cdr (assq backend nnoo-state-alist)))
+	   (defs (assoc server (cdr bstate))))
+      (when bstate
+	(setcar bstate nil)
+	(setcdr bstate (delq defs (cdr bstate)))
+	(pop defs)
+	(while defs
+	  (set (car (pop defs)) nil)))))
+  t)
+
+(defun nnoo-close (backend)
+  (setq nnoo-state-alist
+	(delq (assq backend nnoo-state-alist)
+	      nnoo-state-alist))
+  t)
+
+(defun nnoo-status-message (backend server)
+  (nnheader-get-report backend))
+
+(defun nnoo-server-opened (backend server)
+  (and (nnoo-current-server-p backend server)
+       nntp-server-buffer
+       (buffer-name nntp-server-buffer)))
+
+(defmacro nnoo-define-basics (backend)
+  "Define `close-server', `server-opened' and `status-message'."
+  `(eval-and-compile
+     (nnoo-define-basics-1 ',backend)))
+
+(defun nnoo-define-basics-1 (backend)
+  (let ((functions '(close-server server-opened status-message)))
+    (while functions
+      (eval `(deffoo ,(nnoo-symbol backend (car functions))
+		 (&optional server)
+	       (,(nnoo-symbol 'nnoo (pop functions)) ',backend server)))))
+  (eval `(deffoo ,(nnoo-symbol backend 'open-server)
+	     (server &optional defs)
+	   (nnoo-change-server ',backend server defs))))
+
+(defmacro nnoo-define-skeleton (backend)
+  "Define all required backend functions for BACKEND.
+All functions will return nil and report an error."
+  `(eval-and-compile
+     (nnoo-define-skeleton-1 ',backend)))
+
+(defun nnoo-define-skeleton-1 (backend)
+  (let ((functions '(retrieve-headers
+		     request-close request-article
+		     request-group close-group
+		     request-list request-post request-list-newsgroups))
+	function fun)
+    (while (setq function (pop functions))
+      (when (not (fboundp (setq fun (nnoo-symbol backend function))))
+	(eval `(deffoo ,fun
+		   (&rest args)
+		 (nnheader-report ',backend ,(format "%s-%s not implemented"
+						     backend function))))))))
+(provide 'nnoo)
+
+;;; nnoo.el ends here.

lisp/gnus/nnsoup.el

@@ -0,0 +1,804 @@
+;;; nnsoup.el --- SOUP access for Gnus
+;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nnmail)
+(require 'gnus-soup)
+(require 'gnus-msg)
+(require 'nnoo)
+(eval-when-compile (require 'cl))
+
+(nnoo-declare nnsoup)
+
+(defvoo nnsoup-directory "~/SOUP/"
+  "*SOUP packet directory.")
+
+(defvoo nnsoup-tmp-directory "/tmp/"
+  "*Where nnsoup will store temporary files.")
+
+(defvoo nnsoup-replies-directory (concat nnsoup-directory "replies/")
+  "*Directory where outgoing packets will be composed.")
+
+(defvoo nnsoup-replies-format-type ?n
+  "*Format of the replies packages.")
+
+(defvoo nnsoup-replies-index-type ?n
+  "*Index type of the replies packages.")
+
+(defvoo nnsoup-active-file (concat nnsoup-directory "active")
+  "Active file.")
+
+(defvoo nnsoup-packer "tar cf - %s | gzip > $HOME/Soupin%d.tgz"
+  "Format string command for packing a SOUP packet.
+The SOUP files will be inserted where the %s is in the string.
+This string MUST contain both %s and %d.  The file number will be
+inserted where %d appears.")
+
+(defvoo nnsoup-unpacker "gunzip -c %s | tar xvf -"
+  "*Format string command for unpacking a SOUP packet.
+The SOUP packet file name will be inserted at the %s.")
+
+(defvoo nnsoup-packet-directory "~/"
+  "*Where nnsoup will look for incoming packets.")
+
+(defvoo nnsoup-packet-regexp "Soupout"
+  "*Regular expression matching SOUP packets in `nnsoup-packet-directory'.")
+
+
+
+(defconst nnsoup-version "nnsoup 0.0"
+  "nnsoup version.")
+
+(defvoo nnsoup-status-string "")
+(defvoo nnsoup-group-alist nil)
+(defvoo nnsoup-current-prefix 0)
+(defvoo nnsoup-replies-list nil)
+(defvoo nnsoup-buffers nil)
+(defvoo nnsoup-current-group nil)
+(defvoo nnsoup-group-alist-touched nil)
+(defvoo nnsoup-article-alist nil)
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nnsoup)
+
+(deffoo nnsoup-retrieve-headers (sequence &optional group server fetch-old)
+  (nnsoup-possibly-change-group group)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (let ((areas (cddr (assoc nnsoup-current-group nnsoup-group-alist)))
+	  (articles sequence)
+	  (use-nov t)
+	  useful-areas this-area-seq msg-buf)
+      (if (stringp (car sequence))
+	  ;; We don't support fetching by Message-ID.
+	  'headers
+	;; We go through all the areas and find which files the
+	;; articles in SEQUENCE come from.
+	(while (and areas sequence)
+	  ;; Peel off areas that are below sequence.
+	  (while (and areas (< (cdaar areas) (car sequence)))
+	    (setq areas (cdr areas)))
+	  (when areas
+	    ;; This is a useful area.
+	    (push (car areas) useful-areas)
+	    (setq this-area-seq nil)
+	    ;; We take note whether this MSG has a corresponding IDX
+	    ;; for later use.
+	    (when (or (= (gnus-soup-encoding-index
+			  (gnus-soup-area-encoding (nth 1 (car areas)))) ?n)
+		      (not (file-exists-p
+			    (nnsoup-file
+			     (gnus-soup-area-prefix (nth 1 (car areas)))))))
+	      (setq use-nov nil))
+	    ;; We assign the portion of `sequence' that is relevant to
+	    ;; this MSG packet to this packet.
+	    (while (and sequence (<= (car sequence) (cdaar areas)))
+	      (push (car sequence) this-area-seq)
+	      (setq sequence (cdr sequence)))
+	    (setcar useful-areas (cons (nreverse this-area-seq)
+				       (car useful-areas)))))
+
+	;; We now have a list of article numbers and corresponding
+	;; areas.
+	(setq useful-areas (nreverse useful-areas))
+
+	;; Two different approaches depending on whether all the MSG
+	;; files have corresponding IDX files.  If they all do, we
+	;; simply return the relevant IDX files and let Gnus sort out
+	;; what lines are relevant.  If some of the IDX files are
+	;; missing, we must return HEADs for all the articles.
+	(if use-nov
+	    ;; We have IDX files for all areas.
+	    (progn
+	      (while useful-areas
+		(goto-char (point-max))
+		(let ((b (point))
+		      (number (car (nth 1 (car useful-areas))))
+		      (index-buffer (nnsoup-index-buffer
+				     (gnus-soup-area-prefix
+				      (nth 2 (car useful-areas))))))
+		  (when index-buffer
+		    (insert-buffer-substring index-buffer)
+		    (goto-char b)
+		    ;; We have to remove the index number entires and
+		    ;; insert article numbers instead.
+		    (while (looking-at "[0-9]+")
+		      (replace-match (int-to-string number) t t)
+		      (incf number)
+		      (forward-line 1))))
+		(setq useful-areas (cdr useful-areas)))
+	      'nov)
+	  ;; We insert HEADs.
+	  (while useful-areas
+	    (setq articles (caar useful-areas)
+		  useful-areas (cdr useful-areas))
+	    (while articles
+	      (when (setq msg-buf
+			  (nnsoup-narrow-to-article
+			   (car articles) (cdar useful-areas) 'head))
+		(goto-char (point-max))
+		(insert (format "221 %d Article retrieved.\n" (car articles)))
+		(insert-buffer-substring msg-buf)
+		(goto-char (point-max))
+		(insert ".\n"))
+	      (setq articles (cdr articles))))
+
+	  (nnheader-fold-continuation-lines)
+	  'headers)))))
+
+(deffoo nnsoup-open-server (server &optional defs)
+  (nnoo-change-server 'nnsoup server defs)
+  (when (not (file-exists-p nnsoup-directory))
+    (condition-case ()
+	(make-directory nnsoup-directory t)
+      (error t)))
+  (cond
+   ((not (file-exists-p nnsoup-directory))
+    (nnsoup-close-server)
+    (nnheader-report 'nnsoup "Couldn't create directory: %s" nnsoup-directory))
+   ((not (file-directory-p (file-truename nnsoup-directory)))
+    (nnsoup-close-server)
+    (nnheader-report 'nnsoup "Not a directory: %s" nnsoup-directory))
+   (t
+    (nnsoup-read-active-file)
+    (nnheader-report 'nnsoup "Opened server %s using directory %s"
+		     server nnsoup-directory)
+    t)))
+
+(deffoo nnsoup-request-close ()
+  (nnsoup-write-active-file)
+  (nnsoup-write-replies)
+  (gnus-soup-save-areas)
+  ;; Kill all nnsoup buffers.
+  (let (buffer)
+    (while nnsoup-buffers
+      (setq buffer (cdr (pop nnsoup-buffers)))
+      (and buffer
+	   (buffer-name buffer)
+	   (kill-buffer buffer))))
+  (setq nnsoup-group-alist nil
+	nnsoup-group-alist-touched nil
+	nnsoup-current-group nil
+	nnsoup-replies-list nil)
+  (nnoo-close-server 'nnoo)
+  t)
+
+(deffoo nnsoup-request-article (id &optional newsgroup server buffer)
+  (nnsoup-possibly-change-group newsgroup)
+  (let (buf)
+    (save-excursion
+      (set-buffer (or buffer nntp-server-buffer))
+      (erase-buffer)
+      (when (and (not (stringp id))
+		 (setq buf (nnsoup-narrow-to-article id)))
+	(insert-buffer-substring buf)
+	t))))
+
+(deffoo nnsoup-request-group (group &optional server dont-check)
+  (nnsoup-possibly-change-group group)
+  (if dont-check
+      t
+    (let ((active (cadr (assoc group nnsoup-group-alist))))
+      (if (not active)
+	  (nnheader-report 'nnsoup "No such group: %s" group)
+	(nnheader-insert
+	 "211 %d %d %d %s\n"
+	 (max (1+ (- (cdr active) (car active))) 0)
+	 (car active) (cdr active) group)))))
+
+(deffoo nnsoup-request-type (group &optional article)
+  (nnsoup-possibly-change-group group)
+  ;; Try to guess the type based on the first articl ein the group.
+  (when (not article)
+    (setq article
+	  (cdaar (cddr (assoc group nnsoup-group-alist)))))
+  (if (not article)
+      'unknown
+    (let ((kind (gnus-soup-encoding-kind
+		 (gnus-soup-area-encoding
+		  (nth 1 (nnsoup-article-to-area
+			  article nnsoup-current-group))))))
+      (cond ((= kind ?m) 'mail)
+	    ((= kind ?n) 'news)
+	    (t 'unknown)))))
+
+(deffoo nnsoup-close-group (group &optional server)
+  ;; Kill all nnsoup buffers.
+  (let ((buffers nnsoup-buffers)
+	elem)
+    (while buffers
+      (when (equal (car (setq elem (pop buffers))) group)
+	(setq nnsoup-buffers (delq elem nnsoup-buffers))
+	(and (cdr elem) (buffer-name (cdr elem))
+	     (kill-buffer (cdr elem))))))
+  t)
+
+(deffoo nnsoup-request-list (&optional server)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (unless nnsoup-group-alist
+      (nnsoup-read-active-file))
+    (let ((alist nnsoup-group-alist)
+	  (standard-output (current-buffer))
+	  entry)
+      (while (setq entry (pop alist))
+	(insert (car entry) " ")
+	(princ (cdadr entry))
+	(insert " ")
+	(princ (caadr entry))
+	(insert " y\n"))
+      t)))
+
+(deffoo nnsoup-request-scan (group &optional server)
+  (nnsoup-unpack-packets))
+
+(deffoo nnsoup-request-newgroups (date &optional server)
+  (nnsoup-request-list))
+
+(deffoo nnsoup-request-list-newsgroups (&optional server)
+  nil)
+
+(deffoo nnsoup-request-post (&optional server)
+  (nnsoup-store-reply "news")
+  t)
+
+(deffoo nnsoup-request-mail (&optional server)
+  (nnsoup-store-reply "mail")
+  t)
+
+(deffoo nnsoup-request-expire-articles (articles group &optional server force)
+  (nnsoup-possibly-change-group group)
+  (let* ((total-infolist (assoc group nnsoup-group-alist))
+	 (active (cadr total-infolist))
+	 (infolist (cddr total-infolist))
+	 info range-list mod-time prefix)
+    (while infolist
+      (setq info (pop infolist)
+	    range-list (gnus-uncompress-range (car info))
+	    prefix (gnus-soup-area-prefix (nth 1 info)))
+      (when ;; All the articles in this file are marked for expiry.
+	  (and (or (setq mod-time (nth 5 (file-attributes
+					  (nnsoup-file prefix))))
+		   (setq mod-time (nth 5 (file-attributes
+					  (nnsoup-file prefix t)))))
+	       (gnus-sublist-p articles range-list)
+	       ;; This file is old enough.
+	       (nnmail-expired-article-p group mod-time force))
+	;; Ok, we delete this file.
+	(when (ignore-errors
+		(nnheader-message
+		 5 "Deleting %s in group %s..." (nnsoup-file prefix)
+		 group)
+		(when (file-exists-p (nnsoup-file prefix))
+		  (delete-file (nnsoup-file prefix)))
+		(nnheader-message
+		 5 "Deleting %s in group %s..." (nnsoup-file prefix t)
+		 group)
+		(when (file-exists-p (nnsoup-file prefix t))
+		  (delete-file (nnsoup-file prefix t)))
+		t)
+	  (setcdr (cdr total-infolist) (delq info (cddr total-infolist)))
+	  (setq articles (gnus-sorted-complement articles range-list))))
+      (when (not mod-time)
+	(setcdr (cdr total-infolist) (delq info (cddr total-infolist)))))
+    (if (cddr total-infolist)
+	(setcar active (caaadr (cdr total-infolist)))
+      (setcar active (1+ (cdr active))))
+    (nnsoup-write-active-file t)
+    ;; Return the articles that weren't expired.
+    articles))
+
+
+;;; Internal functions
+
+(defun nnsoup-possibly-change-group (group &optional force)
+  (when (and group
+	     (not (equal nnsoup-current-group group)))
+    (setq nnsoup-article-alist nil)
+    (setq nnsoup-current-group group))
+  t)
+
+(defun nnsoup-read-active-file ()
+  (setq nnsoup-group-alist nil)
+  (when (file-exists-p nnsoup-active-file)
+    (ignore-errors
+      (load nnsoup-active-file t t t))
+    ;; Be backwards compatible.
+    (when (and nnsoup-group-alist
+	       (not (atom (caadar nnsoup-group-alist))))
+      (let ((alist nnsoup-group-alist)
+	    entry e min max)
+	(while (setq e (cdr (setq entry (pop alist))))
+	  (setq min (caaar e))
+	  (while (cdr e)
+	    (setq e (cdr e)))
+	  (setq max (cdaar e))
+	  (setcdr entry (cons (cons min max) (cdr entry)))))
+      (setq nnsoup-group-alist-touched t))
+    nnsoup-group-alist))
+
+(defun nnsoup-write-active-file (&optional force)
+  (when (and nnsoup-group-alist
+	     (or force
+		 nnsoup-group-alist-touched))
+    (setq nnsoup-group-alist-touched nil)
+    (nnheader-temp-write nnsoup-active-file
+      (gnus-prin1 `(setq nnsoup-group-alist ',nnsoup-group-alist))
+      (insert "\n")
+      (gnus-prin1 `(setq nnsoup-current-prefix ,nnsoup-current-prefix))
+      (insert "\n"))))
+
+(defun nnsoup-next-prefix ()
+  "Return the next free prefix."
+  (let (prefix)
+    (while (or (file-exists-p
+		(nnsoup-file (setq prefix (int-to-string
+					   nnsoup-current-prefix))))
+	       (file-exists-p (nnsoup-file prefix t)))
+      (incf nnsoup-current-prefix))
+    (incf nnsoup-current-prefix)
+    prefix))
+
+(defun nnsoup-file-name (dir file)
+  "Return the full path of FILE (in any case) in DIR."
+  (let* ((case-fold-search t)
+	 (files (directory-files dir t))
+	 (regexp (concat (regexp-quote file) "$")))
+    (car (delq nil
+	       (mapcar
+		(lambda (file)
+		  (if (string-match regexp file)
+		      file
+		    nil))
+		files)))))
+
+(defun nnsoup-read-areas ()
+  (let ((areas-file (nnsoup-file-name nnsoup-tmp-directory "areas")))
+    (when areas-file
+      (save-excursion
+	(set-buffer nntp-server-buffer)
+	(let ((areas (gnus-soup-parse-areas areas-file))
+	      entry number area lnum cur-prefix file)
+	  ;; Go through all areas in the new AREAS file.
+	  (while (setq area (pop areas))
+	    ;; Change the name to the permanent name and move the files.
+	    (setq cur-prefix (nnsoup-next-prefix))
+	    (message "Incorporating file %s..." cur-prefix)
+	    (when (file-exists-p
+		   (setq file (concat nnsoup-tmp-directory
+				      (gnus-soup-area-prefix area) ".IDX")))
+	      (rename-file file (nnsoup-file cur-prefix)))
+	    (when (file-exists-p
+		   (setq file (concat nnsoup-tmp-directory
+				      (gnus-soup-area-prefix area) ".MSG")))
+	      (rename-file file (nnsoup-file cur-prefix t))
+	      (gnus-soup-set-area-prefix area cur-prefix)
+	      ;; Find the number of new articles in this area.
+	      (setq number (nnsoup-number-of-articles area))
+	      (if (not (setq entry (assoc (gnus-soup-area-name area)
+					  nnsoup-group-alist)))
+		  ;; If this is a new area (group), we just add this info to
+		  ;; the group alist.
+		  (push (list (gnus-soup-area-name area)
+			      (cons 1 number)
+			      (list (cons 1 number) area))
+			nnsoup-group-alist)
+		;; There are already articles in this group, so we add this
+		;; info to the end of the entry.
+		(nconc entry (list (list (cons (1+ (setq lnum (cdadr entry)))
+					       (+ lnum number))
+					 area)))
+		(setcdr (cadr entry) (+ lnum number))))))
+	(nnsoup-write-active-file t)
+	(delete-file areas-file)))))
+
+(defun nnsoup-number-of-articles (area)
+  (save-excursion
+    (cond
+     ;; If the number is in the area info, we just return it.
+     ((gnus-soup-area-number area)
+      (gnus-soup-area-number area))
+     ;; If there is an index file, we just count the lines.
+     ((/= (gnus-soup-encoding-index (gnus-soup-area-encoding area)) ?n)
+      (set-buffer (nnsoup-index-buffer (gnus-soup-area-prefix area)))
+      (count-lines (point-min) (point-max)))
+     ;; We do it the hard way - re-searching through the message
+     ;; buffer.
+     (t
+      (set-buffer (nnsoup-message-buffer (gnus-soup-area-prefix area)))
+      (unless (assoc (gnus-soup-area-prefix area) nnsoup-article-alist)
+	(nnsoup-dissect-buffer area))
+      (length (cdr (assoc (gnus-soup-area-prefix area)
+			  nnsoup-article-alist)))))))
+
+(defun nnsoup-dissect-buffer (area)
+  (let ((mbox-delim (concat "^" message-unix-mail-delimiter))
+	(format (gnus-soup-encoding-format (gnus-soup-area-encoding area)))
+	(i 0)
+	alist len)
+    (goto-char (point-min))
+    (cond
+     ;; rnews batch format
+     ((= format ?n)
+      (while (looking-at "^#! *rnews \\(+[0-9]+\\) *$")
+	(forward-line 1)
+	(push (list
+	       (incf i) (point)
+	       (progn
+		 (forward-char (string-to-number (match-string 1)))
+		 (point)))
+	      alist)))
+     ;; Unix mbox format
+     ((= format ?m)
+      (while (looking-at mbox-delim)
+	(forward-line 1)
+	(push (list
+	       (incf i) (point)
+	       (progn
+		 (if (re-search-forward mbox-delim nil t)
+		     (beginning-of-line)
+		   (goto-char (point-max)))
+		 (point)))
+	      alist)))
+     ;; MMDF format
+     ((= format ?M)
+      (while (looking-at "\^A\^A\^A\^A\n")
+	(forward-line 1)
+	(push (list
+	       (incf i) (point)
+	       (progn
+		 (if (search-forward "\n\^A\^A\^A\^A\n" nil t)
+		     (beginning-of-line)
+		   (goto-char (point-max)))
+		 (point)))
+	      alist)))
+     ;; Binary format
+     ((or (= format ?B) (= format ?b))
+      (while (not (eobp))
+	(setq len (+ (* (char-after (point)) (expt 2.0 24))
+		     (* (char-after (+ (point) 1)) (expt 2 16))
+		     (* (char-after (+ (point) 2)) (expt 2 8))
+		     (char-after (+ (point) 3))))
+	(push (list
+	       (incf i) (+ (point) 4)
+	       (progn
+		 (forward-char (floor (+ len 4)))
+		 (point)))
+	      alist)))
+     (t
+      (error "Unknown format: %c" format)))
+    (push (cons (gnus-soup-area-prefix area) alist) nnsoup-article-alist)))
+
+(defun nnsoup-index-buffer (prefix &optional message)
+  (let* ((file (concat prefix (if message ".MSG" ".IDX")))
+	 (buffer-name (concat " *nnsoup " file "*")))
+    (or (get-buffer buffer-name)	; File already loaded.
+	(when (file-exists-p (concat nnsoup-directory file))
+	  (save-excursion		; Load the file.
+	    (set-buffer (get-buffer-create buffer-name))
+	    (buffer-disable-undo (current-buffer))
+	    (push (cons nnsoup-current-group (current-buffer)) nnsoup-buffers)
+	    (nnheader-insert-file-contents (concat nnsoup-directory file))
+	    (current-buffer))))))
+
+(defun nnsoup-file (prefix &optional message)
+  (expand-file-name
+   (concat nnsoup-directory prefix (if message ".MSG" ".IDX"))))
+
+(defun nnsoup-message-buffer (prefix)
+  (nnsoup-index-buffer prefix 'msg))
+
+(defun nnsoup-unpack-packets ()
+  "Unpack all packets in `nnsoup-packet-directory'."
+  (let ((packets (directory-files
+		  nnsoup-packet-directory t nnsoup-packet-regexp))
+	packet)
+    (while (setq packet (pop packets))
+      (message "nnsoup: unpacking %s..." packet)
+      (if (not (gnus-soup-unpack-packet
+		nnsoup-tmp-directory nnsoup-unpacker packet))
+	  (message "Couldn't unpack %s" packet)
+	(delete-file packet)
+	(nnsoup-read-areas)
+	(message "Unpacking...done")))))
+
+(defun nnsoup-narrow-to-article (article &optional area head)
+  (let* ((area (or area (nnsoup-article-to-area article nnsoup-current-group)))
+	 (prefix (and area (gnus-soup-area-prefix (nth 1 area))))
+	 (msg-buf (and prefix (nnsoup-index-buffer prefix 'msg)))
+	 beg end)
+    (when area
+      (save-excursion
+	(cond
+	 ;; There is no MSG file.
+	 ((null msg-buf)
+	  nil)
+	 ;; We use the index file to find out where the article
+	 ;; begins and ends.
+	 ((and (= (gnus-soup-encoding-index
+		   (gnus-soup-area-encoding (nth 1 area)))
+		  ?c)
+	       (file-exists-p (nnsoup-file prefix)))
+	  (set-buffer (nnsoup-index-buffer prefix))
+	  (widen)
+	  (goto-char (point-min))
+	  (forward-line (- article (caar area)))
+	  (setq beg (read (current-buffer)))
+	  (forward-line 1)
+	  (if (looking-at "[0-9]+")
+	      (progn
+		(setq end (read (current-buffer)))
+		(set-buffer msg-buf)
+		(widen)
+		(let ((format (gnus-soup-encoding-format
+			       (gnus-soup-area-encoding (nth 1 area)))))
+		  (goto-char end)
+		  (when (or (= format ?n) (= format ?m))
+		    (setq end (progn (forward-line -1) (point))))))
+	    (set-buffer msg-buf))
+	  (widen)
+	  (narrow-to-region beg (or end (point-max))))
+	 (t
+	  (set-buffer msg-buf)
+	  (widen)
+	  (unless (assoc (gnus-soup-area-prefix (nth 1 area))
+			 nnsoup-article-alist)
+	    (nnsoup-dissect-buffer (nth 1 area)))
+	  (let ((entry (assq article (cdr (assoc (gnus-soup-area-prefix
+						  (nth 1 area))
+						 nnsoup-article-alist)))))
+	    (when entry
+	      (narrow-to-region (cadr entry) (caddr entry))))))
+	(goto-char (point-min))
+	(if (not head)
+	    ()
+	  (narrow-to-region
+	   (point-min)
+	   (if (search-forward "\n\n" nil t)
+	       (1- (point))
+	     (point-max))))
+	msg-buf))))
+
+;;;###autoload
+(defun nnsoup-pack-replies ()
+  "Make an outbound package of SOUP replies."
+  (interactive)
+  (unless (file-exists-p nnsoup-replies-directory)
+    (message "No such directory: %s" nnsoup-replies-directory))
+  ;; Write all data buffers.
+  (gnus-soup-save-areas)
+  ;; Write the active file.
+  (nnsoup-write-active-file)
+  ;; Write the REPLIES file.
+  (nnsoup-write-replies)
+  ;; Check whether there is anything here.
+  (when (null (directory-files nnsoup-replies-directory nil "\\.MSG$"))
+    (error "No files to pack."))
+  ;; Pack all these files into a SOUP packet.
+  (gnus-soup-pack nnsoup-replies-directory nnsoup-packer))
+
+(defun nnsoup-write-replies ()
+  "Write the REPLIES file."
+  (when nnsoup-replies-list
+    (gnus-soup-write-replies nnsoup-replies-directory nnsoup-replies-list)
+    (setq nnsoup-replies-list nil)))
+
+(defun nnsoup-article-to-area (article group)
+  "Return the area that ARTICLE in GROUP is located in."
+  (let ((areas (cddr (assoc group nnsoup-group-alist))))
+    (while (and areas (< (cdaar areas) article))
+      (setq areas (cdr areas)))
+    (and areas (car areas))))
+
+(defvar nnsoup-old-functions
+  (list message-send-mail-function message-send-news-function))
+
+;;;###autoload
+(defun nnsoup-set-variables ()
+  "Use the SOUP methods for posting news and mailing mail."
+  (interactive)
+  (setq message-send-news-function 'nnsoup-request-post)
+  (setq message-send-mail-function 'nnsoup-request-mail))
+
+;;;###autoload
+(defun nnsoup-revert-variables ()
+  "Revert posting and mailing methods to the standard Emacs methods."
+  (interactive)
+  (setq message-send-mail-function (car nnsoup-old-functions))
+  (setq message-send-news-function (cadr nnsoup-old-functions)))
+
+(defun nnsoup-store-reply (kind)
+  ;; Mostly stolen from `message.el'.
+  (require 'mail-utils)
+  (let ((tembuf (generate-new-buffer " message temp"))
+	(case-fold-search nil)
+	delimline
+	(mailbuf (current-buffer)))
+    (unwind-protect
+	(save-excursion
+	  (save-restriction
+	    (message-narrow-to-headers)
+	    (if (equal kind "mail")
+		(message-generate-headers message-required-mail-headers)
+	      (message-generate-headers message-required-news-headers)))
+	  (set-buffer tembuf)
+	  (erase-buffer)
+	  (insert-buffer-substring mailbuf)
+	  ;; Remove some headers.
+	  (save-restriction
+	    (message-narrow-to-headers)
+	    ;; Remove some headers.
+	    (message-remove-header message-ignored-mail-headers t))
+	  (goto-char (point-max))
+	  ;; require one newline at the end.
+	  (or (= (preceding-char) ?\n)
+	      (insert ?\n))
+	  (let ((case-fold-search t))
+	    ;; Change header-delimiter to be what sendmail expects.
+	    (goto-char (point-min))
+	    (re-search-forward
+	     (concat "^" (regexp-quote mail-header-separator) "\n"))
+	    (replace-match "\n")
+	    (backward-char 1)
+	    (setq delimline (point-marker))
+	    ;; Insert an extra newline if we need it to work around
+	    ;; Sun's bug that swallows newlines.
+	    (goto-char (1+ delimline))
+	    (when (eval message-mailer-swallows-blank-line)
+	      (newline))
+	    (let ((msg-buf
+		   (gnus-soup-store
+		    nnsoup-replies-directory
+		    (nnsoup-kind-to-prefix kind) nil nnsoup-replies-format-type
+		    nnsoup-replies-index-type))
+		  (num 0))
+	      (when (and msg-buf (bufferp msg-buf))
+		(save-excursion
+		  (set-buffer msg-buf)
+		  (goto-char (point-min))
+		  (while (re-search-forward "^#! *rnews" nil t)
+		    (incf num)))
+		(message "Stored %d messages" num)))
+	    (nnsoup-write-replies)
+	    (kill-buffer tembuf))))))
+
+(defun nnsoup-kind-to-prefix (kind)
+  (unless nnsoup-replies-list
+    (setq nnsoup-replies-list
+	  (gnus-soup-parse-replies
+	   (concat nnsoup-replies-directory "REPLIES"))))
+  (let ((replies nnsoup-replies-list))
+    (while (and replies
+		(not (string= kind (gnus-soup-reply-kind (car replies)))))
+      (setq replies (cdr replies)))
+    (if replies
+	(gnus-soup-reply-prefix (car replies))
+      (push (vector (gnus-soup-unique-prefix nnsoup-replies-directory)
+		    kind
+		    (format "%c%c%c"
+			    nnsoup-replies-format-type
+			    nnsoup-replies-index-type
+			    (if (string= kind "news")
+				?n ?m)))
+	    nnsoup-replies-list)
+      (gnus-soup-reply-prefix (car nnsoup-replies-list)))))
+
+(defun nnsoup-make-active ()
+  "(Re-)create the SOUP active file."
+  (interactive)
+  (let ((files (sort (directory-files nnsoup-directory t "IDX$")
+		     (lambda (f1 f2)
+		       (< (progn (string-match "/\\([0-9]+\\)\\." f1)
+				 (string-to-int (match-string 1 f1)))
+			  (progn (string-match "/\\([0-9]+\\)\\." f2)
+				 (string-to-int (match-string 1 f2)))))))
+	active group lines ident elem min)
+    (set-buffer (get-buffer-create " *nnsoup work*"))
+    (buffer-disable-undo (current-buffer))
+    (while files
+      (message "Doing %s..." (car files))
+      (erase-buffer)
+      (nnheader-insert-file-contents (car files))
+      (goto-char (point-min))
+      (if (not (re-search-forward "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t *\\(Xref: \\)? *[^ ]* \\([^ ]+\\):[0-9]" nil t))
+	  (setq group "unknown")
+	(setq group (match-string 2)))
+      (setq lines (count-lines (point-min) (point-max)))
+      (setq ident (progn (string-match
+			  "/\\([0-9]+\\)\\." (car files))
+			 (substring
+			  (car files) (match-beginning 1)
+			  (match-end 1))))
+      (if (not (setq elem (assoc group active)))
+	  (push (list group (cons 1 lines)
+		      (list (cons 1 lines)
+			    (vector ident group "ncm" "" lines)))
+		active)
+	(nconc elem
+	       (list
+		(list (cons (1+ (setq min (cdadr elem)))
+			    (+ min lines))
+		      (vector ident group "ncm" "" lines))))
+	(setcdr (cadr elem) (+ min lines)))
+      (setq files (cdr files)))
+    (message "")
+    (setq nnsoup-group-alist active)
+    (nnsoup-write-active-file t)))
+
+(defun nnsoup-delete-unreferenced-message-files ()
+  "Delete any *.MSG and *.IDX files that aren't known by nnsoup."
+  (interactive)
+  (let* ((known (apply 'nconc (mapcar
+			       (lambda (ga)
+				 (mapcar
+				  (lambda (area)
+				    (gnus-soup-area-prefix (cadr area)))
+				  (cddr ga)))
+			       nnsoup-group-alist)))
+	 (regexp "\\.MSG$\\|\\.IDX$")
+	 (files (directory-files nnsoup-directory nil regexp))
+	 non-files file)
+    ;; Find all files that aren't known by nnsoup.
+    (while (setq file (pop files))
+      (string-match regexp file)
+      (unless (member (substring file 0 (match-beginning 0)) known)
+	(push file non-files)))
+    ;; Sort and delete the files.
+    (setq non-files (sort non-files 'string<))
+    (map-y-or-n-p "Delete file %s? "
+		  (lambda (file) (delete-file (concat nnsoup-directory file)))
+		  non-files)))
+
+(provide 'nnsoup)
+
+;;; nnsoup.el ends here

lisp/gnus/nnspool.el

@@ -0,0 +1,463 @@
+;;; nnspool.el --- spool access for GNU Emacs
+;; Copyright (C) 1988,89,90,93,94,95,96,97 Free Software Foundation, Inc.
+
+;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; 	Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nntp)
+(require 'timezone)
+(require 'nnoo)
+(eval-when-compile (require 'cl))
+
+(nnoo-declare nnspool)
+
+(defvoo nnspool-inews-program news-inews-program
+  "Program to post news.
+This is most commonly `inews' or `injnews'.")
+
+(defvoo nnspool-inews-switches '("-h" "-S")
+  "Switches for nnspool-request-post to pass to `inews' for posting news.
+If you are using Cnews, you probably should set this variable to nil.")
+
+(defvoo nnspool-spool-directory (file-name-as-directory news-path)
+  "Local news spool directory.")
+
+(defvoo nnspool-nov-directory (concat nnspool-spool-directory "over.view/")
+  "Local news nov directory.")
+
+(defvoo nnspool-lib-dir "/usr/lib/news/"
+  "Where the local news library files are stored.")
+
+(defvoo nnspool-active-file (concat nnspool-lib-dir "active")
+  "Local news active file.")
+
+(defvoo nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups")
+  "Local news newsgroups file.")
+
+(defvoo nnspool-distributions-file (concat nnspool-lib-dir "distribs.pat")
+  "Local news distributions file.")
+
+(defvoo nnspool-history-file (concat nnspool-lib-dir "history")
+  "Local news history file.")
+
+(defvoo nnspool-active-times-file (concat nnspool-lib-dir "active.times")
+  "Local news active date file.")
+
+(defvoo nnspool-large-newsgroup 50
+  "The number of the articles which indicates a large newsgroup.
+If the number of the articles is greater than the value, verbose
+messages will be shown to indicate the current status.")
+
+(defvoo nnspool-nov-is-evil nil
+  "Non-nil means that nnspool will never return NOV lines instead of headers.")
+
+(defconst nnspool-sift-nov-with-sed nil
+  "If non-nil, use sed to get the relevant portion from the overview file.
+If nil, nnspool will load the entire file into a buffer and process it
+there.")
+
+(defvoo nnspool-rejected-article-hook nil
+  "*A hook that will be run when an article has been rejected by the server.")
+
+
+
+(defconst nnspool-version "nnspool 2.0"
+  "Version numbers of this version of NNSPOOL.")
+
+(defvoo nnspool-current-directory nil
+  "Current news group directory.")
+
+(defvoo nnspool-current-group nil)
+(defvoo nnspool-status-string "")
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nnspool)
+
+(deffoo nnspool-retrieve-headers (articles &optional group server fetch-old)
+  "Retrieve the headers of ARTICLES."
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (when (nnspool-possibly-change-directory group)
+      (let* ((number (length articles))
+	     (count 0)
+	     (default-directory nnspool-current-directory)
+	     (do-message (and (numberp nnspool-large-newsgroup)
+			      (> number nnspool-large-newsgroup)))
+	     file beg article ag)
+	(if (and (numberp (car articles))
+		 (nnspool-retrieve-headers-with-nov articles fetch-old))
+	    ;; We successfully retrieved the NOV headers.
+	    'nov
+	  ;; No NOV headers here, so we do it the hard way.
+	  (while (setq article (pop articles))
+	    (if (stringp article)
+		;; This is a Message-ID.
+		(setq ag (nnspool-find-id article)
+		      file (and ag (nnspool-article-pathname
+				    (car ag) (cdr ag)))
+		      article (cdr ag))
+	      ;; This is an article in the current group.
+	      (setq file (int-to-string article)))
+	    ;; Insert the head of the article.
+	    (when (and file
+		       (file-exists-p file))
+	      (insert "221 ")
+	      (princ article (current-buffer))
+	      (insert " Article retrieved.\n")
+	      (setq beg (point))
+	      (inline (nnheader-insert-head file))
+	      (goto-char beg)
+	      (search-forward "\n\n" nil t)
+	      (forward-char -1)
+	      (insert ".\n")
+	      (delete-region (point) (point-max)))
+
+	    (and do-message
+		 (zerop (% (incf count) 20))
+		 (message "nnspool: Receiving headers... %d%%"
+			  (/ (* count 100) number))))
+
+	  (when do-message
+	    (message "nnspool: Receiving headers...done"))
+
+	  ;; Fold continuation lines.
+	  (nnheader-fold-continuation-lines)
+	  'headers)))))
+
+(deffoo nnspool-open-server (server &optional defs)
+  (nnoo-change-server 'nnspool server defs)
+  (cond
+   ((not (file-exists-p nnspool-spool-directory))
+    (nnspool-close-server)
+    (nnheader-report 'nnspool "Spool directory doesn't exist: %s"
+		     nnspool-spool-directory))
+   ((not (file-directory-p
+	  (directory-file-name
+	   (file-truename nnspool-spool-directory))))
+    (nnspool-close-server)
+    (nnheader-report 'nnspool "Not a directory: %s" nnspool-spool-directory))
+   ((not (file-exists-p nnspool-active-file))
+    (nnheader-report 'nnspool "The active file doesn't exist: %s"
+		     nnspool-active-file))
+   (t
+    (nnheader-report 'nnspool "Opened server %s using directory %s"
+		     server nnspool-spool-directory)
+    t)))
+
+(deffoo nnspool-request-article (id &optional group server buffer)
+  "Select article by message ID (or number)."
+  (nnspool-possibly-change-directory group)
+  (let ((nntp-server-buffer (or buffer nntp-server-buffer))
+	file ag)
+    (if (stringp id)
+	;; This is a Message-ID.
+	(when (setq ag (nnspool-find-id id))
+	  (setq file (nnspool-article-pathname (car ag) (cdr ag))))
+      (setq file (nnspool-article-pathname nnspool-current-group id)))
+    (and file
+	 (file-exists-p file)
+	 (not (file-directory-p file))
+	 (save-excursion (nnspool-find-file file))
+	 ;; We return the article number and group name.
+	 (if (numberp id)
+	     (cons nnspool-current-group id)
+	   ag))))
+
+(deffoo nnspool-request-body (id &optional group server)
+  "Select article body by message ID (or number)."
+  (nnspool-possibly-change-directory group)
+  (let ((res (nnspool-request-article id)))
+    (when res
+      (save-excursion
+	(set-buffer nntp-server-buffer)
+	(goto-char (point-min))
+	(when (search-forward "\n\n" nil t)
+	  (delete-region (point-min) (point)))
+	res))))
+
+(deffoo nnspool-request-head (id &optional group server)
+  "Select article head by message ID (or number)."
+  (nnspool-possibly-change-directory group)
+  (let ((res (nnspool-request-article id)))
+    (when res
+      (save-excursion
+	(set-buffer nntp-server-buffer)
+	(goto-char (point-min))
+	(when (search-forward "\n\n" nil t)
+	  (delete-region (1- (point)) (point-max)))
+	(nnheader-fold-continuation-lines)))
+    res))
+
+(deffoo nnspool-request-group (group &optional server dont-check)
+  "Select news GROUP."
+  (let ((pathname (nnspool-article-pathname group))
+	dir)
+    (if (not (file-directory-p pathname))
+	(nnheader-report
+	 'nnspool "Invalid group name (no such directory): %s" group)
+      (setq nnspool-current-directory pathname)
+      (nnheader-report 'nnspool "Selected group %s" group)
+      (if dont-check
+	  (progn
+	    (nnheader-report 'nnspool "Selected group %s" group)
+	    t)
+	;; Yes, completely empty spool directories *are* possible.
+	;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
+	(when (setq dir (directory-files pathname nil "^[0-9]+$" t))
+	  (setq dir
+		(sort (mapcar (lambda (name) (string-to-int name)) dir) '<)))
+	(if dir
+	    (nnheader-insert
+	     "211 %d %d %d %s\n" (length dir) (car dir)
+	     (progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
+	     group)
+	  (nnheader-report 'nnspool "Empty group %s" group)
+	  (nnheader-insert "211 0 0 0 %s\n" group))))))
+
+(deffoo nnspool-request-type (group &optional article)
+  'news)
+
+(deffoo nnspool-close-group (group &optional server)
+  t)
+
+(deffoo nnspool-request-list (&optional server)
+  "List active newsgroups."
+  (save-excursion
+    (or (nnspool-find-file nnspool-active-file)
+	(nnheader-report 'nnspool (nnheader-file-error nnspool-active-file)))))
+
+(deffoo nnspool-request-list-newsgroups (&optional server)
+  "List newsgroups (defined in NNTP2)."
+  (save-excursion
+    (or (nnspool-find-file nnspool-newsgroups-file)
+	(nnheader-report 'nnspool (nnheader-file-error
+				   nnspool-newsgroups-file)))))
+
+(deffoo nnspool-request-list-distributions (&optional server)
+  "List distributions (defined in NNTP2)."
+  (save-excursion
+    (or (nnspool-find-file nnspool-distributions-file)
+	(nnheader-report 'nnspool (nnheader-file-error
+				   nnspool-distributions-file)))))
+
+;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
+(deffoo nnspool-request-newgroups (date &optional server)
+  "List groups created after DATE."
+  (if (nnspool-find-file nnspool-active-times-file)
+      (save-excursion
+	;; Find the last valid line.
+	(goto-char (point-max))
+	(while (and (not (looking-at
+			  "\\([^ ]+\\) +\\([0-9]+\\)[0-9][0-9][0-9] "))
+		    (zerop (forward-line -1))))
+	(let ((seconds (nnspool-seconds-since-epoch date))
+	      groups)
+	  ;; Go through lines and add the latest groups to a list.
+	  (while (and (looking-at "\\([^ ]+\\) +[0-9]+ ")
+		      (progn
+			;; We insert a .0 to make the list reader
+			;; interpret the number as a float.  It is far
+			;; too big to be stored in a lisp integer.
+			(goto-char (1- (match-end 0)))
+			(insert ".0")
+			(> (progn
+			     (goto-char (match-end 1))
+			     (read (current-buffer)))
+			   seconds))
+		      (push (buffer-substring
+					  (match-beginning 1) (match-end 1))
+					 groups)
+		      (zerop (forward-line -1))))
+	  (erase-buffer)
+	  (while groups
+	    (insert (car groups) " 0 0 y\n")
+	    (setq groups (cdr groups))))
+	t)
+    nil))
+
+(deffoo nnspool-request-post (&optional server)
+  "Post a new news in current buffer."
+  (save-excursion
+    (let* ((process-connection-type nil) ; t bugs out on Solaris
+	   (inews-buffer (generate-new-buffer " *nnspool post*"))
+	   (proc
+	    (condition-case err
+		(apply 'start-process "*nnspool inews*" inews-buffer
+		       nnspool-inews-program nnspool-inews-switches)
+	      (error
+	       (nnheader-report 'nnspool "inews error: %S" err)))))
+      (if (not proc)
+	  ;; The inews program failed.
+	  ()
+	(nnheader-report 'nnspool "")
+	(set-process-sentinel proc 'nnspool-inews-sentinel)
+	(process-send-region proc (point-min) (point-max))
+	;; We slap a condition-case around this, because the process may
+	;; have exited already...
+	(ignore-errors
+	  (process-send-eof proc))
+	t))))
+
+
+
+;;; Internal functions.
+
+(defun nnspool-inews-sentinel (proc status)
+  (save-excursion
+    (set-buffer (process-buffer proc))
+    (goto-char (point-min))
+    (if (or (zerop (buffer-size))
+	    (search-forward "spooled" nil t))
+	(kill-buffer (current-buffer))
+      ;; Make status message by folding lines.
+      (while (re-search-forward "[ \t\n]+" nil t)
+	(replace-match " " t t))
+      (nnheader-report 'nnspool "%s" (buffer-string))
+      (message "nnspool: %s" nnspool-status-string)
+      (ding)
+      (run-hooks 'nnspool-rejected-article-hook))))
+
+(defun nnspool-retrieve-headers-with-nov (articles &optional fetch-old)
+  (if (or gnus-nov-is-evil nnspool-nov-is-evil)
+      nil
+    (let ((nov (nnheader-group-pathname
+		nnspool-current-group nnspool-nov-directory ".overview"))
+	  (arts articles)
+	  last)
+      (if (not (file-exists-p nov))
+	  ()
+	(save-excursion
+	  (set-buffer nntp-server-buffer)
+	  (erase-buffer)
+	  (if nnspool-sift-nov-with-sed
+	      (nnspool-sift-nov-with-sed articles nov)
+	    (nnheader-insert-file-contents nov)
+	    (if (and fetch-old
+		     (not (numberp fetch-old)))
+		t			; We want all the headers.
+	      (ignore-errors
+		;; Delete unwanted NOV lines.
+		(nnheader-nov-delete-outside-range
+		 (if fetch-old (max 1 (- (car articles) fetch-old))
+		   (car articles))
+		 (car (last articles)))
+		;; If the buffer is empty, this wasn't very successful.
+		(unless (zerop (buffer-size))
+		  ;; We check what the last article number was.
+		  ;; The NOV file may be out of sync with the articles
+		  ;; in the group.
+		  (forward-line -1)
+		  (setq last (read (current-buffer)))
+		  (if (= last (car articles))
+		      ;; Yup, it's all there.
+		      t
+		    ;; Perhaps not.  We try to find the missing articles.
+		    (while (and arts
+				(<= last (car arts)))
+		      (pop arts))
+		    ;; The articles in `arts' are missing from the buffer.
+		    (while arts
+		      (nnspool-insert-nov-head (pop arts)))
+		    t))))))))))
+
+(defun nnspool-insert-nov-head (article)
+  "Read the head of ARTICLE, convert to NOV headers, and insert."
+  (save-excursion
+    (let ((cur (current-buffer))
+	  buf)
+      (setq buf (nnheader-set-temp-buffer " *nnspool head*"))
+      (when (nnheader-insert-head
+	     (nnspool-article-pathname nnspool-current-group article))
+	(nnheader-insert-article-line article)
+	(let ((headers (nnheader-parse-head)))
+	  (set-buffer cur)
+	  (goto-char (point-max))
+	  (nnheader-insert-nov headers)))
+      (kill-buffer buf))))
+
+(defun nnspool-sift-nov-with-sed (articles file)
+  (let ((first (car articles))
+	(last (progn (while (cdr articles) (setq articles (cdr articles)))
+		     (car articles))))
+    (call-process "awk" nil t nil
+		  (format "BEGIN {firstmsg=%d; lastmsg=%d;}\n $1 >= firstmsg && $1 <= lastmsg {print;}"
+			  (1- first) (1+ last))
+		  file)))
+
+;; Fixed by fdc@cliwe.ping.de (Frank D. Cringle).
+;; Find out what group an article identified by a Message-ID is in.
+(defun nnspool-find-id (id)
+  (save-excursion
+    (set-buffer (get-buffer-create " *nnspool work*"))
+    (buffer-disable-undo (current-buffer))
+    (erase-buffer)
+    (ignore-errors
+      (call-process "grep" nil t nil (regexp-quote id) nnspool-history-file))
+    (goto-char (point-min))
+    (prog1
+	(when (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ /\t\n]+\\)/\\([0-9]+\\)[ \t\n]")
+	  (cons (match-string 1) (string-to-int (match-string 2))))
+      (kill-buffer (current-buffer)))))
+
+(defun nnspool-find-file (file)
+  "Insert FILE in server buffer safely."
+  (set-buffer nntp-server-buffer)
+  (erase-buffer)
+  (condition-case ()
+      (progn (nnheader-insert-file-contents file) t)
+    (file-error nil)))
+
+(defun nnspool-possibly-change-directory (group)
+  (if (not group)
+      t
+    (let ((pathname (nnspool-article-pathname group)))
+      (if (file-directory-p pathname)
+	  (setq nnspool-current-directory pathname
+		nnspool-current-group group)
+	(nnheader-report 'nnspool "No such newsgroup: %s" group)))))
+
+(defun nnspool-article-pathname (group &optional article)
+  "Find the path for GROUP."
+  (nnheader-group-pathname group nnspool-spool-directory article))
+
+(defun nnspool-seconds-since-epoch (date)
+  (let* ((tdate (mapcar (lambda (ti) (and ti (string-to-int ti)))
+			(timezone-parse-date date)))
+	 (ttime (mapcar (lambda (ti) (and ti (string-to-int ti)))
+			(timezone-parse-time
+			 (aref (timezone-parse-date date) 3))))
+	 (unix (encode-time (nth 2 ttime) (nth 1 ttime) (nth 0 ttime)
+			    (nth 2 tdate) (nth 1 tdate) (nth 0 tdate)
+			    (nth 4 tdate))))
+    (+ (* (car unix) 65536.0)
+       (cadr unix))))
+
+(provide 'nnspool)
+
+;;; nnspool.el ends here

lisp/gnus/nnvirtual.el

@@ -0,0 +1,766 @@
+;;; nnvirtual.el --- virtual newsgroups access for Gnus
+;; Copyright (C) 1994,95,96,97 Free Software Foundation, Inc.
+
+;; Author: David Moore <dmoore@ucsd.edu>
+;;	Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; 	Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; The other access methods (nntp, nnspool, etc) are general news
+;; access methods.  This module relies on Gnus and can not be used
+;; separately.
+
+;;; Code:
+
+(require 'nntp)
+(require 'nnheader)
+(require 'gnus)
+(require 'nnoo)
+(require 'gnus-util)
+(require 'gnus-start)
+(require 'gnus-sum)
+(eval-when-compile (require 'cl))
+
+(nnoo-declare nnvirtual)
+
+(defvoo nnvirtual-always-rescan nil
+  "*If non-nil, always scan groups for unread articles when entering a group.
+If this variable is nil (which is the default) and you read articles
+in a component group after the virtual group has been activated, the
+read articles from the component group will show up when you enter the
+virtual group.")
+
+(defvoo nnvirtual-component-regexp nil
+  "*Regexp to match component groups.")
+
+(defvoo nnvirtual-component-groups nil
+  "Component group in this nnvirtual group.")
+
+
+
+(defconst nnvirtual-version "nnvirtual 1.1")
+
+(defvoo nnvirtual-current-group nil)
+
+(defvoo nnvirtual-mapping-table nil
+  "Table of rules on how to map between component group and article number
+to virtual article number.")
+
+(defvoo nnvirtual-mapping-offsets nil
+  "Table indexed by component group to an offset to be applied to article numbers in that group.")
+
+(defvoo nnvirtual-mapping-len 0
+  "Number of articles in this virtual group.")
+
+(defvoo nnvirtual-mapping-reads nil
+  "Compressed sequence of read articles on the virtual group as computed from the unread status of individual component groups.")
+
+(defvoo nnvirtual-mapping-marks nil
+  "Compressed marks alist for the virtual group as computed from the marks of individual component groups.")
+
+(defvoo nnvirtual-info-installed nil
+  "T if we have already installed the group info for this group, and shouldn't blast over it again.")
+
+(defvoo nnvirtual-status-string "")
+
+(eval-and-compile
+  (autoload 'gnus-cache-articles-in-group "gnus-cache"))
+
+
+
+;;; Interface functions.
+
+(nnoo-define-basics nnvirtual)
+
+
+(deffoo nnvirtual-retrieve-headers (articles &optional newsgroup
+					     server fetch-old)
+  (when (nnvirtual-possibly-change-server server)
+    (save-excursion
+      (set-buffer nntp-server-buffer)
+      (erase-buffer)
+      (if (stringp (car articles))
+	  'headers
+	(let ((vbuf (nnheader-set-temp-buffer
+		     (get-buffer-create " *virtual headers*")))
+	      (carticles (nnvirtual-partition-sequence articles))
+	      (system-name (system-name))
+	      cgroup carticle article result prefix)
+	  (while carticles
+	    (setq cgroup (caar carticles))
+	    (setq articles (cdar carticles))
+	    (pop carticles)
+	    (when (and articles
+		       (gnus-check-server
+			(gnus-find-method-for-group cgroup) t)
+		       (gnus-request-group cgroup t)
+		       (setq prefix (gnus-group-real-prefix cgroup))
+		       ;; FIX FIX FIX we want to check the cache!
+		       ;; This is probably evil if people have set
+		       ;; gnus-use-cache to nil themselves, but I
+		       ;; have no way of finding the true value of it.
+		       (let ((gnus-use-cache t))
+			 (setq result (gnus-retrieve-headers
+				       articles cgroup nil))))
+	    (set-buffer nntp-server-buffer)
+	    ;; If we got HEAD headers, we convert them into NOV
+	    ;; headers.  This is slow, inefficient and, come to think
+	    ;; of it, downright evil.  So sue me.  I couldn't be
+	    ;; bothered to write a header parse routine that could
+	    ;; parse a mixed HEAD/NOV buffer.
+	    (when (eq result 'headers)
+	      (nnvirtual-convert-headers))
+	    (goto-char (point-min))
+	    (while (not (eobp))
+	      (delete-region (point)
+			     (progn
+			       (setq carticle (read nntp-server-buffer))
+			       (point)))
+
+	      ;; We remove this article from the articles list, if
+	      ;; anything is left in the articles list after going through
+	      ;; the entire buffer, then those articles have been
+	      ;; expired or canceled, so we appropriately update the
+	      ;; component group below.  They should be coming up
+	      ;; generally in order, so this shouldn't be slow.
+	      (setq articles (delq carticle articles))
+
+	      (setq article (nnvirtual-reverse-map-article cgroup carticle))
+	      (if (null article)
+		  ;; This line has no reverse mapping, that means it
+		  ;; was an extra article reference returned by nntp.
+		  (progn
+		    (beginning-of-line)
+		    (delete-region (point) (progn (forward-line 1) (point))))
+		;; Otherwise insert the virtual article number,
+		;; and clean up the xrefs.
+		(princ article nntp-server-buffer)
+		(nnvirtual-update-xref-header cgroup carticle
+					      prefix system-name)
+		(forward-line 1))
+	      )
+
+	    (set-buffer vbuf)
+	    (goto-char (point-max))
+	    (insert-buffer-substring nntp-server-buffer))
+	    ;; Anything left in articles is expired or canceled.
+	    ;; Could be smart and not tell it about articles already known?
+	    (when articles
+	      (gnus-group-make-articles-read cgroup articles))
+	    )
+
+	  ;; The headers are ready for reading, so they are inserted into
+	  ;; the nntp-server-buffer, which is where Gnus expects to find
+	  ;; them.
+	  (prog1
+	      (save-excursion
+		(set-buffer nntp-server-buffer)
+		(erase-buffer)
+		(insert-buffer-substring vbuf)
+		;; FIX FIX FIX, we should be able to sort faster than
+		;; this if needed, since each cgroup is sorted, we just
+		;; need to merge
+		(sort-numeric-fields 1 (point-min) (point-max))
+		'nov)
+	    (kill-buffer vbuf)))))))
+
+
+(defvoo nnvirtual-last-accessed-component-group nil)
+
+(deffoo nnvirtual-request-article (article &optional group server buffer)
+  (when (nnvirtual-possibly-change-server server)
+    (if (stringp article)
+	;; This is a fetch by Message-ID.
+	(cond
+	 ((not nnvirtual-last-accessed-component-group)
+	  (nnheader-report
+	   'nnvirtual "Don't know what server to request from"))
+	 (t
+	  (save-excursion
+	    (when buffer
+	      (set-buffer buffer))
+	    (let ((method (gnus-find-method-for-group
+			   nnvirtual-last-accessed-component-group)))
+	      (funcall (gnus-get-function method 'request-article)
+		       article nil (nth 1 method) buffer)))))
+      ;; This is a fetch by number.
+      (let* ((amap (nnvirtual-map-article article))
+	     (cgroup (car amap)))
+	(cond
+	 ((not amap)
+	  (nnheader-report 'nnvirtual "No such article: %s" article))
+	 ((not (gnus-check-group cgroup))
+	  (nnheader-report
+	   'nnvirtual "Can't open server where %s exists" cgroup))
+	 ((not (gnus-request-group cgroup t))
+	  (nnheader-report 'nnvirtual "Can't open component group %s" cgroup))
+	 (t
+	  (setq nnvirtual-last-accessed-component-group cgroup)
+	  (if buffer
+	      (save-excursion
+		(set-buffer buffer)
+		(gnus-request-article-this-buffer (cdr amap) cgroup))
+	    (gnus-request-article (cdr amap) cgroup))))))))
+
+
+(deffoo nnvirtual-open-server (server &optional defs)
+  (unless (assq 'nnvirtual-component-regexp defs)
+    (push `(nnvirtual-component-regexp ,server)
+	  defs))
+  (nnoo-change-server 'nnvirtual server defs)
+  (if nnvirtual-component-groups
+      t
+    (setq nnvirtual-mapping-table nil
+	  nnvirtual-mapping-offsets nil
+	  nnvirtual-mapping-len 0
+	  nnvirtual-mapping-reads nil
+	  nnvirtual-mapping-marks nil
+	  nnvirtual-info-installed nil)
+    (when nnvirtual-component-regexp
+      ;; Go through the newsrc alist and find all component groups.
+      (let ((newsrc (cdr gnus-newsrc-alist))
+	    group)
+	(while (setq group (car (pop newsrc)))
+	  (when (string-match nnvirtual-component-regexp group) ; Match
+	    ;; Add this group to the list of component groups.
+	    (setq nnvirtual-component-groups
+		  (cons group (delete group nnvirtual-component-groups)))))))
+    (if (not nnvirtual-component-groups)
+	(nnheader-report 'nnvirtual "No component groups: %s" server)
+      t)))
+
+
+(deffoo nnvirtual-request-group (group &optional server dont-check)
+  (nnvirtual-possibly-change-server server)
+  (setq nnvirtual-component-groups
+	(delete (nnvirtual-current-group) nnvirtual-component-groups))
+  (cond
+   ((null nnvirtual-component-groups)
+    (setq nnvirtual-current-group nil)
+    (nnheader-report 'nnvirtual "No component groups in %s" group))
+   (t
+    (when (or (not dont-check)
+	      nnvirtual-always-rescan)
+      (nnvirtual-create-mapping))
+    (setq nnvirtual-current-group group)
+    (nnheader-insert "211 %d 1 %d %s\n"
+		     nnvirtual-mapping-len nnvirtual-mapping-len group))))
+
+
+(deffoo nnvirtual-request-type (group &optional article)
+  (if (not article)
+      'unknown
+    (let ((mart (nnvirtual-map-article article)))
+      (when mart
+	(gnus-request-type (car mart) (cdr mart))))))
+
+(deffoo nnvirtual-request-update-mark (group article mark)
+  (let* ((nart (nnvirtual-map-article article))
+	 (cgroup (car nart))
+	 ;; The component group might be a virtual group.
+	 (nmark (gnus-request-update-mark cgroup (cdr nart) mark)))
+    (when (and nart
+	       (= mark nmark)
+	       (gnus-group-auto-expirable-p cgroup))
+      (setq mark gnus-expirable-mark)))
+  mark)
+
+
+(deffoo nnvirtual-close-group (group &optional server)
+  (when (and (nnvirtual-possibly-change-server server)
+	     (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
+    (nnvirtual-update-read-and-marked t t))
+  t)
+
+
+(deffoo nnvirtual-request-list (&optional server)
+  (nnheader-report 'nnvirtual "LIST is not implemented."))
+
+
+(deffoo nnvirtual-request-newgroups (date &optional server)
+  (nnheader-report 'nnvirtual "NEWGROUPS is not supported."))
+
+
+(deffoo nnvirtual-request-list-newsgroups (&optional server)
+  (nnheader-report 'nnvirtual "LIST NEWSGROUPS is not implemented."))
+
+
+(deffoo nnvirtual-request-update-info (group info &optional server)
+  (when (and (nnvirtual-possibly-change-server server)
+	     (not nnvirtual-info-installed))
+    ;; Install the precomputed lists atomically, so the virtual group
+    ;; is not left in a half-way state in case of C-g.
+    (gnus-atomic-progn
+      (setcar (cddr info) nnvirtual-mapping-reads)
+      (if (nthcdr 3 info)
+	  (setcar (nthcdr 3 info) nnvirtual-mapping-marks)
+	(when nnvirtual-mapping-marks
+	  (setcdr (nthcdr 2 info) (list nnvirtual-mapping-marks))))
+      (setq nnvirtual-info-installed t))
+    t))
+
+
+(deffoo nnvirtual-catchup-group (group &optional server all)
+  (when (and (nnvirtual-possibly-change-server server)
+	     (not (gnus-ephemeral-group-p (nnvirtual-current-group))))
+    ;; copy over existing marks first, in case they set anything
+    (nnvirtual-update-read-and-marked nil nil)
+    ;; do a catchup on all component groups
+    (let ((gnus-group-marked (copy-sequence nnvirtual-component-groups))
+	  (gnus-expert-user t))
+      ;; Make sure all groups are activated.
+      (mapcar
+       (lambda (g)
+	 (when (not (numberp (car (gnus-gethash g gnus-newsrc-hashtb))))
+	   (gnus-activate-group g)))
+       nnvirtual-component-groups)
+      (save-excursion
+	(set-buffer gnus-group-buffer)
+	(gnus-group-catchup-current nil all)))))
+
+
+(deffoo nnvirtual-find-group-art (group article)
+  "Return the real group and article for virtual GROUP and ARTICLE."
+  (nnvirtual-map-article article))
+
+
+;;; Internal functions.
+
+(defun nnvirtual-convert-headers ()
+  "Convert HEAD headers into NOV headers."
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (let* ((dependencies (make-vector 100 0))
+	   (headers (gnus-get-newsgroup-headers dependencies))
+	   header)
+      (erase-buffer)
+      (while (setq header (pop headers))
+	(nnheader-insert-nov header)))))
+
+
+(defun nnvirtual-update-xref-header (group article prefix system-name)
+  "Edit current NOV header in current buffer to have an xref to the component group, and also server prefix any existing xref lines."
+  ;; Move to beginning of Xref field, creating a slot if needed.
+  (beginning-of-line)
+  (looking-at
+   "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
+  (goto-char (match-end 0))
+  (unless (search-forward "\t" (gnus-point-at-eol) 'move)
+    (insert "\t"))
+
+  ;; Remove any spaces at the beginning of the Xref field.
+  (while (= (char-after (1- (point))) ? )
+    (forward-char -1)
+    (delete-char 1))
+
+  (insert "Xref: " system-name " " group ":")
+  (princ article (current-buffer))
+
+  ;; If there were existing xref lines, clean them up to have the correct
+  ;; component server prefix.
+  (let ((xref-end (save-excursion
+		    (search-forward "\t" (gnus-point-at-eol) 'move)
+		    (point)))
+	(len (length prefix)))
+    (unless (= (point) xref-end)
+      (insert " ")
+      (when (not (string= "" prefix))
+	(while (re-search-forward "[^ ]+:[0-9]+" xref-end t)
+	  (save-excursion
+	    (goto-char (match-beginning 0))
+	    (insert prefix))
+	  (setq xref-end (+ xref-end len)))
+	)))
+
+  ;; Ensure a trailing \t.
+  (end-of-line)
+  (or (= (char-after (1- (point))) ?\t)
+      (insert ?\t)))
+
+
+(defun nnvirtual-possibly-change-server (server)
+  (or (not server)
+      (nnoo-current-server-p 'nnvirtual server)
+      (nnvirtual-open-server server)))
+
+
+(defun nnvirtual-update-read-and-marked (read-p update-p)
+  "Copy marks from the virtual group to the component groups.
+If READ-P is not nil, update the (un)read status of the components.
+If UPDATE-P is not nil, call gnus-group-update-group on the components."
+  (when nnvirtual-current-group
+    (let ((unreads (and read-p
+			(nnvirtual-partition-sequence
+			 (gnus-list-of-unread-articles
+			  (nnvirtual-current-group)))))
+	  (type-marks (mapcar (lambda (ml)
+				(cons (car ml)
+				      (nnvirtual-partition-sequence (cdr ml))))
+			      (gnus-info-marks (gnus-get-info
+						(nnvirtual-current-group)))))
+	  mark type groups carticles info entry)
+
+      ;; Ok, atomically move all of the (un)read info, clear any old
+      ;; marks, and move all of the current marks.  This way if someone
+      ;; hits C-g, you won't leave the component groups in a half-way state.
+      (gnus-atomic-progn
+	;; move (un)read
+	(let ((gnus-newsgroup-active nil)) ;workaround guns-update-read-articles
+	  (while (setq entry (pop unreads))
+	    (gnus-update-read-articles (car entry) (cdr entry))))
+
+	;; clear all existing marks on the component groups
+	(setq groups nnvirtual-component-groups)
+	(while groups
+	  (when (and (setq info (gnus-get-info (pop groups)))
+		     (gnus-info-marks info))
+	    (gnus-info-set-marks info nil)))
+
+	;; Ok, currently type-marks is an assq list with keys of a mark type,
+	;; with data of an assq list with keys of component group names
+	;; and the articles which correspond to that key/group pair.
+	(while (setq mark (pop type-marks))
+	  (setq type (car mark))
+	  (setq groups (cdr mark))
+	  (while (setq carticles (pop groups))
+	    (gnus-add-marked-articles (car carticles) type (cdr carticles)
+				      nil t))))
+
+      ;; possibly update the display, it is really slow
+      (when update-p
+	(setq groups nnvirtual-component-groups)
+	(while groups
+	  (gnus-group-update-group (pop groups) t))))))
+
+
+(defun nnvirtual-current-group ()
+  "Return the prefixed name of the current nnvirtual group."
+  (concat "nnvirtual:" nnvirtual-current-group))
+
+
+
+;;; This is currently O(kn^2) to merge n lists of length k.
+;;; You could do it in O(knlogn), but we have a small n, and the
+;;; overhead of the other approach is probably greater.
+(defun nnvirtual-merge-sorted-lists (&rest lists)
+  "Merge many sorted lists of numbers."
+  (if (null (cdr lists))
+      (car lists)
+    (apply 'nnvirtual-merge-sorted-lists
+	   (merge 'list (car lists) (cadr lists) '<)
+	   (cddr lists))))
+
+
+
+;;; We map between virtual articles and real articles in a manner
+;;; which keeps the size of the virtual active list the same as
+;;; the sum of the component active lists.
+;;; To achieve fair mixing of the groups, the last article in
+;;; each of N component groups will be in the the last N articles
+;;; in the virtual group.
+
+;;; If you have 3 components A, B and C, with articles 1-8, 1-5, and 6-7
+;;; resprectively, then the virtual article numbers look like:
+;;;
+;;;  1  2  3  4  5  6  7  8  9  10 11 12 13 14 15
+;;;  A1 A2 A3 A4 B1 A5 B2 A6 B3 A7 B4 C6 A8 B5 C7
+
+;;; To compute these mappings we generate a couple tables and then
+;;; do some fast operations on them.  Tables for the example above:
+;;;
+;;; Offsets - [(A 0) (B -3) (C -1)]
+;;;
+;;;               a  b  c  d  e
+;;; Mapping - ([  3  0  1  3  0 ]
+;;;            [  6  3  2  9  3 ]
+;;;            [  8  6  3 15  9 ])
+;;;
+;;; (note column 'e' is different in real algorithm, which is slightly
+;;;  different than described here, but this gives you the methodology.)
+;;;
+;;; The basic idea is this, when going from component->virtual, apply
+;;; the appropriate offset to the article number.  Then search the first
+;;; column of the table for a row where 'a' is less than or equal to the
+;;; modified number.  You can see that only group A can therefore go to
+;;; the first row, groups A and B to the second, and all to the last.
+;;; The third column of the table is telling us the number of groups
+;;; which might be able to reach that row (it might increase by more than
+;;; 1 if several groups have the same size).
+;;; Then column 'b' provides an additional offset you apply when you have
+;;; found the correct row.  You then multiply by 'c' and add on the groups
+;;; _position_ in the offset table.  The basic idea here is that on
+;;; any given row we are going to map back and forth using X'=X*c+Y and
+;;; X=(X'/c), Y=(X' mod c).  Then once you've done this transformation,
+;;; you apply a final offset from column 'e' to give the virtual article.
+;;;
+;;; Going the other direction, you instead search on column 'd' instead
+;;; of 'a', and apply everything in reverse order.
+
+;;; Convert component -> virtual:
+;;; set num = num - Offset(group)
+;;; find first row in Mapping where num <= 'a'
+;;; num = (num-'b')*c + Position(group) + 'e'
+
+;;; Convert virtual -> component:
+;;; find first row in Mapping where num <= 'd'
+;;; num = num - 'e'
+;;; group_pos = num mod 'c'
+;;; num = (num / 'c') + 'b' + Offset(group_pos)
+
+;;; Easy no? :)
+;;;
+;;; Well actually, you need to keep column e offset smaller by the 'c'
+;;; column for that line, and always add 1 more when going from
+;;; component -> virtual.  Otherwise you run into a problem with
+;;; unique reverse mapping.
+
+(defun nnvirtual-map-article (article)
+  "Return a cons of the component group and article corresponding to the given virtual ARTICLE."
+  (let ((table nnvirtual-mapping-table)
+	entry group-pos)
+    (while (and table
+		(> article (aref (car table) 3)))
+      (setq table (cdr table)))
+    (when (and table
+	       (> article 0))
+      (setq entry (car table))
+      (setq article (- article (aref entry 4) 1))
+      (setq group-pos (mod article (aref entry 2)))
+      (cons (car (aref nnvirtual-mapping-offsets group-pos))
+	    (+ (/ article (aref entry 2))
+	       (aref entry 1)
+	       (cdr (aref nnvirtual-mapping-offsets group-pos)))
+	    ))
+      ))
+
+
+
+(defun nnvirtual-reverse-map-article (group article)
+  "Return the virtual article number corresponding to the given component GROUP and ARTICLE."
+  (let ((table nnvirtual-mapping-table)
+	(group-pos 0)
+	entry)
+    (while (not (string= group (car (aref nnvirtual-mapping-offsets
+					  group-pos))))
+      (setq group-pos (1+ group-pos)))
+    (setq article (- article (cdr (aref nnvirtual-mapping-offsets
+					group-pos))))
+    (while (and table
+		(> article (aref (car table) 0)))
+      (setq table (cdr table)))
+    (setq entry (car table))
+    (when (and entry
+	       (> article 0)
+	       (< group-pos (aref entry 2))) ; article not out of range below
+      (+ (aref entry 4)
+	 group-pos
+	 (* (- article (aref entry 1))
+	    (aref entry 2))
+	 1))
+    ))
+
+
+(defsubst nnvirtual-reverse-map-sequence (group articles)
+  "Return list of virtual article numbers for all ARTICLES in GROUP.
+The ARTICLES should be sorted, and can be a compressed sequence.
+If any of the article numbers has no corresponding virtual article,
+then it is left out of the result."
+  (when (numberp (cdr-safe articles))
+    (setq articles (list articles)))
+  (let (result a i j new-a)
+    (while (setq a (pop articles))
+      (if (atom a)
+	  (setq i a
+		j a)
+	(setq i (car a)
+	      j (cdr a)))
+      (while (<= i j)
+	;; If this is slow, you can optimize by moving article checking
+	;; into here.  You don't have to recompute the group-pos,
+	;; nor scan the table every time.
+	(when (setq new-a (nnvirtual-reverse-map-article group i))
+	  (push new-a result))
+	(setq i (1+ i))))
+    (nreverse result)))
+
+
+(defun nnvirtual-partition-sequence (articles)
+  "Return an association list of component article numbers.
+These are indexed by elements of nnvirtual-component-groups, based on
+the sequence ARTICLES of virtual article numbers.  ARTICLES should be
+sorted, and can be a compressed sequence. If any of the article
+numbers has no corresponding component article, then it is left out of
+the result."
+  (when (numberp (cdr-safe articles))
+    (setq articles (list articles)))
+  (let ((carticles (mapcar (lambda (g) (list g))
+			   nnvirtual-component-groups))
+	a i j article entry)
+    (while (setq a (pop articles))
+      (if (atom a)
+	  (setq i a
+		j a)
+	(setq i (car a)
+	      j (cdr a)))
+      (while (<= i j)
+	(when (setq article (nnvirtual-map-article i))
+	  (setq entry (assoc (car article) carticles))
+	  (setcdr entry (cons (cdr article) (cdr entry))))
+	(setq i (1+ i))))
+    (mapc (lambda (x) (setcdr x (nreverse (cdr x))))
+	  carticles)
+    carticles))
+
+
+(defun nnvirtual-create-mapping ()
+  "Build the tables necessary to map between component (group, article) to virtual article.
+Generate the set of read messages and marks for the virtual group
+based on the marks on the component groups."
+  (let ((cnt 0)
+	(tot 0)
+	(M 0)
+	(i 0)
+	actives all-unreads all-marks
+	active min max size unreads marks
+	next-M next-tot
+	reads beg)
+    ;; Ok, we loop over all component groups and collect a lot of
+    ;; information:
+    ;; Into actives we place (g size max), where size is max-min+1.
+    ;; Into all-unreads we put (g unreads).
+    ;; Into all-marks we put (g marks).
+    ;; We also increment cnt and tot here, and compute M (max of sizes).
+    (mapc (lambda (g)
+	    (setq active (gnus-activate-group g)
+		  min (car active)
+		  max (cdr active))
+	    (when (and active (>= max min) (not (zerop max)))
+	      ;; store active information
+	      (push (list g (- max min -1) max) actives)
+	      ;; collect unread/mark info for later
+	      (setq unreads (gnus-list-of-unread-articles g))
+	      (setq marks (gnus-info-marks (gnus-get-info g)))
+	      (when gnus-use-cache
+		(push (cons 'cache
+			    (gnus-cache-articles-in-group g))
+		      marks))
+	      (push (cons g unreads) all-unreads)
+	      (push (cons g marks) all-marks)
+	      ;; count groups, total #articles, and max size
+	      (setq size (- max min -1))
+	      (setq cnt (1+ cnt)
+		    tot (+ tot size)
+		    M (max M size))))
+	  nnvirtual-component-groups)
+
+    ;; Number of articles in the virtual group.
+    (setq nnvirtual-mapping-len tot)
+
+
+    ;; We want the actives list sorted by size, to build the tables.
+    (setq actives (sort actives (lambda (g1 g2) (< (nth 1 g1) (nth 1 g2)))))
+
+    ;; Build the offset table.  Largest sized groups are at the front.
+    (setq nnvirtual-mapping-offsets
+	  (vconcat
+	   (nreverse
+	    (mapcar (lambda (entry)
+		      (cons (nth 0 entry)
+			    (- (nth 2 entry) M)))
+		    actives))))
+
+    ;; Build the mapping table.
+    (setq nnvirtual-mapping-table nil)
+    (setq actives (mapcar (lambda (entry) (nth 1 entry)) actives))
+    (while actives
+      (setq size (car actives))
+      (setq next-M (- M size))
+      (setq next-tot (- tot (* cnt size)))
+      ;; make current row in table
+      (push (vector M next-M cnt tot (- next-tot cnt))
+	    nnvirtual-mapping-table)
+      ;; update M and tot
+      (setq M next-M)
+      (setq tot next-tot)
+      ;; subtract the current size from all entries.
+      (setq actives (mapcar (lambda (x) (- x size)) actives))
+      ;; remove anything that went to 0.
+      (while (and actives
+		  (= (car actives) 0))
+	(pop actives)
+	(setq cnt (- cnt 1))))
+
+
+    ;; Now that the mapping tables are generated, we can convert
+    ;; and combine the separate component unreads and marks lists
+    ;; into single lists of virtual article numbers.
+    (setq unreads (apply 'nnvirtual-merge-sorted-lists
+			 (mapcar (lambda (x)
+				   (nnvirtual-reverse-map-sequence
+				    (car x) (cdr x)))
+				 all-unreads)))
+    (setq marks (mapcar
+		 (lambda (type)
+		   (cons (cdr type)
+			 (gnus-compress-sequence
+			  (apply
+			   'nnvirtual-merge-sorted-lists
+			   (mapcar (lambda (x)
+				     (nnvirtual-reverse-map-sequence
+				      (car x)
+				      (cdr (assq (cdr type) (cdr x)))))
+				   all-marks)))))
+		 gnus-article-mark-lists))
+
+    ;; Remove any empty marks lists, and store.
+    (setq nnvirtual-mapping-marks (delete-if-not 'cdr marks))
+
+    ;; We need to convert the unreads to reads.  We compress the
+    ;; sequence as we go, otherwise it could be huge.
+    (while (and (<= (incf i) nnvirtual-mapping-len)
+		unreads)
+      (if (= i (car unreads))
+	  (setq unreads (cdr unreads))
+	;; try to get a range.
+	(setq beg i)
+	(while (and (<= (incf i) nnvirtual-mapping-len)
+		    (not (= i (car unreads)))))
+	(setq i (- i 1))
+	(if (= i beg)
+	    (push i reads)
+	  (push (cons beg i) reads))
+	))
+    (when (<= i nnvirtual-mapping-len)
+      (if (= i nnvirtual-mapping-len)
+	  (push i reads)
+	(push (cons i nnvirtual-mapping-len) reads)))
+
+    ;; Store the reads list for later use.
+    (setq nnvirtual-mapping-reads (nreverse reads))
+
+    ;; Throw flag to show we changed the info.
+    (setq nnvirtual-info-installed nil)
+    ))
+
+(provide 'nnvirtual)
+
+;;; nnvirtual.el ends here

lisp/gnus/nnweb.el

@@ -0,0 +1,689 @@
+;;; nnweb.el --- retrieving articles via web search engines
+;; Copyright (C) 1996,97 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Note: You need to have `url' and `w3' installed for this
+;; backend to work.
+
+;;; Code:
+
+(require 'nnoo)
+(require 'message)
+(require 'gnus-util)
+(require 'gnus)
+(require 'w3)
+(require 'url)
+(require 'nnmail)
+(ignore-errors
+  (require 'w3-forms))
+
+(nnoo-declare nnweb)
+
+(defvoo nnweb-directory (nnheader-concat gnus-directory "nnweb/")
+  "Where nnweb will save its files.")
+
+(defvoo nnweb-type 'dejanews
+  "What search engine type is being used.")
+
+(defvar nnweb-type-definition
+  '((dejanews
+     (article . nnweb-dejanews-wash-article)
+     (map . nnweb-dejanews-create-mapping)
+     (search . nnweb-dejanews-search)
+     (address . "http://xp9.dejanews.com/dnquery.xp")
+     (identifier . nnweb-dejanews-identity))
+    (reference
+     (article . nnweb-reference-wash-article)
+     (map . nnweb-reference-create-mapping)
+     (search . nnweb-reference-search)
+     (address . "http://www.reference.com/cgi-bin/pn/go")
+     (identifier . identity))
+    (altavista
+     (article . nnweb-altavista-wash-article)
+     (map . nnweb-altavista-create-mapping)
+     (search . nnweb-altavista-search)
+     (address . "http://www.altavista.digital.com/cgi-bin/query")
+     (id . "/cgi-bin/news?id@%s")
+     (identifier . identity)))
+  "Type-definition alist.")
+
+(defvoo nnweb-search nil
+  "Search string to feed to DejaNews.")
+
+(defvoo nnweb-max-hits 100
+  "Maximum number of hits to display.")
+
+(defvoo nnweb-ephemeral-p nil
+  "Whether this nnweb server is ephemeral.")
+
+;;; Internal variables
+
+(defvoo nnweb-articles nil)
+(defvoo nnweb-buffer nil)
+(defvoo nnweb-group-alist nil)
+(defvoo nnweb-group nil)
+(defvoo nnweb-hashtb nil)
+
+;;; Interface functions
+
+(nnoo-define-basics nnweb)
+
+(deffoo nnweb-retrieve-headers (articles &optional group server fetch-old)
+  (nnweb-possibly-change-server group server)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (erase-buffer)
+    (let (article header)
+      (while (setq article (pop articles))
+	(when (setq header (cadr (assq article nnweb-articles)))
+	  (nnheader-insert-nov header)))
+      'nov)))
+
+(deffoo nnweb-request-scan (&optional group server)
+  (nnweb-possibly-change-server group server)
+  (setq nnweb-hashtb (gnus-make-hashtable 4095))
+  (funcall (nnweb-definition 'map))
+  (unless nnweb-ephemeral-p
+    (nnweb-write-active)
+    (nnweb-write-overview group)))
+
+(deffoo nnweb-request-group (group &optional server dont-check)
+  (nnweb-possibly-change-server nil server)
+  (when (and group
+	     (not (equal group nnweb-group))
+	     (not nnweb-ephemeral-p))
+    (let ((info (assoc group nnweb-group-alist)))
+      (setq nnweb-group group)
+      (setq nnweb-type (nth 2 info))
+      (setq nnweb-search (nth 3 info))
+      (unless dont-check
+	(nnweb-read-overview group))))
+  (cond
+   ((not nnweb-articles)
+    (nnheader-report 'nnweb "No matching articles"))
+   (t
+    (let ((active (if nnweb-ephemeral-p
+		      (cons (caar nnweb-articles)
+			    (caar (last nnweb-articles)))
+		    (cadr (assoc group nnweb-group-alist)))))
+      (nnheader-report 'nnweb "Opened group %s" group)
+      (nnheader-insert
+       "211 %d %d %d %s\n" (length nnweb-articles)
+       (car active) (cdr active) group)))))
+
+(deffoo nnweb-close-group (group &optional server)
+  (nnweb-possibly-change-server group server)
+  (when (gnus-buffer-live-p nnweb-buffer)
+    (save-excursion
+      (set-buffer nnweb-buffer)
+      (set-buffer-modified-p nil)
+      (kill-buffer nnweb-buffer)))
+  t)
+
+(deffoo nnweb-request-article (article &optional group server buffer)
+  (nnweb-possibly-change-server group server)
+  (save-excursion
+    (set-buffer (or buffer nntp-server-buffer))
+    (let* ((header (cadr (assq article nnweb-articles)))
+	   (url (and header (mail-header-xref header))))
+      (when (or (and url
+		     (nnweb-fetch-url url))
+		(and (stringp article)
+		     (nnweb-definition 'id t)
+		     (let ((fetch (nnweb-definition 'id))
+			   art)
+		       (when (string-match "^<\\(.*\\)>$" article)
+			 (setq art (match-string 1 article)))
+		       (and fetch
+			    art
+			    (nnweb-fetch-url
+			     (format fetch article))))))
+	(unless nnheader-callback-function
+	  (funcall (nnweb-definition 'article))
+	  (nnweb-decode-entities))
+	(nnheader-report 'nnweb "Fetched article %s" article)
+	t))))
+
+(deffoo nnweb-close-server (&optional server)
+  (when (and (nnweb-server-opened server)
+	     (gnus-buffer-live-p nnweb-buffer))
+    (save-excursion
+      (set-buffer nnweb-buffer)
+      (set-buffer-modified-p nil)
+      (kill-buffer nnweb-buffer)))
+  (nnoo-close-server 'nnweb server))
+
+(deffoo nnweb-request-list (&optional server)
+  (nnweb-possibly-change-server nil server)
+  (save-excursion
+    (set-buffer nntp-server-buffer)
+    (nnmail-generate-active nnweb-group-alist)
+    t))
+
+(deffoo nnweb-request-update-info (group info &optional server)
+  (nnweb-possibly-change-server group server)
+  ;;(setcar (cddr info) nil)
+  )
+
+(deffoo nnweb-asynchronous-p ()
+  t)
+
+(deffoo nnweb-request-create-group (group &optional server args)
+  (nnweb-possibly-change-server nil server)
+  (nnweb-request-delete-group group)
+  (push `(,group ,(cons 1 0) ,@args) nnweb-group-alist)
+  (nnweb-write-active)
+  t)
+
+(deffoo nnweb-request-delete-group (group &optional force server)
+  (nnweb-possibly-change-server group server)
+  (gnus-delete-assoc group nnweb-group-alist)
+  (gnus-delete-file (nnweb-overview-file group))
+  t)
+
+(nnoo-define-skeleton nnweb)
+
+;;; Internal functions
+
+(defun nnweb-read-overview (group)
+  "Read the overview of GROUP and build the map."
+  (when (file-exists-p (nnweb-overview-file group))
+    (nnheader-temp-write nil
+      (nnheader-insert-file-contents (nnweb-overview-file group))
+      (goto-char (point-min))
+      (let (header)
+	(while (not (eobp))
+	  (setq header (nnheader-parse-nov))
+	  (forward-line 1)
+	  (push (list (mail-header-number header)
+		      header (mail-header-xref header))
+		nnweb-articles)
+	  (nnweb-set-hashtb header (car nnweb-articles)))))))
+
+(defun nnweb-write-overview (group)
+  "Write the overview file for GROUP."
+  (nnheader-temp-write (nnweb-overview-file group)
+    (let ((articles nnweb-articles))
+      (while articles
+	(nnheader-insert-nov (cadr (pop articles)))))))
+
+(defun nnweb-set-hashtb (header data)
+  (gnus-sethash (nnweb-identifier (mail-header-xref header))
+		data nnweb-hashtb))
+
+(defun nnweb-get-hashtb (url)
+  (gnus-gethash (nnweb-identifier url) nnweb-hashtb))
+
+(defun nnweb-identifier (ident)
+  (funcall (nnweb-definition 'identifier) ident))
+
+(defun nnweb-overview-file (group)
+  "Return the name of the overview file of GROUP."
+  (nnheader-concat nnweb-directory group ".overview"))
+
+(defun nnweb-write-active ()
+  "Save the active file."
+  (nnheader-temp-write (nnheader-concat nnweb-directory "active")
+    (prin1 `(setq nnweb-group-alist ',nnweb-group-alist) (current-buffer))))
+
+(defun nnweb-read-active ()
+  "Read the active file."
+  (load (nnheader-concat nnweb-directory "active") t t t))
+
+(defun nnweb-definition (type &optional noerror)
+  "Return the definition of TYPE."
+  (let ((def (cdr (assq type (assq nnweb-type nnweb-type-definition)))))
+    (when (and (not def)
+	       (not noerror))
+      (error "Undefined definition %s" type))
+    def))
+
+(defun nnweb-possibly-change-server (&optional group server)
+  (nnweb-init server)
+  (when server
+    (unless (nnweb-server-opened server)
+      (nnweb-open-server server)))
+  (unless nnweb-group-alist
+    (nnweb-read-active))
+  (when group
+    (when (and (not nnweb-ephemeral-p)
+	       (not (equal group nnweb-group)))
+      (nnweb-request-group group nil t))))
+
+(defun nnweb-init (server)
+  "Initialize buffers and such."
+  (unless (gnus-buffer-live-p nnweb-buffer)
+    (setq nnweb-buffer
+	  (save-excursion
+	    (nnheader-set-temp-buffer
+	     (format " *nnweb %s %s %s*" nnweb-type nnweb-search server))))))
+
+(defun nnweb-fetch-url (url)
+  (save-excursion
+    (if (not nnheader-callback-function)
+	(let ((buf (current-buffer)))
+	  (save-excursion
+	    (set-buffer nnweb-buffer)
+	    (erase-buffer)
+	    (prog1
+		(url-insert-file-contents url)
+	      (copy-to-buffer buf (point-min) (point-max)))))
+      (nnweb-url-retrieve-asynch
+       url 'nnweb-callback (current-buffer) nnheader-callback-function)
+      t)))
+
+(defun nnweb-callback (buffer callback)
+  (when (gnus-buffer-live-p url-working-buffer)
+    (save-excursion
+      (set-buffer url-working-buffer)
+      (funcall (nnweb-definition 'article))
+      (nnweb-decode-entities)
+      (set-buffer buffer)
+      (goto-char (point-max))
+      (insert-buffer-substring url-working-buffer))
+    (funcall callback t)
+    (gnus-kill-buffer url-working-buffer)))
+
+(defun nnweb-url-retrieve-asynch (url callback &rest data)
+  (let ((url-request-method "GET")
+	(old-asynch url-be-asynchronous)
+	(url-request-data nil)
+	(url-request-extra-headers nil)
+	(url-working-buffer (generate-new-buffer-name " *nnweb*")))
+    (setq-default url-be-asynchronous t)
+    (save-excursion
+      (set-buffer (get-buffer-create url-working-buffer))
+      (setq url-current-callback-data data
+	    url-be-asynchronous t
+	    url-current-callback-func callback)
+      (url-retrieve url))
+    (setq-default url-be-asynchronous old-asynch)))
+
+(defun nnweb-encode-www-form-urlencoded (pairs)
+  "Return PAIRS encoded for forms."
+  (mapconcat
+   (function
+    (lambda (data)
+      (concat (w3-form-encode-xwfu (car data)) "="
+	      (w3-form-encode-xwfu (cdr data)))))
+   pairs "&"))
+
+(defun nnweb-fetch-form (url pairs)
+  (let ((url-request-data (nnweb-encode-www-form-urlencoded pairs))
+	(url-request-method "POST")
+	(url-request-extra-headers
+	 '(("Content-type" . "application/x-www-form-urlencoded"))))
+    (url-insert-file-contents url)
+    (setq buffer-file-name nil))
+  t)
+
+(defun nnweb-decode-entities ()
+  (goto-char (point-min))
+  (while (re-search-forward "&\\([a-z]+\\);" nil t)
+    (replace-match (char-to-string (or (cdr (assq (intern (match-string 1))
+						  w3-html-entities ))
+				       ?#))
+		   t t)))
+
+(defun nnweb-remove-markup ()
+  (goto-char (point-min))
+  (while (search-forward "<!--" nil t)
+    (delete-region (match-beginning 0)
+		   (or (search-forward "-->" nil t)
+		       (point-max))))
+  (goto-char (point-min))
+  (while (re-search-forward "<[^>]+>" nil t)
+    (replace-match "" t t)))
+
+;;;
+;;; DejaNews functions.
+;;;
+
+(defun nnweb-dejanews-create-mapping ()
+  "Perform the search and create an number-to-url alist."
+  (save-excursion
+    (set-buffer nnweb-buffer)
+    (erase-buffer)
+    (when (funcall (nnweb-definition 'search) nnweb-search)
+      (let ((i 0)
+	    (more t)
+	    (case-fold-search t)
+	    (active (or (cadr (assoc nnweb-group nnweb-group-alist))
+			(cons 1 0)))
+	    Subject Score Date Newsgroup Author
+	    map url)
+	(while more
+	  ;; Go through all the article hits on this page.
+	  (goto-char (point-min))
+	  (nnweb-decode-entities)
+	  (goto-char (point-min))
+	  (while (re-search-forward "^ +[0-9]+\\." nil t)
+	    (narrow-to-region
+	     (point)
+	     (cond ((re-search-forward "^ +[0-9]+\\." nil t)
+		    (match-beginning 0))
+		   ((search-forward "\n\n" nil t)
+		    (point))
+		   (t
+		    (point-max))))
+	    (goto-char (point-min))
+	    (when (looking-at ".*HREF=\"\\([^\"]+\\)\"")
+	      (setq url (match-string 1)))
+	    (nnweb-remove-markup)
+	    (goto-char (point-min))
+	    (while (search-forward "\t" nil t)
+	      (replace-match " "))
+	    (goto-char (point-min))
+	    (while (re-search-forward "^ +\\([^:]+\\): +\\(.*\\)$" nil t)
+	      (set (intern (match-string 1)) (match-string 2)))
+	    (widen)
+	    (when (string-match "#[0-9]+/[0-9]+ *$" Subject)
+	      (setq Subject (substring Subject 0 (match-beginning 0))))
+	    (incf i)
+	    (unless (nnweb-get-hashtb url)
+	      (push
+	       (list
+		(incf (cdr active))
+		(make-full-mail-header
+		 (cdr active) (concat  "(" Newsgroup ") " Subject) Author Date
+		 (concat "<" (nnweb-identifier url) "@dejanews>")
+		 nil 0 (string-to-int Score) url))
+	       map)
+	      (nnweb-set-hashtb (cadar map) (car map))))
+	  ;; See whether there is a "Get next 20 hits" button here.
+	  (if (or (not (re-search-forward
+			"HREF=\"\\([^\"]+\\)\">Get next" nil t))
+		  (>= i nnweb-max-hits))
+	      (setq more nil)
+	    ;; Yup -- fetch it.
+	    (setq more (match-string 1))
+	    (erase-buffer)
+	    (url-insert-file-contents more)))
+	;; Return the articles in the right order.
+	(setq nnweb-articles
+	      (sort (nconc nnweb-articles map)
+		    (lambda (s1 s2) (< (car s1) (car s2)))))))))
+
+(defun nnweb-dejanews-wash-article ()
+  (let ((case-fold-search t))
+    (goto-char (point-min))
+    (re-search-forward "<PRE>" nil t)
+    (delete-region (point-min) (point))
+    (re-search-forward "</PRE>" nil t)
+    (delete-region (point) (point-max))
+    (nnweb-remove-markup)
+    (goto-char (point-min))
+    (while (and (looking-at " *$")
+		(not (eobp)))
+      (gnus-delete-line))
+    (while (looking-at "\\(^[^ ]+:\\) *")
+      (replace-match "\\1 " t)
+      (forward-line 1))
+    (when (re-search-forward "\n\n+" nil t)
+      (replace-match "\n" t t))))
+
+(defun nnweb-dejanews-search (search)
+  (nnweb-fetch-form
+   (nnweb-definition 'address)
+   `(("query" . ,search)
+     ("defaultOp" . "AND")
+     ("svcclass" . "dncurrent")
+     ("maxhits" . "100")
+     ("format" . "verbose")
+     ("threaded" . "0")
+     ("showsort" . "score")
+     ("agesign" . "1")
+     ("ageweight" . "1")))
+  t)
+
+(defun nnweb-dejanews-identity (url)
+  "Return an unique identifier based on URL."
+  (if (string-match "recnum=\\([0-9]+\\)" url)
+      (match-string 1 url)
+    url))
+
+;;;
+;;; InReference
+;;;
+
+(defun nnweb-reference-create-mapping ()
+  "Perform the search and create an number-to-url alist."
+  (save-excursion
+    (set-buffer nnweb-buffer)
+    (erase-buffer)
+    (when (funcall (nnweb-definition 'search) nnweb-search)
+      (let ((i 0)
+	    (more t)
+	    (case-fold-search t)
+	    (active (or (cadr (assoc nnweb-group nnweb-group-alist))
+			(cons 1 0)))
+	    Subject Score Date Newsgroups From Message-ID
+	    map url)
+	(while more
+	  ;; Go through all the article hits on this page.
+	  (goto-char (point-min))
+	  (search-forward "</pre><hr>" nil t)
+	  (delete-region (point-min) (point))
+					;(nnweb-decode-entities)
+	  (goto-char (point-min))
+	  (while (re-search-forward "^ +[0-9]+\\." nil t)
+	    (narrow-to-region
+	     (point)
+	     (if (re-search-forward "^$" nil t)
+		 (match-beginning 0)
+	       (point-max)))
+	    (goto-char (point-min))
+	    (when (looking-at ".*href=\"\\([^\"]+\\)\"")
+	      (setq url (match-string 1)))
+	    (nnweb-remove-markup)
+	    (goto-char (point-min))
+	    (while (search-forward "\t" nil t)
+	      (replace-match " "))
+	    (goto-char (point-min))
+	    (while (re-search-forward "^\\([^:]+\\): \\(.*\\)$" nil t)
+	      (set (intern (match-string 1)) (match-string 2)))
+	    (widen)
+	    (search-forward "</pre>" nil t)
+	    (incf i)
+	    (unless (nnweb-get-hashtb url)
+	      (push
+	       (list
+		(incf (cdr active))
+		(make-full-mail-header
+		 (cdr active) (concat  "(" Newsgroups ") " Subject) From Date
+		 Message-ID
+		 nil 0 (string-to-int Score) url))
+	       map)
+	      (nnweb-set-hashtb (cadar map) (car map))))
+	  (setq more nil))
+	;; Return the articles in the right order.
+	(setq nnweb-articles
+	      (sort (nconc nnweb-articles map)
+		    (lambda (s1 s2) (< (car s1) (car s2)))))))))
+
+(defun nnweb-reference-wash-article ()
+  (let ((case-fold-search t))
+    (goto-char (point-min))
+    (re-search-forward "^</center><hr>" nil t)
+    (delete-region (point-min) (point))
+    (search-forward "<pre>" nil t)
+    (forward-line -1)
+    (let ((body (point-marker)))
+      (search-forward "</pre>" nil t)
+      (delete-region (point) (point-max))
+      (nnweb-remove-markup)
+      (goto-char (point-min))
+      (while (looking-at " *$")
+	(gnus-delete-line))
+      (narrow-to-region (point-min) body)
+      (while (and (re-search-forward "^$" nil t)
+		  (not (eobp)))
+	(gnus-delete-line))
+      (goto-char (point-min))
+      (while (looking-at "\\(^[^ ]+:\\) *")
+	(replace-match "\\1 " t)
+	(forward-line 1))
+      (goto-char (point-min))
+      (when (re-search-forward "^References:" nil t)
+	(narrow-to-region
+	 (point) (if (re-search-forward "^$\\|^[^:]+:" nil t)
+		     (match-beginning 0)
+		   (point-max)))
+	(goto-char (point-min))
+	(while (not (eobp))
+	  (unless (looking-at "References")
+	    (insert "\t")
+	    (forward-line 1)))
+	(goto-char (point-min))
+	(while (search-forward "," nil t)
+	  (replace-match " " t t)))
+      (widen)
+      (set-marker body nil))))
+
+(defun nnweb-reference-search (search)
+  (prog1
+      (url-insert-file-contents
+       (concat
+	(nnweb-definition 'address)
+	"?"
+	(nnweb-encode-www-form-urlencoded
+	 `(("search" . "advanced")
+	   ("querytext" . ,search)
+	   ("subj" . "")
+	   ("name" . "")
+	   ("login" . "")
+	   ("host" . "")
+	   ("organization" . "")
+	   ("groups" . "")
+	   ("keywords" . "")
+	   ("choice" . "Search")
+	   ("startmonth" . "Jul")
+	   ("startday" . "25")
+	   ("startyear" . "1996")
+	   ("endmonth" . "Aug")
+	   ("endday" . "24")
+	   ("endyear" . "1996")
+	   ("mode" . "Quick")
+	   ("verbosity" . "Verbose")
+	   ("ranking" . "Relevance")
+	   ("first" . "1")
+	   ("last" . "25")
+	   ("score" . "50")))))
+    (setq buffer-file-name nil))
+  t)
+
+;;;
+;;; Alta Vista
+;;;
+
+(defun nnweb-altavista-create-mapping ()
+  "Perform the search and create an number-to-url alist."
+  (save-excursion
+    (set-buffer nnweb-buffer)
+    (erase-buffer)
+    (let ((part 0))
+      (when (funcall (nnweb-definition 'search) nnweb-search part)
+	(let ((i 0)
+	      (more t)
+	      (case-fold-search t)
+	      (active (or (cadr (assoc nnweb-group nnweb-group-alist))
+			  (cons 1 0)))
+	      subject date from id group
+	      map url)
+	  (while more
+	    ;; Go through all the article hits on this page.
+	    (goto-char (point-min))
+	    (search-forward "<dt>" nil t)
+	    (delete-region (point-min) (match-beginning 0))
+	    (goto-char (point-min))
+	    (while (search-forward "<dt>" nil t)
+	      (replace-match "\n<blubb>"))
+	    (nnweb-decode-entities)
+	    (goto-char (point-min))
+	    (while (re-search-forward "<blubb>.*href=\"\\([^\"]+\\)\"><strong>\\([^>]*\\)</strong></a><dd>\\([^-]+\\)- <b>\\([^<]+\\)<.*href=\"news:\\([^\"]+\\)\">.*\">\\(.+\\)</a><P>"
+				      nil t)
+	      (setq url (match-string 1)
+		    subject (match-string 2)
+		    date (match-string 3)
+		    group (match-string 4)
+		    id (concat "<" (match-string 5) ">")
+		    from (match-string 6))
+	      (incf i)
+	      (unless (nnweb-get-hashtb url)
+		(push
+		 (list
+		  (incf (cdr active))
+		  (make-full-mail-header
+		   (cdr active) (concat  "(" group ") " subject) from date
+		   id nil 0 0 url))
+		 map)
+		(nnweb-set-hashtb (cadar map) (car map))))
+	    ;; See if we want more.
+	    (when (or (not nnweb-articles)
+		      (>= i nnweb-max-hits)
+		      (not (funcall (nnweb-definition 'search)
+				    nnweb-search (incf part))))
+	      (setq more nil)))
+	  ;; Return the articles in the right order.
+	  (setq nnweb-articles
+		(sort (nconc nnweb-articles map)
+		      (lambda (s1 s2) (< (car s1) (car s2))))))))))
+
+(defun nnweb-altavista-wash-article ()
+  (goto-char (point-min))
+  (let ((case-fold-search t))
+    (when (re-search-forward "^<strong>" nil t)
+      (delete-region (point-min) (match-beginning 0)))
+    (goto-char (point-min))
+    (while (looking-at "<strong>\\([^ ]+\\) +</strong> +\\(.*\\)$")
+      (replace-match "\\1: \\2" t)
+      (forward-line 1))
+    (when (re-search-backward "^References:" nil t)
+      (narrow-to-region (point) (progn (forward-line 1) (point)))
+      (goto-char (point-min))
+      (while (re-search-forward "<A.*\\?id@\\([^\"]+\\)\">[0-9]+</A>" nil t)
+	(replace-match "&lt;\\1&gt; " t)))
+    (widen)
+    (nnweb-remove-markup)))
+
+(defun nnweb-altavista-search (search &optional part)
+  (prog1
+      (url-insert-file-contents
+       (concat
+	(nnweb-definition 'address)
+	"?"
+	(nnweb-encode-www-form-urlencoded
+	 `(("pg" . "aq")
+	   ("what" . "news")
+	   ,@(when part `(("stq" . ,(int-to-string (* part 30)))))
+	   ("fmt" . "d")
+	   ("q" . ,search)
+	   ("r" . "")
+	   ("d0" . "")
+	   ("d1" . "")))))
+    (setq buffer-file-name nil)))
+
+(provide 'nnweb)
+
+;;; nnweb.el ends here

lisp/gnus/parse-time.el

@@ -0,0 +1,199 @@
+;;; parse-time.el --- Parsing time strings
+
+;; Copyright (C) 1996 by Free Software Foundation, Inc.
+
+;; Author: Erik Naggum <erik@arcana.naggum.no>
+;; Keywords: util
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; With the introduction of the `encode-time', `decode-time', and
+;; `format-time-string' functions, dealing with time became simpler in
+;; Emacs.  However, parsing time strings is still largely a matter of
+;; heuristics and no common interface has been designed.
+
+;; `parse-time-string' parses a time in a string and returns a list of 9
+;; values, just like `decode-time', where unspecified elements in the
+;; string are returned as nil.  `encode-time' may be applied on these
+;; valuse to obtain an internal time value.
+
+;;; Code:
+
+(require 'cl)				;and ah ain't kiddin' 'bout it
+
+(put 'parse-time-syntax 'char-table-extra-slots 0)
+
+(defvar parse-time-syntax (make-char-table 'parse-time-syntax))
+(defvar parse-time-digits (make-char-table 'parse-time-syntax))
+
+;; Byte-compiler warnings
+(defvar elt)
+(defvar val)
+
+(unless (aref parse-time-digits ?0)
+  (loop for i from ?0 to ?9
+	do (set-char-table-range parse-time-digits i (- i ?0))))
+
+(unless (aref parse-time-syntax ?0)
+  (loop for i from ?0 to ?9
+	do (set-char-table-range parse-time-syntax i ?0))
+  (loop for i from ?A to ?Z
+	do (set-char-table-range parse-time-syntax i ?A))
+  (loop for i from ?a to ?z
+	do (set-char-table-range parse-time-syntax i ?a))
+  (set-char-table-range parse-time-syntax ?+ 1)
+  (set-char-table-range parse-time-syntax ?- -1)
+  (set-char-table-range parse-time-syntax ?: ?d)
+  )
+
+(defsubst digit-char-p (char)
+  (aref parse-time-digits char))
+
+(defsubst parse-time-string-chars (char)
+  (aref parse-time-syntax char))
+
+(put 'parse-error 'error-conditions '(parse-error error))
+(put 'parse-error 'error-message "Parsing error")
+
+(defsubst parse-integer (string &optional start end)
+  "[CL] Parse and return the integer in STRING, or nil if none."
+  (let ((integer 0)
+	(digit 0)
+	(index (or start 0))
+	(end (or end (length string))))
+    (when (< index end)
+      (let ((sign (aref string index)))
+	(if (or (eq sign ?+) (eq sign ?-))
+	    (setq sign (parse-time-string-chars sign)
+		  index (1+ index))
+	  (setq sign 1))
+	(while (and (< index end)
+		    (setq digit (digit-char-p (aref string index))))
+	  (setq integer (+ (* integer 10) digit)
+		index (1+ index)))
+	(if (/= index end)
+	    (signal 'parse-error `("not an integer" ,(substring string (or start 0) end)))
+	  (* sign integer))))))
+
+(defun parse-time-tokenize (string)
+  "Tokenize STRING into substrings."
+  (let ((start nil)
+	(end (length string))
+	(all-digits nil)
+	(list ())
+	(index 0)
+	(c nil))
+    (while (< index end)
+      (while (and (< index end)		;skip invalid characters
+		  (not (setq c (parse-time-string-chars (aref string index)))))
+	(incf index))
+      (setq start index all-digits (eq c ?0))
+      (while (and (< (incf index) end)	;scan valid characters
+		  (setq c (parse-time-string-chars (aref string index))))
+	(setq all-digits (and all-digits (eq c ?0))))
+      (if (<= index end)
+	  (push (if all-digits (parse-integer string start index)
+		  (substring string start index))
+		list)))
+    (nreverse list)))
+
+(defvar parse-time-months '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3)
+			    ("Apr" . 4) ("May" . 5) ("Jun" . 6)
+			    ("Jul" . 7) ("Aug" . 8) ("Sep" . 9)
+			    ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))
+(defvar parse-time-weekdays '(("Sun" . 0) ("Mon" . 1) ("Tue" . 2)
+			      ("Wed" . 3) ("Thu" . 4) ("Fri" . 5) ("Sat" . 6)))
+(defvar parse-time-zoneinfo `(("Z" 0) ("UT" 0) ("GMT" 0)
+			      ("PST" ,(* -8 3600)) ("PDT" ,(* -7 3600) t)
+			      ("MST" ,(* -7 3600)) ("MDT" ,(* -6 3600) t)
+			      ("CST" ,(* -6 3600)) ("CDT" ,(* -5 3600) t)
+			      ("EST" ,(* -5 3600)) ("EDT" ,(* -4 3600) t))
+  "(zoneinfo seconds-off daylight-savings-time-p)")
+
+(defvar parse-time-rules
+  `(((6) parse-time-weekdays)
+    ((3) (1 31))
+    ((4) parse-time-months)
+    ((5) (1970 2038))
+    ((2 1 0)
+     ,#'(lambda () (and (stringp elt)
+			(= (length elt) 8)
+			(= (aref elt 2) ?:)
+			(= (aref elt 5) ?:)))
+     [0 2] [3 5] [6 8])
+    ((8 7) parse-time-zoneinfo
+     ,#'(lambda () (car val))
+     ,#'(lambda () (cadr val)))
+    ((8)
+     ,#'(lambda ()
+	  (and (stringp elt)
+	       (= 5 (length elt))
+	       (or (= (aref elt 0) ?+) (= (aref elt 0) ?-))))
+     ,#'(lambda () (* 60 (+ (parse-integer elt 3 5)
+			    (* 60 (parse-integer elt 1 3)))
+		      (if (= (aref elt 0) ?-) -1 1))))
+    ((5 4 3)
+     ,#'(lambda () (and (stringp elt) (= (length elt) 10) (= (aref elt 4) ?-) (= (aref elt 7) ?-)))
+     [0 4] [5 7] [8 10])
+    ((2 1)
+     ,#'(lambda () (and (stringp elt) (= (length elt) 5) (= (aref elt 2) ?:)))
+     [0 2] [3 5])
+    ((5) (70 99) ,#'(lambda () (+ 1900 elt))))
+  "(slots predicate extractor...)")
+
+(defun parse-time-string (string)
+  "Parse the time-string STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ).
+The values are identical to those of `decode-time', but any values that are
+unknown are returned as nil."
+  (let ((time (list nil nil nil nil nil nil nil nil nil nil))
+	(temp (parse-time-tokenize string)))
+    (while temp
+      (let ((elt (pop temp))
+	    (rules parse-time-rules)
+	    (exit nil))
+	(while (and (not (null rules)) (not exit))
+	  (let* ((rule (pop rules))
+		 (slots (pop rule))
+		 (predicate (pop rule))
+		 (val))
+	    (if (and (not (nth (car slots) time)) ;not already set
+		     (setq val (cond ((and (consp predicate)
+					   (not (eq (car predicate) 'lambda)))
+				      (and (numberp elt)
+					   (<= (car predicate) elt)
+					   (<= elt (cadr predicate))
+					   elt))
+				     ((symbolp predicate)
+				      (cdr (assoc elt (symbol-value predicate))))
+				     ((funcall predicate)))))
+		(progn
+		  (setq exit t)
+		  (while slots
+		    (let ((new-val (and rule
+					(let ((this (pop rule)))
+					  (if (vectorp this)
+					      (parse-integer elt (aref this 0) (aref this 1))
+					    (funcall this))))))
+		      (rplaca (nthcdr (pop slots) time) (or new-val val))))))))))
+    time))
+
+(provide 'parse-time)
+
+;;; parse-time.el ends here

lisp/gnus/pop3.el

@@ -0,0 +1,443 @@
+;;; pop3.el --- Post Office Protocol (RFC 1460) interface
+
+;; Copyright (C) 1996, Free Software Foundation, Inc.
+
+;; Author: Richard L. Pieri <ratinox@peorth.gweep.net>
+;; Keywords: mail, pop3
+;; Version: 1.3e
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; Most of the standard Post Office Protocol version 3 (RFC 1460) commands
+;; are implemented.  The LIST command has not been implemented due to lack
+;; of actual usefulness.
+;; The optional POP3 command TOP has not been implemented.
+
+;; This program was inspired by Kyle E. Jones's vm-pop program.
+
+;;; Code:
+
+(require 'mail-utils)
+(provide 'pop3)
+
+(defconst pop3-version "1.3c")
+
+(defvar pop3-maildrop (or user-login-name (getenv "LOGNAME") (getenv "USER") nil)
+  "*POP3 maildrop.")
+(defvar pop3-mailhost (or (getenv "MAILHOST") nil)
+  "*POP3 mailhost.")
+(defvar pop3-port 110
+  "*POP3 port.")
+
+(defvar pop3-password-required t
+  "*Non-nil if a password is required when connecting to POP server.")
+(defvar pop3-password nil
+  "*Password to use when connecting to POP server.")
+
+(defvar pop3-authentication-scheme 'pass
+  "*POP3 authentication scheme.
+Defaults to 'pass, for the standard USER/PASS authentication.  Other valid
+values are 'apop.")
+
+(defvar pop3-timestamp nil
+  "Timestamp returned when initially connected to the POP server.
+Used for APOP authentication.")
+
+(defvar pop3-read-point nil)
+(defvar pop3-debug nil)
+
+(defun pop3-movemail (&optional crashbox)
+  "Transfer contents of a maildrop to the specified CRASHBOX."
+  (or crashbox (setq crashbox (expand-file-name "~/.crashbox")))
+  (let* ((process (pop3-open-server pop3-mailhost pop3-port))
+	 (crashbuf (get-buffer-create " *pop3-retr*"))
+	 (n 1)
+	 message-count)
+    ;; for debugging only
+    (if pop3-debug (switch-to-buffer (process-buffer process)))
+    (cond ((equal 'apop pop3-authentication-scheme)
+	   (pop3-apop process pop3-maildrop))
+	  ((equal 'pass pop3-authentication-scheme)
+	   (pop3-user process pop3-maildrop)
+	   (pop3-pass process))
+	  (t (error "Invalid POP3 authentication scheme.")))
+    (setq message-count (car (pop3-stat process)))
+    (while (<= n message-count)
+      (message (format "Retrieving message %d of %d from %s..."
+		       n message-count pop3-mailhost))
+      (pop3-retr process n crashbuf)
+      (save-excursion
+	(set-buffer crashbuf)
+	(append-to-file (point-min) (point-max) crashbox)
+	(set-buffer (process-buffer process))
+	(while (> (buffer-size) 5000)
+	  (goto-char (point-min))
+	  (forward-line 50)
+	  (delete-region (point-min) (point))))
+      (pop3-dele process n)
+      (setq n (+ 1 n))
+      (if pop3-debug (sit-for 1) (sit-for 0.1))
+      )
+    (pop3-quit process)
+    (kill-buffer crashbuf)
+    )
+  )
+
+(defun pop3-open-server (mailhost port)
+  "Open TCP connection to MAILHOST.
+Returns the process associated with the connection."
+  (let ((process-buffer
+	 (get-buffer-create (format "trace of POP session to %s" mailhost)))
+	(process))
+    (save-excursion
+      (set-buffer process-buffer)
+      (erase-buffer))
+    (setq process
+	  (open-network-stream "POP" process-buffer mailhost port))
+    (setq pop3-read-point (point-min))
+    (let ((response (pop3-read-response process t)))
+      (setq pop3-timestamp
+	    (substring response (or (string-match "<" response) 0)
+		       (+ 1 (or (string-match ">" response) -1)))))
+    process
+    ))
+
+;; Support functions
+
+(defun pop3-process-filter (process output)
+  (save-excursion
+    (set-buffer (process-buffer process))
+    (goto-char (point-max))
+    (insert output)))
+
+(defun pop3-send-command (process command)
+    (set-buffer (process-buffer process))
+    (goto-char (point-max))
+;;    (if (= (aref command 0) ?P)
+;;	(insert "PASS <omitted>\r\n")
+;;      (insert command "\r\n"))
+    (setq pop3-read-point (point))
+    (goto-char (point-max))
+    (process-send-string process command)
+    (process-send-string process "\r\n")
+    )
+
+(defun pop3-read-response (process &optional return)
+  "Read the response from the server.
+Return the response string if optional second argument is non-nil."
+  (let ((case-fold-search nil)
+	match-end)
+    (save-excursion
+      (set-buffer (process-buffer process))
+      (goto-char pop3-read-point)
+      (while (not (search-forward "\r\n" nil t))
+	(accept-process-output process)
+	(goto-char pop3-read-point))
+      (setq match-end (point))
+      (goto-char pop3-read-point)
+      (if (looking-at "-ERR")
+	  (error (buffer-substring (point) (- match-end 2)))
+	(if (not (looking-at "+OK"))
+	    (progn (setq pop3-read-point match-end) nil)
+	  (setq pop3-read-point match-end)
+	  (if return
+	      (buffer-substring (point) match-end)
+	    t)
+	  )))))
+
+(defun pop3-string-to-list (string &optional regexp)
+  "Chop up a string into a list."
+  (let ((list)
+	(regexp (or regexp " "))
+	(string (if (string-match "\r" string)
+		    (substring string 0 (match-beginning 0))
+		  string)))
+    (store-match-data nil)
+    (while string
+      (if (string-match regexp string)
+	  (setq list (cons (substring string 0 (- (match-end 0) 1)) list)
+		string (substring string (match-end 0)))
+	(setq list (cons string list)
+	      string nil)))
+    (nreverse list)))
+
+(defvar pop3-read-passwd nil)
+(defun pop3-read-passwd (prompt)
+  (if (not pop3-read-passwd)
+      (if (load "passwd" t)
+	  (setq pop3-read-passwd 'read-passwd)
+	(autoload 'ange-ftp-read-passwd "ange-ftp")
+	(setq pop3-read-passwd 'ange-ftp-read-passwd)))
+  (funcall pop3-read-passwd prompt))
+
+(defun pop3-clean-region (start end)
+  (setq end (set-marker (make-marker) end))
+  (save-excursion
+    (goto-char start)
+    (while (and (< (point) end) (search-forward "\r\n" end t))
+      (replace-match "\n" t t))
+    (goto-char start)
+    (while (and (< (point) end) (re-search-forward "^\\." end t))
+      (replace-match "" t t)
+      (forward-char)))
+  (set-marker end nil))
+
+(defun pop3-munge-message-separator (start end)
+  "Check to see if a message separator exists.  If not, generate one."
+  (save-excursion
+    (save-restriction
+      (narrow-to-region start end)
+      (goto-char (point-min))
+      (if (not (or (looking-at "From .?") ; Unix mail
+		   (looking-at "\001\001\001\001\n") ; MMDF
+		   (looking-at "BABYL OPTIONS:") ; Babyl
+		   ))
+	  (let ((from (mail-strip-quoted-names (mail-fetch-field "From")))
+		(date (pop3-string-to-list (mail-fetch-field "Date")))
+		(From_))
+	    ;; sample date formats I have seen
+	    ;; Date: Tue, 9 Jul 1996 09:04:21 -0400 (EDT)
+	    ;; Date: 08 Jul 1996 23:22:24 -0400
+	    ;; should be
+	    ;; Tue Jul 9 09:04:21 1996
+	    (setq date
+		  (cond ((string-match "[A-Z]" (nth 0 date))
+			 (format "%s %s %s %s %s"
+				 (nth 0 date) (nth 2 date) (nth 1 date)
+				 (nth 4 date) (nth 3 date)))
+			(t
+			 ;; this really needs to be better but I don't feel
+			 ;; like writing a date to day converter.
+			 (format "Sun %s %s %s %s"
+				 (nth 1 date) (nth 0 date)
+				 (nth 3 date) (nth 2 date)))
+			))
+	    (setq From_ (format "\nFrom %s  %s\n" from date))
+	    (while (string-match "," From_)
+	      (setq From_ (concat (substring From_ 0 (match-beginning 0))
+				  (substring From_ (match-end 0)))))
+	    (goto-char (point-min))
+	    (insert From_))))))
+
+;; The Command Set
+
+;; AUTHORIZATION STATE
+
+(defun pop3-user (process user)
+  "Send USER information to POP3 server."
+  (pop3-send-command process (format "USER %s" user))
+  (let ((response (pop3-read-response process t)))
+    (if (not (and response (string-match "+OK" response)))
+	(error (format "USER %s not valid." user)))))
+
+(defun pop3-pass (process)
+  "Send authentication information to the server."
+  (let ((pass pop3-password))
+    (if (and pop3-password-required (not pass))
+	(setq pass
+	      (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
+    (if pass
+	(progn
+	  (pop3-send-command process (format "PASS %s" pass))
+	  (let ((response (pop3-read-response process t)))
+	    (if (not (and response (string-match "+OK" response)))
+		(pop3-quit process)))))
+    ))
+
+(defun pop3-apop (process user)
+  "Send alternate authentication information to the server."
+  (if (not (fboundp 'md5)) (autoload 'md5 "md5"))
+  (let ((pass pop3-password))
+    (if (and pop3-password-required (not pass))
+	(setq pass
+	      (pop3-read-passwd (format "Password for %s: " pop3-maildrop))))
+    (if pass
+	(let ((hash (md5 (concat pop3-timestamp pass))))
+	  (pop3-send-command process (format "APOP %s %s" user hash))
+	  (let ((response (pop3-read-response process t)))
+	    (if (not (and response (string-match "+OK" response)))
+		(pop3-quit process)))))
+    ))
+
+;; TRANSACTION STATE
+
+(defun pop3-stat (process)
+  "Return the number of messages in the maildrop and the maildrop's size."
+  (pop3-send-command process "STAT")
+  (let ((response (pop3-read-response process t)))
+    (list (string-to-int (nth 1 (pop3-string-to-list response)))
+	  (string-to-int (nth 2 (pop3-string-to-list response))))
+    ))
+
+(defun pop3-list (process &optional msg)
+  "Scan listing of available messages.
+This function currently does nothing.")
+
+(defun pop3-retr (process msg crashbuf)
+  "Retrieve message-id MSG to buffer CRASHBUF."
+  (pop3-send-command process (format "RETR %s" msg))
+  (pop3-read-response process)
+  (let ((start pop3-read-point) end)
+    (save-excursion
+      (set-buffer (process-buffer process))
+      (while (not (re-search-forward "^\\.\r\n" nil t))
+	(accept-process-output process)
+	;; bill@att.com ... to save wear and tear on the heap
+	(if (> (buffer-size)  20000) (sleep-for 1))
+	(if (> (buffer-size)  50000) (sleep-for 1))
+	(if (> (buffer-size) 100000) (sleep-for 1))
+	(if (> (buffer-size) 200000) (sleep-for 1))
+	(if (> (buffer-size) 500000) (sleep-for 1))
+	;; bill@att.com
+	(goto-char start))
+      (setq pop3-read-point (point-marker))
+;; this code does not seem to work for some POP servers...
+;; and I cannot figure out why not.
+;      (goto-char (match-beginning 0))
+;      (backward-char 2)
+;      (if (not (looking-at "\r\n"))
+;	  (insert "\r\n"))
+;      (re-search-forward "\\.\r\n")
+      (goto-char (match-beginning 0))
+      (setq end (point-marker))
+      (pop3-clean-region start end)
+      (pop3-munge-message-separator start end)
+      (save-excursion
+	(set-buffer crashbuf)
+	(erase-buffer))
+      (copy-to-buffer crashbuf start end)
+      (delete-region start end)
+      )))
+
+(defun pop3-dele (process msg)
+  "Mark message-id MSG as deleted."
+  (pop3-send-command process (format "DELE %s" msg))
+  (pop3-read-response process))
+
+(defun pop3-noop (process msg)
+  "No-operation."
+  (pop3-send-command process "NOOP")
+  (pop3-read-response process))
+
+(defun pop3-last (process)
+  "Return highest accessed message-id number for the session."
+  (pop3-send-command process "LAST")
+  (let ((response (pop3-read-response process t)))
+    (string-to-int (nth 1 (pop3-string-to-list response)))
+    ))
+
+(defun pop3-rset (process)
+  "Remove all delete marks from current maildrop."
+  (pop3-send-command process "RSET")
+  (pop3-read-response process))
+
+;; UPDATE
+
+(defun pop3-quit (process)
+  "Close connection to POP3 server.
+Tell server to remove all messages marked as deleted, unlock the maildrop,
+and close the connection."
+  (pop3-send-command process "QUIT")
+  (pop3-read-response process t)
+  (if process
+      (save-excursion
+	(set-buffer (process-buffer process))
+	(goto-char (point-max))
+	(delete-process process))))
+
+;; Summary of POP3 (Post Office Protocol version 3) commands and responses
+
+;;; AUTHORIZATION STATE
+
+;; Initial TCP connection
+;; Arguments: none
+;; Restrictions: none
+;; Possible responses:
+;;  +OK [POP3 server ready]
+
+;; USER name
+;; Arguments: a server specific user-id (required)
+;; Restrictions: authorization state [after unsuccessful USER or PASS
+;; Possible responses:
+;;  +OK [valid user-id]
+;;  -ERR [invalid user-id]
+
+;; PASS string
+;; Arguments: a server/user-id specific password (required)
+;; Restrictions: authorization state, after successful USER
+;; Possible responses:
+;;  +OK [maildrop locked and ready]
+;;  -ERR [invalid password]
+;;  -ERR [unable to lock maildrop]
+
+;;; TRANSACTION STATE
+
+;; STAT
+;; Arguments: none
+;; Restrictions: transaction state
+;; Possible responses:
+;;  +OK nn mm [# of messages, size of maildrop]
+
+;; LIST [msg]
+;; Arguments: a message-id (optional)
+;; Restrictions: transaction state; msg must not be deleted
+;; Possible responses:
+;;  +OK [scan listing follows]
+;;  -ERR [no such message]
+
+;; RETR msg
+;; Arguments: a message-id (required)
+;; Restrictions: transaction state; msg must not be deleted
+;; Possible responses:
+;;  +OK [message contents follow]
+;;  -ERR [no such message]
+
+;; DELE msg
+;; Arguments: a message-id (required)
+;; Restrictions: transaction state; msg must not be deleted
+;; Possible responses:
+;;  +OK [message deleted]
+;;  -ERR [no such message]
+
+;; NOOP
+;; Arguments: none
+;; Restrictions: transaction state
+;; Possible responses:
+;;  +OK
+
+;; LAST
+;; Arguments: none
+;; Restrictions: transaction state
+;; Possible responses:
+;;  +OK nn [highest numbered message accessed]
+
+;; RSET
+;; Arguments: none
+;; Restrictions: transaction state
+;; Possible responses:
+;;  +OK [all delete marks removed]
+
+;;; UPDATE STATE
+
+;; QUIT
+;; Arguments: none
+;; Restrictions: none
+;; Possible responses:
+;;  +OK [TCP connection closed]

lisp/gnus/score-mode.el

@@ -0,0 +1,109 @@
+;;; score-mode.el --- mode for editing Gnus score files
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Keywords: news, mail
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'easymenu)
+(require 'timezone)
+(eval-when-compile (require 'cl))
+
+(defvar gnus-score-mode-hook nil
+  "*Hook run in score mode buffers.")
+
+(defvar gnus-score-menu-hook nil
+  "*Hook run after creating the score mode menu.")
+
+(defvar gnus-score-edit-exit-function nil
+  "Function run on exit from the score buffer.")
+
+(defvar gnus-score-mode-map nil)
+(unless gnus-score-mode-map
+  (setq gnus-score-mode-map (copy-keymap emacs-lisp-mode-map))
+  (define-key gnus-score-mode-map "\C-c\C-c" 'gnus-score-edit-exit)
+  (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date)
+  (define-key gnus-score-mode-map "\C-c\C-p" 'gnus-score-pretty-print))
+
+;;;###autoload
+(defun gnus-score-mode ()
+  "Mode for editing Gnus score files.
+This mode is an extended emacs-lisp mode.
+
+\\{gnus-score-mode-map}"
+  (interactive)
+  (kill-all-local-variables)
+  (use-local-map gnus-score-mode-map)
+  (gnus-score-make-menu-bar)
+  (set-syntax-table emacs-lisp-mode-syntax-table)
+  (setq major-mode 'gnus-score-mode)
+  (setq mode-name "Score")
+  (lisp-mode-variables nil)
+  (make-local-variable 'gnus-score-edit-exit-function)
+  (run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook))
+
+(defun gnus-score-make-menu-bar ()
+  (unless (boundp 'gnus-score-menu)
+    (easy-menu-define
+     gnus-score-menu gnus-score-mode-map ""
+     '("Score"
+       ["Exit" gnus-score-edit-exit t]
+       ["Insert date" gnus-score-edit-insert-date t]
+       ["Format" gnus-score-pretty-print t]))
+    (run-hooks 'gnus-score-menu-hook)))
+
+(defun gnus-score-edit-insert-date ()
+  "Insert date in numerical format."
+  (interactive)
+  (princ (gnus-score-day-number (current-time)) (current-buffer)))
+
+(defun gnus-score-pretty-print ()
+  "Format the current score file."
+  (interactive)
+  (goto-char (point-min))
+  (let ((form (read (current-buffer))))
+    (erase-buffer)
+    (pp form (current-buffer)))
+  (goto-char (point-min)))
+
+(defun gnus-score-edit-exit ()
+  "Stop editing the score file."
+  (interactive)
+  (unless (file-exists-p (file-name-directory (buffer-file-name)))
+    (make-directory (file-name-directory (buffer-file-name)) t))
+  (save-buffer)
+  (bury-buffer (current-buffer))
+  (let ((buf (current-buffer)))
+    (when gnus-score-edit-exit-function
+      (funcall gnus-score-edit-exit-function))
+    (when (eq buf (current-buffer))
+      (switch-to-buffer (other-buffer (current-buffer))))))
+
+(defun gnus-score-day-number (time)
+  (let ((dat (decode-time time)))
+    (timezone-absolute-from-gregorian
+     (nth 4 dat) (nth 3 dat) (nth 5 dat))))
+
+(provide 'score-mode)
+
+;;; score-mode.el ends here