summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lisp/=custom.el2429
-rw-r--r--lisp/gnus-cache.el361
-rw-r--r--lisp/gnus-cite.el585
-rw-r--r--lisp/gnus-cus.el546
-rw-r--r--lisp/gnus-edit.el628
-rw-r--r--lisp/gnus-ems.el693
-rw-r--r--lisp/gnus-kill.el633
-rw-r--r--lisp/gnus-mh.el226
-rw-r--r--lisp/gnus-msg.el1803
-rw-r--r--lisp/gnus-score.el1643
-rw-r--r--lisp/gnus-uu.el1889
-rw-r--r--lisp/gnus-vis.el1428
-rw-r--r--lisp/gnus-vm.el261
-rw-r--r--lisp/gnus.el14136
-rw-r--r--lisp/nnbabyl.el578
-rw-r--r--lisp/nndir.el141
-rw-r--r--lisp/nndoc.el400
-rw-r--r--lisp/nneething.el334
-rw-r--r--lisp/nnfolder.el704
-rw-r--r--lisp/nnheader.el358
-rw-r--r--lisp/nnkiboze.el345
-rw-r--r--lisp/nnmail.el877
-rw-r--r--lisp/nnmbox.el508
-rw-r--r--lisp/nnmh.el516
-rw-r--r--lisp/nnml.el701
-rw-r--r--lisp/nnspool.el492
-rw-r--r--lisp/nntp.el1275
-rw-r--r--lisp/nnvirtual.el476
28 files changed, 34966 insertions, 0 deletions
diff --git a/lisp/=custom.el b/lisp/=custom.el
new file mode 100644
index 00000000000..c4e7a4a870a
--- /dev/null
+++ b/lisp/=custom.el
@@ -0,0 +1,2429 @@
+;;; custom.el --- User friendly customization support.
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;;
+;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
+;; Keywords: help
+;; Version: 0.5
+
+;;; Commentary:
+;;
+;; WARNING: This package is still under construction and not all of
+;; the features below are implemented.
+;;
+;; This package provides a framework for adding user friendly
+;; customization support to Emacs. Having to do customization by
+;; editing a text file in some arcane syntax is user hostile in the
+;; extreme, and to most users emacs lisp definitely count as arcane.
+;;
+;; The intension is that authors of emacs lisp packages declare the
+;; variables intended for user customization with `custom-declare'.
+;; Custom can then automatically generate a customization buffer with
+;; `custom-buffer-create' where the user can edit the package
+;; variables in a simple and intuitive way, as well as a menu with
+;; `custom-menu-create' where he can set the more commonly used
+;; variables interactively.
+;;
+;; It is also possible to use custom for modifying the properties of
+;; other objects than the package itself, by specifying extra optional
+;; arguments to `custom-buffer-create'.
+;;
+;; Custom is inspired by OPEN LOOK property windows.
+
+;;; Todo:
+;;
+;; - Toggle documentation in three states `none', `one-line', `full'.
+;; - Function to generate an XEmacs menu from a CUSTOM.
+;; - Write TeXinfo documentation.
+;; - Make it possible to hide sections by clicking at the level.
+;; - Declare AUC TeX variables.
+;; - Declare (ding) Gnus variables.
+;; - Declare Emacs variables.
+;; - Implement remaining types.
+;; - XEmacs port.
+;; - Allow `URL', `info', and internal hypertext buttons.
+;; - Support meta-variables and goal directed customization.
+;; - Make it easy to declare custom types independently.
+;; - Make it possible to declare default value and type for a single
+;; variable, storing the data in a symbol property.
+;; - Syntactic sugar for CUSTOM declarations.
+;; - Use W3 for variable documenation.
+
+;;; Code:
+
+;;; Compatibility:
+
+(or (fboundp 'buffer-substring-no-properties)
+ ;; Introduced in Emacs 19.29.
+ (defun buffer-substring-no-properties (beg end)
+ "Return the text from BEG to END, without text properties, as a string."
+ (let ((string (buffer-substring beg end)))
+ (set-text-properties 0 (length string) nil string)
+ string)))
+
+(or (fboundp 'add-to-list)
+ ;; Introduced in Emacs 19.29.
+ (defun add-to-list (list-var element)
+ "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
+If you want to use `add-to-list' on a variable that is not defined
+until a certain package is loaded, you should put the call to `add-to-list'
+into a hook function that will be run only after loading the package.
+`eval-after-load' provides one way to do this. In some cases
+other hooks, such as major mode hooks, can do the job."
+ (or (member element (symbol-value list-var))
+ (set list-var (cons element (symbol-value list-var))))))
+
+(or (fboundp 'plist-get)
+ ;; Introduced in Emacs 19.29.
+ (defun plist-get (plist prop)
+ "Extract a value from a property list.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value
+corresponding to the given PROP, or nil if PROP is not
+one of the properties on the list."
+ (let (result)
+ (while plist
+ (if (eq (car plist) prop)
+ (setq result (car (cdr plist))
+ plist nil)
+ (set plist (cdr (cdr plist)))))
+ result)))
+
+(or (fboundp 'plist-put)
+ ;; Introduced in Emacs 19.29.
+ (defun plist-put (plist prop val)
+ "Change value in PLIST of PROP to VAL.
+PLIST is a property list, which is a list of the form
+\(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object.
+If PROP is already a property on the list, its value is set to VAL,
+otherwise the new PROP VAL pair is added. The new plist is returned;
+use `(setq x (plist-put x prop val))' to be sure to use the new value.
+The PLIST is modified by side effects."
+ (if (null plist)
+ (list prop val)
+ (let ((current plist))
+ (while current
+ (cond ((eq (car current) prop)
+ (setcar (cdr current) val)
+ (setq current nil))
+ ((null (cdr (cdr current)))
+ (setcdr (cdr current) (list prop val))
+ (setq current nil))
+ (t
+ (setq current (cdr (cdr current)))))))
+ plist)))
+
+(or (fboundp 'match-string)
+ ;; Introduced in Emacs 19.29.
+ (defun match-string (num &optional string)
+ "Return string of text matched by last search.
+NUM specifies which parenthesized expression in the last regexp.
+ Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
+Zero means the entire text matched by the whole regexp or whole string.
+STRING should be given if the last search was by `string-match' on STRING."
+ (if (match-beginning num)
+ (if string
+ (substring string (match-beginning num) (match-end num))
+ (buffer-substring (match-beginning num) (match-end num))))))
+
+(or (fboundp 'facep)
+ ;; Introduced in Emacs 19.29.
+ (defun facep (x)
+ "Return t if X is a face name or an internal face vector."
+ (and (or (and (fboundp 'internal-facep) (internal-facep x))
+ (and
+ (symbolp x)
+ (assq x (and (boundp 'global-face-data) global-face-data))))
+ t)))
+
+;; XEmacs and Emacs 19.29 facep does different things.
+(if (fboundp 'find-face)
+ (fset 'custom-facep 'find-face)
+ (fset 'custom-facep 'facep))
+
+(if (custom-facep 'underline)
+ ()
+ ;; No underline face in XEmacs 19.12.
+ (and (fboundp 'make-face)
+ (funcall (intern "make-face") 'underline))
+ ;; Must avoid calling set-face-underline-p directly, because it
+ ;; is a defsubst in emacs19, and will make the .elc files non
+ ;; portable!
+ (or (and (fboundp 'face-differs-from-default-p)
+ (face-differs-from-default-p 'underline))
+ (and (fboundp 'set-face-underline-p)
+ (funcall 'set-face-underline-p 'underline t))))
+
+(or (fboundp 'set-text-properties)
+ ;; Missing in XEmacs 19.12.
+ (defun set-text-properties (start end props &optional buffer)
+ (if (or (null buffer) (bufferp buffer))
+ (if props
+ (while props
+ (put-text-property
+ start end (car props) (nth 1 props) buffer)
+ (setq props (nthcdr 2 props)))
+ (remove-text-properties start end ())))))
+
+(or (fboundp 'event-closest-point)
+ ;; Missing in Emacs 19.29.
+ (defun event-point (event)
+ "Return the character position of the given mouse-motion, button-press,
+or button-release event. If the event did not occur over a window, or did
+not occur over text, then this returns nil. Otherwise, it returns an index
+into the buffer visible in the event's window."
+ (posn-point (event-start event))))
+
+(eval-when-compile
+ (defvar x-colors nil)
+ (defvar custom-button-face nil)
+ (defvar custom-field-uninitialized-face nil)
+ (defvar custom-field-invalid-face nil)
+ (defvar custom-field-modified-face nil)
+ (defvar custom-field-face nil)
+ (defvar custom-mouse-face nil)
+ (defvar custom-field-active-face nil))
+
+(or (and (fboundp 'modify-face) (not (featurep 'face-lock)))
+ ;; Introduced in Emacs 19.29. Incompatible definition also introduced
+ ;; by face-lock.el version 3.00 and above for Emacs 19.28 and below.
+ ;; face-lock does not call modify-face, so we can safely redefine it.
+ (defun modify-face (face foreground background stipple
+ bold-p italic-p underline-p)
+ "Change the display attributes for face FACE.
+FOREGROUND and BACKGROUND should be color strings or nil.
+STIPPLE should be a stipple pattern name or nil.
+BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold,
+in italic, and underlined, respectively. (Yes if non-nil.)
+If called interactively, prompts for a face and face attributes."
+ (interactive
+ (let* ((completion-ignore-case t)
+ (face (symbol-name (read-face-name "Modify face: ")))
+ (colors (mapcar 'list x-colors))
+ (stipples (mapcar 'list
+ (apply 'nconc
+ (mapcar 'directory-files
+ x-bitmap-file-path))))
+ (foreground (modify-face-read-string
+ face (face-foreground (intern face))
+ "foreground" colors))
+ (background (modify-face-read-string
+ face (face-background (intern face))
+ "background" colors))
+ (stipple (modify-face-read-string
+ face (face-stipple (intern face))
+ "stipple" stipples))
+ (bold-p (y-or-n-p (concat "Set face " face " bold ")))
+ (italic-p (y-or-n-p (concat "Set face " face " italic ")))
+ (underline-p (y-or-n-p (concat "Set face " face " underline "))))
+ (message "Face %s: %s" face
+ (mapconcat 'identity
+ (delq nil
+ (list (and foreground (concat (downcase foreground) " foreground"))
+ (and background (concat (downcase background) " background"))
+ (and stipple (concat (downcase stipple) " stipple"))
+ (and bold-p "bold") (and italic-p "italic")
+ (and underline-p "underline"))) ", "))
+ (list (intern face) foreground background stipple
+ bold-p italic-p underline-p)))
+ (condition-case nil (set-face-foreground face foreground) (error nil))
+ (condition-case nil (set-face-background face background) (error nil))
+ (condition-case nil (set-face-stipple face stipple) (error nil))
+ (if (string-match "XEmacs" emacs-version)
+ (progn
+ (funcall (if bold-p 'make-face-bold 'make-face-unbold) face)
+ (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face))
+ (funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t)
+ (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t))
+ (set-face-underline-p face underline-p)
+ (and (interactive-p) (redraw-display))))
+
+;; We can't easily check for a working intangible.
+(defconst intangible (if (and (boundp 'emacs-minor-version)
+ (or (> emacs-major-version 19)
+ (and (> emacs-major-version 18)
+ (> emacs-minor-version 28))))
+ (setq intangible 'intangible)
+ (setq intangible 'intangible-if-it-had-been-working))
+ "The symbol making text intangible")
+
+(defconst rear-nonsticky (if (string-match "XEmacs" emacs-version)
+ 'end-open
+ 'rear-nonsticky)
+ "The symbol making text proeprties non-sticky in the rear end.")
+
+(defconst front-sticky (if (string-match "XEmacs" emacs-version)
+ 'front-closed
+ 'front-sticky)
+ "The symbol making text properties sticky in the front.")
+
+(defconst mouse-face (if (string-match "XEmacs" emacs-version)
+ 'highlight
+ 'mouse-face)
+ "Symbol used for highlighting text under mouse.")
+
+;; Put it in the Help menu, if possible.
+(if (string-match "XEmacs" emacs-version)
+ ;; XEmacs (disabled because it doesn't work)
+ (and current-menubar
+ (add-menu-item '("Help") "Customize..." 'customize nil))
+ ;; Emacs 19.28 and earlier
+ (global-set-key [ menu-bar help customize ]
+ '("Customize..." . customize))
+ ;; Emacs 19.29 and later
+ (global-set-key [ menu-bar help-menu customize ]
+ '("Customize..." . customize)))
+
+;; XEmacs popup-menu stolen from w3.el.
+(defun custom-x-really-popup-menu (pos title menudesc)
+ "My hacked up function to do a blocking popup menu..."
+ (let ((echo-keystrokes 0)
+ event menu)
+ (while menudesc
+ (setq menu (cons (vector (car (car menudesc))
+ (list (car (car menudesc))) t) menu)
+ menudesc (cdr menudesc)))
+ (setq menu (cons title menu))
+ (popup-menu menu)
+ (catch 'popup-done
+ (while t
+ (setq event (next-command-event event))
+ (cond ((and (misc-user-event-p event) (stringp (car-safe (event-object event))))
+ (throw 'popup-done (event-object event)))
+ ((and (misc-user-event-p event)
+ (or (eq (event-object event) 'abort)
+ (eq (event-object event) 'menu-no-selection-hook)))
+ nil)
+ ((not (popup-menu-up-p))
+ (throw 'popup-done nil))
+ ((button-release-event-p event);; don't beep twice
+ nil)
+ (t
+ (beep)
+ (message "please make a choice from the menu.")))))))
+
+;;; Categories:
+;;
+;; XEmacs use inheritable extents for the same purpose as Emacs uses
+;; the category text property.
+
+(if (string-match "XEmacs" emacs-version)
+ (progn
+ ;; XEmacs categories.
+ (defun custom-category-create (name)
+ (set name (make-extent nil nil))
+ "Create a text property category named NAME.")
+
+ (defun custom-category-put (name property value)
+ "In CATEGORY set PROPERTY to VALUE."
+ (set-extent-property (symbol-value name) property value))
+
+ (defun custom-category-get (name property)
+ "In CATEGORY get PROPERTY."
+ (extent-property (symbol-value name) property))
+
+ (defun custom-category-set (from to category)
+ "Make text between FROM and TWO have category CATEGORY."
+ (let ((extent (make-extent from to)))
+ (set-extent-parent extent (symbol-value category)))))
+
+ ;; Emacs categories.
+ (defun custom-category-create (name)
+ "Create a text property category named NAME."
+ (set name name))
+
+ (defun custom-category-put (name property value)
+ "In CATEGORY set PROPERTY to VALUE."
+ (put name property value))
+
+ (defun custom-category-get (name property)
+ "In CATEGORY get PROPERTY."
+ (get name property))
+
+ (defun custom-category-set (from to category)
+ "Make text between FROM and TWO have category CATEGORY."
+ (put-text-property from to 'category category)))
+
+;;; External Data:
+;;
+;; The following functions and variables defines the interface for
+;; connecting a CUSTOM with an external entity, by default an emacs
+;; lisp variable.
+
+(defvar custom-external 'default-value
+ "Function returning the external value of NAME.")
+
+(defvar custom-external-set 'set-default
+ "Function setting the external value of NAME to VALUE.")
+
+(defun custom-external (name)
+ "Get the external value associated with NAME."
+ (funcall custom-external name))
+
+(defun custom-external-set (name value)
+ "Set the external value associated with NAME to VALUE."
+ (funcall custom-external-set name value))
+
+(defvar custom-name-fields nil
+ "Alist of custom names and their associated editing field.")
+(make-variable-buffer-local 'custom-name-fields)
+
+(defun custom-name-enter (name field)
+ "Associate NAME with FIELD."
+ (if (null name)
+ ()
+ (custom-assert 'field)
+ (setq custom-name-fields (cons (cons name field) custom-name-fields))))
+
+(defun custom-name-field (name)
+ "The editing field associated with NAME."
+ (cdr (assq name custom-name-fields)))
+
+(defun custom-name-value (name)
+ "The value currently displayed for NAME in the customization buffer."
+ (let* ((field (custom-name-field name))
+ (custom (custom-field-custom field)))
+ (custom-field-parse field)
+ (funcall (custom-property custom 'export) custom
+ (car (custom-field-extract custom field)))))
+
+(defvar custom-save 'custom-save
+ "Function that will save current customization buffer.")
+
+;;; Custom Functions:
+;;
+;; The following functions are part of the public interface to the
+;; CUSTOM datastructure. Each CUSTOM describes a group of variables,
+;; a single variable, or a component of a structured variable. The
+;; CUSTOM instances are part of two hiearachies, the first is the
+;; `part-of' hierarchy in which each CUSTOM is a component of another
+;; CUSTOM, except for the top level CUSTOM which is contained in
+;; `custom-data'. The second hiearachy is a `is-a' type hierarchy
+;; where each CUSTOM is a leaf in the hierarchy defined by the `type'
+;; property and `custom-type-properties'.
+
+(defvar custom-file "~/.custom.el"
+ "Name of file with customization information.")
+
+(defconst custom-data
+ '((tag . "Emacs")
+ (doc . "The extensible self-documenting text editor.")
+ (type . group)
+ (data "\n"
+ ((header . nil)
+ (compact . t)
+ (type . group)
+ (doc . "\
+Press [Save] to save any changes permanently after you are done editing.
+You can load customization information from other files by editing the
+`File' field and pressing the [Load] button. When you press [Save] the
+customization information of all files you have loaded, plus any
+changes you might have made manually, will be stored in the file
+specified by the `File' field.")
+ (data ((tag . "Load")
+ (type . button)
+ (query . custom-load))
+ ((tag . "Save")
+ (type . button)
+ (query . custom-save))
+ ((name . custom-file)
+ (default . "~/.custom.el")
+ (doc . "Name of file with customization information.\n")
+ (tag . "File")
+ (type . file))))))
+ "The global customization information.
+A custom association list.")
+
+(defun custom-declare (path custom)
+ "Declare variables for customization.
+PATH is a list of tags leading to the place in the customization
+hierarchy the new entry should be added. CUSTOM is the entry to add."
+ (custom-initialize custom)
+ (let ((current (custom-travel-path custom-data path)))
+ (or (member custom (custom-data current))
+ (nconc (custom-data current) (list custom)))))
+
+(put 'custom-declare 'lisp-indent-hook 1)
+
+(defconst custom-type-properties
+ '((repeat (type . default)
+ ;; See `custom-match'.
+ (import . custom-repeat-import)
+ (eval . custom-repeat-eval)
+ (quote . custom-repeat-quote)
+ (accept . custom-repeat-accept)
+ (extract . custom-repeat-extract)
+ (validate . custom-repeat-validate)
+ (insert . custom-repeat-insert)
+ (match . custom-repeat-match)
+ (query . custom-repeat-query)
+ (prefix . "")
+ (del-tag . "[DEL]")
+ (add-tag . "[INS]"))
+ (pair (type . group)
+ ;; A cons-cell.
+ (accept . custom-pair-accept)
+ (eval . custom-pair-eval)
+ (import . custom-pair-import)
+ (quote . custom-pair-quote)
+ (valid . (lambda (c d) (consp d)))
+ (extract . custom-pair-extract))
+ (list (type . group)
+ ;; A lisp list.
+ (quote . custom-list-quote)
+ (valid . (lambda (c d)
+ (listp d)))
+ (extract . custom-list-extract))
+ (group (type . default)
+ ;; See `custom-match'.
+ (face-tag . nil)
+ (eval . custom-group-eval)
+ (import . custom-group-import)
+ (initialize . custom-group-initialize)
+ (apply . custom-group-apply)
+ (reset . custom-group-reset)
+ (factory-reset . custom-group-factory-reset)
+ (extract . nil)
+ (validate . custom-group-validate)
+ (query . custom-toggle-hide)
+ (accept . custom-group-accept)
+ (insert . custom-group-insert)
+ (find . custom-group-find))
+ (toggle (type . choice)
+ ;; Booleans.
+ (data ((type . const)
+ (tag . "On ")
+ (default . t))
+ ((type . const)
+ (tag . "Off")
+ (default . nil))))
+ (choice (type . default)
+ ;; See `custom-match'.
+ (query . custom-choice-query)
+ (accept . custom-choice-accept)
+ (extract . custom-choice-extract)
+ (validate . custom-choice-validate)
+ (insert . custom-choice-insert)
+ (none (tag . "Unknown")
+ (default . __uninitialized__)
+ (type . const)))
+ (const (type . default)
+ ;; A `const' only matches a single lisp value.
+ (extract . (lambda (c f) (list (custom-default c))))
+ (validate . (lambda (c f) nil))
+ (valid . custom-const-valid)
+ (update . custom-const-update)
+ (insert . custom-const-insert))
+ (face-doc (type . doc)
+ ;; A variable containing a face.
+ (doc . "\
+You can customize the look of Emacs by deciding which faces should be
+used when. If you push one of the face buttons below, you will be
+given a choice between a number of standard faces. The name of the
+selected face is shown right after the face button, and it is
+displayed its own face so you can see how it looks. If you know of
+another standard face not listed and want to use it, you can select
+`Other' and write the name in the editing field.
+
+If none of the standard faces suits you, you can select `Customize' to
+create your own face. This will make six fields appear under the face
+button. The `Fg' and `Bg' fields are the foreground and background
+colors for the face, respectively. You should type the name of the
+color in the field. You can use any X11 color name. A list of X11
+color names may be available in the file `/usr/lib/X11/rgb.txt' on
+your system. The special color name `default' means that the face
+will not change the color of the text. The `Stipple' field is weird,
+so just ignore it. The three remaining fields are toggles, which will
+make the text `bold', `italic', or `underline' respectively. For some
+fonts `bold' or `italic' will not make any visible change."))
+ (face (type . choice)
+ (eval . custom-face-eval)
+ (import . custom-face-import)
+ (data ((tag . "None")
+ (default . nil)
+ (type . const))
+ ((tag . "Default")
+ (default . default)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Bold")
+ (default . bold)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Bold-italic")
+ (default . bold-italic)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Italic")
+ (default . italic)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Underline")
+ (default . underline)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Highlight")
+ (default . highlight)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Modeline")
+ (default . modeline)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Region")
+ (default . region)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Secondary Selection")
+ (default . secondary-selection)
+ (face . custom-const-face)
+ (type . const))
+ ((tag . "Customized")
+ (compact . t)
+ (face-tag . custom-face-hack)
+ (eval . custom-face-eval)
+ (data ((hidden . t)
+ (tag . "")
+ (doc . "\
+Select the properties you want this face to have.")
+ (default . custom-face-lookup)
+ (type . const))
+ "\n"
+ ((tag . "Fg")
+ (hidden . t)
+ (default . "default")
+ (width . 20)
+ (type . string))
+ ((tag . "Bg")
+ (default . "default")
+ (width . 20)
+ (type . string))
+ ((tag . "Stipple")
+ (default . "default")
+ (width . 20)
+ (type . string))
+ "\n"
+ ((tag . "Bold")
+ (default . nil)
+ (type . toggle))
+ " "
+ ((tag . "Italic")
+ (default . nil)
+ (type . toggle))
+ " "
+ ((tag . "Underline")
+ (hidden . t)
+ (default . nil)
+ (type . toggle)))
+ (default . (custom-face-lookup "default" "default" "default"
+ nil nil nil))
+ (type . list))
+ ((prompt . "Other")
+ (face . custom-field-value)
+ (default . __uninitialized__)
+ (type . symbol))))
+ (file (type . string)
+ ;; A string containing a file or directory name.
+ (directory . nil)
+ (default-file . nil)
+ (query . custom-file-query))
+ (sexp (type . default)
+ ;; Any lisp expression.
+ (width . 40)
+ (default . (__uninitialized__ . "Uninitialized"))
+ (read . custom-sexp-read)
+ (write . custom-sexp-write))
+ (symbol (type . sexp)
+ ;; A lisp symbol.
+ (width . 40)
+ (valid . (lambda (c d) (symbolp d))))
+ (integer (type . sexp)
+ ;; A lisp integer.
+ (width . 10)
+ (valid . (lambda (c d) (integerp d))))
+ (string (type . default)
+ ;; A lisp string.
+ (width . 40)
+ (valid . (lambda (c d) (stringp d)))
+ (read . custom-string-read)
+ (write . custom-string-write))
+ (button (type . default)
+ ;; Push me.
+ (accept . ignore)
+ (extract . nil)
+ (validate . ignore)
+ (insert . custom-button-insert))
+ (doc (type . default)
+ ;; A documentation only entry with no value.
+ (header . nil)
+ (reset . ignore)
+ (extract . nil)
+ (validate . ignore)
+ (insert . custom-documentation-insert))
+ (default (width . 20)
+ (valid . (lambda (c v) t))
+ (insert . custom-default-insert)
+ (update . custom-default-update)
+ (query . custom-default-query)
+ (tag . nil)
+ (prompt . nil)
+ (doc . nil)
+ (header . t)
+ (padding . ? )
+ (quote . custom-default-quote)
+ (eval . (lambda (c v) nil))
+ (export . custom-default-export)
+ (import . (lambda (c v) (list v)))
+ (synchronize . ignore)
+ (initialize . custom-default-initialize)
+ (extract . custom-default-extract)
+ (validate . custom-default-validate)
+ (apply . custom-default-apply)
+ (reset . custom-default-reset)
+ (factory-reset . custom-default-factory-reset)
+ (accept . custom-default-accept)
+ (match . custom-default-match)
+ (name . nil)
+ (compact . nil)
+ (hidden . nil)
+ (face . custom-default-face)
+ (data . nil)
+ (calculate . nil)
+ (default . __uninitialized__)))
+ "Alist of default properties for type symbols.
+The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.")
+
+(defconst custom-local-type-properties nil
+ "Local type properties.
+Entries in this list take precedence over `custom-type-properties'.")
+
+(make-variable-buffer-local 'custom-local-type-properties)
+
+(defconst custom-nil '__uninitialized__
+ "Special value representing an uninitialized field.")
+
+(defconst custom-invalid '__invalid__
+ "Special value representing an invalid field.")
+
+(defun custom-property (custom property)
+ "Extract from CUSTOM property PROPERTY."
+ (let ((entry (assq property custom)))
+ (while (null entry)
+ ;; Look in superclass.
+ (let ((type (custom-type custom)))
+ (setq custom (cdr (or (assq type custom-local-type-properties)
+ (assq type custom-type-properties)))
+ entry (assq property custom))
+ (custom-assert 'custom)))
+ (cdr entry)))
+
+(defun custom-super (custom property)
+ "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass."
+ (let ((entry nil))
+ (while (null entry)
+ ;; Look in superclass.
+ (let ((type (custom-type custom)))
+ (setq custom (cdr (or (assq type custom-local-type-properties)
+ (assq type custom-type-properties)))
+ entry (assq property custom))
+ (custom-assert 'custom)))
+ (cdr entry)))
+
+(defun custom-property-set (custom property value)
+ "Set CUSTOM PROPERY to VALUE by side effect.
+CUSTOM must have at least one property already."
+ (let ((entry (assq property custom)))
+ (if entry
+ (setcdr entry value)
+ (setcdr custom (cons (cons property value) (cdr custom))))))
+
+(defun custom-type (custom)
+ "Extract `type' from CUSTOM."
+ (cdr (assq 'type custom)))
+
+(defun custom-name (custom)
+ "Extract `name' from CUSTOM."
+ (custom-property custom 'name))
+
+(defun custom-tag (custom)
+ "Extract `tag' from CUSTOM."
+ (custom-property custom 'tag))
+
+(defun custom-face-tag (custom)
+ "Extract `face-tag' from CUSTOM."
+ (custom-property custom 'face-tag))
+
+(defun custom-prompt (custom)
+ "Extract `prompt' from CUSTOM.
+If none exist, default to `tag' or, failing that, `type'."
+ (or (custom-property custom 'prompt)
+ (custom-property custom 'tag)
+ (capitalize (symbol-name (custom-type custom)))))
+
+(defun custom-default (custom)
+ "Extract `default' from CUSTOM."
+ (let ((value (custom-property custom 'calculate)))
+ (if value
+ (eval value)
+ (custom-property custom 'default))))
+
+(defun custom-data (custom)
+ "Extract the `data' from CUSTOM."
+ (custom-property custom 'data))
+
+(defun custom-documentation (custom)
+ "Extract `doc' from CUSTOM."
+ (custom-property custom 'doc))
+
+(defun custom-width (custom)
+ "Extract `width' from CUSTOM."
+ (custom-property custom 'width))
+
+(defun custom-compact (custom)
+ "Extract `compact' from CUSTOM."
+ (custom-property custom 'compact))
+
+(defun custom-padding (custom)
+ "Extract `padding' from CUSTOM."
+ (custom-property custom 'padding))
+
+(defun custom-valid (custom value)
+ "Non-nil if CUSTOM may validly be set to VALUE."
+ (and (not (and (listp value) (eq custom-invalid (car value))))
+ (funcall (custom-property custom 'valid) custom value)))
+
+(defun custom-import (custom value)
+ "Import CUSTOM VALUE from external variable.
+
+This function change VALUE into a form that makes it easier to edit
+internally. What the internal form is exactly depends on CUSTOM.
+The internal form is returned."
+ (if (eq custom-nil value)
+ (list custom-nil)
+ (funcall (custom-property custom 'import) custom value)))
+
+(defun custom-eval (custom value)
+ "Return non-nil if CUSTOM's VALUE needs to be evaluated."
+ (funcall (custom-property custom 'eval) custom value))
+
+(defun custom-quote (custom value)
+ "Quote CUSTOM's VALUE if necessary."
+ (funcall (custom-property custom 'quote) custom value))
+
+(defun custom-write (custom value)
+ "Convert CUSTOM VALUE to a string."
+ (cond ((eq value custom-nil)
+ "")
+ ((and (listp value) (eq (car value) custom-invalid))
+ (cdr value))
+ (t
+ (funcall (custom-property custom 'write) custom value))))
+
+(defun custom-read (custom string)
+ "Convert CUSTOM field content STRING into lisp."
+ (condition-case nil
+ (funcall (custom-property custom 'read) custom string)
+ (error (cons custom-invalid string))))
+
+(defun custom-match (custom values)
+ "Match CUSTOM with a list of VALUES.
+
+Return a cons-cell where the car is the sublist of VALUES matching CUSTOM,
+and the cdr is the remaining VALUES.
+
+A CUSTOM is actually a regular expression over the alphabet of lisp
+types. Most CUSTOM types are just doing a literal match, e.g. the
+`symbol' type matches any lisp symbol. The exceptions are:
+
+group: which corresponds to a `(' and `)' group in a regular expression.
+choice: which corresponds to a group of `|' in a regular expression.
+repeat: which corresponds to a `*' in a regular expression.
+optional: which corresponds to a `?', and isn't implemented yet."
+ (if (memq values (list custom-nil nil))
+ ;; Nothing matches the uninitialized or empty list.
+ (cons custom-nil nil)
+ (funcall (custom-property custom 'match) custom values)))
+
+(defun custom-initialize (custom)
+ "Initialize `doc' and `default' attributes of CUSTOM."
+ (funcall (custom-property custom 'initialize) custom))
+
+(defun custom-find (custom tag)
+ "Find child in CUSTOM with `tag' TAG."
+ (funcall (custom-property custom 'find) custom tag))
+
+(defun custom-travel-path (custom path)
+ "Find decedent of CUSTOM by looking through PATH."
+ (if (null path)
+ custom
+ (custom-travel-path (custom-find custom (car path)) (cdr path))))
+
+(defun custom-field-extract (custom field)
+ "Extract CUSTOM's value in FIELD."
+ (if (stringp custom)
+ nil
+ (funcall (custom-property (custom-field-custom field) 'extract)
+ custom field)))
+
+(defun custom-field-validate (custom field)
+ "Validate CUSTOM's value in FIELD.
+Return nil if valid, otherwise return a cons-cell where the car is the
+position of the error, and the cdr is a text describing the error."
+ (if (stringp custom)
+ nil
+ (funcall (custom-property custom 'validate) custom field)))
+
+;;; Field Functions:
+;;
+;; This section defines the public functions for manipulating the
+;; FIELD datatype. The FIELD instance hold information about a
+;; specific editing field in the customization buffer.
+;;
+;; Each FIELD can be seen as an instanciation of a CUSTOM.
+
+(defvar custom-field-last nil)
+;; Last field containing point.
+(make-variable-buffer-local 'custom-field-last)
+
+(defvar custom-modified-list nil)
+;; List of modified fields.
+(make-variable-buffer-local 'custom-modified-list)
+
+(defun custom-field-create (custom value)
+ "Create a field structure of type CUSTOM containing VALUE.
+
+A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where
+CUSTOM defines the type of the field,
+VALUE is the current value of the field,
+ORIGINAL is the original value when created, and
+START and END are markers to the start and end of the field."
+ (vector custom value custom-nil nil nil))
+
+(defun custom-field-custom (field)
+ "Return the `custom' attribute of FIELD."
+ (aref field 0))
+
+(defun custom-field-value (field)
+ "Return the `value' attribute of FIELD."
+ (aref field 1))
+
+(defun custom-field-original (field)
+ "Return the `original' attribute of FIELD."
+ (aref field 2))
+
+(defun custom-field-start (field)
+ "Return the `start' attribute of FIELD."
+ (aref field 3))
+
+(defun custom-field-end (field)
+ "Return the `end' attribute of FIELD."
+ (aref field 4))
+
+(defun custom-field-value-set (field value)
+ "Set the `value' attribute of FIELD to VALUE."
+ (aset field 1 value))
+
+(defun custom-field-original-set (field original)
+ "Set the `original' attribute of FIELD to ORIGINAL."
+ (aset field 2 original))
+
+(defun custom-field-move (field start end)
+ "Set the `start'and `end' attributes of FIELD to START and END."
+ (set-marker (or (aref field 3) (aset field 3 (make-marker))) start)
+ (set-marker (or (aref field 4) (aset field 4 (make-marker))) end))
+
+(defun custom-field-query (field)
+ "Query user for content of current field."
+ (funcall (custom-property (custom-field-custom field) 'query) field))
+
+(defun custom-field-accept (field value &optional original)
+ "Store a new value into field FIELD, taking it from VALUE.
+If optional ORIGINAL is non-nil, concider VALUE for the original value."
+ (let ((inhibit-point-motion-hooks t))
+ (funcall (custom-property (custom-field-custom field) 'accept)
+ field value original)))
+
+(defun custom-field-face (field)
+ "The face used for highlighting FIELD."
+ (let ((custom (custom-field-custom field)))
+ (if (stringp custom)
+ nil
+ (let ((face (funcall (custom-property custom 'face) field)))
+ (if (custom-facep face) face nil)))))
+
+(defun custom-field-update (field)
+ "Update the screen appearance of FIELD to correspond with the field's value."
+ (let ((custom (custom-field-custom field)))
+ (if (stringp custom)
+ nil
+ (funcall (custom-property custom 'update) field))))
+
+;;; Types:
+;;
+;; The following functions defines type specific actions.
+
+(defun custom-repeat-eval (custom value)
+ "Non-nil if CUSTOM's VALUE needs to be evaluated."
+ (if (eq value custom-nil)
+ nil
+ (let ((child (custom-data custom))
+ (found nil))
+ (mapcar (lambda (v) (if (custom-eval child v) (setq found t)))
+ value))))
+
+(defun custom-repeat-quote (custom value)
+ "A list of CUSTOM's VALUEs quoted."
+ (let ((child (custom-data custom)))
+ (apply 'append (mapcar (lambda (v) (custom-quote child v))
+ value))))
+
+
+(defun custom-repeat-import (custom value)
+ "Modify CUSTOM's VALUE to match internal expectations."
+ (let ((child (custom-data custom)))
+ (apply 'append (mapcar (lambda (v) (custom-import child v))
+ value))))
+
+(defun custom-repeat-accept (field value &optional original)
+ "Store a new value into field FIELD, taking it from VALUE."
+ (let ((values (copy-sequence (custom-field-value field)))
+ (all (custom-field-value field))
+ (start (custom-field-start field))
+ current new)
+ (if original
+ (custom-field-original-set field value))
+ (while (consp value)
+ (setq new (car value)
+ value (cdr value))
+ (if values
+ ;; Change existing field.
+ (setq current (car values)
+ values (cdr values))
+ ;; Insert new field if series has grown.
+ (goto-char start)
+ (setq current (custom-repeat-insert-entry field))
+ (setq all (custom-insert-before all nil current))
+ (custom-field-value-set field all))
+ (custom-field-accept current new original))
+ (while (consp values)
+ ;; Delete old field if series has scrunk.
+ (setq current (car values)
+ values (cdr values))
+ (let ((pos (custom-field-start current))
+ data)
+ (while (not data)
+ (setq pos (previous-single-property-change pos 'custom-data))
+ (custom-assert 'pos)
+ (setq data (get-text-property pos 'custom-data))
+ (or (and (arrayp data)
+ (> (length data) 1)
+ (eq current (aref data 1)))
+ (setq data nil)))
+ (custom-repeat-delete data)))))
+
+(defun custom-repeat-insert (custom level)
+ "Insert field for CUSTOM at nesting LEVEL in customization buffer."
+ (let* ((field (custom-field-create custom nil))
+ (add-tag (custom-property custom 'add-tag))
+ (start (make-marker))
+ (data (vector field nil start nil)))
+ (custom-text-insert "\n")
+ (let ((pos (point)))
+ (custom-text-insert (custom-property custom 'prefix))
+ (custom-tag-insert add-tag 'custom-repeat-add data)
+ (set-marker start pos))
+ (custom-field-move field start (point))
+ (custom-documentation-insert custom)
+ field))
+
+(defun custom-repeat-insert-entry (repeat)
+ "Insert entry at point in the REPEAT field."
+ (let* ((inhibit-point-motion-hooks t)
+ (inhibit-read-only t)
+ (before-change-functions nil)
+ (after-change-functions nil)
+ (custom (custom-field-custom repeat))
+ (add-tag (custom-property custom 'add-tag))
+ (del-tag (custom-property custom 'del-tag))
+ (start (make-marker))
+ (end (make-marker))
+ (data (vector repeat nil start end))
+ field)
+ (insert-before-markers "\n")
+ (backward-char 1)
+ (set-marker start (point))
+ (custom-text-insert " ")
+ (aset data 1 (setq field (custom-insert (custom-data custom) nil)))
+ (custom-text-insert " ")
+ (set-marker end (point))
+ (goto-char start)
+ (custom-text-insert (custom-property custom 'prefix))
+ (custom-tag-insert add-tag 'custom-repeat-add data)
+ (custom-text-insert " ")
+ (custom-tag-insert del-tag 'custom-repeat-delete data)
+ (forward-char 1)
+ field))
+
+(defun custom-repeat-add (data)
+ "Add list entry."
+ (let ((parent (aref data 0))
+ (field (aref data 1))
+ (at (aref data 2))
+ new)
+ (goto-char at)
+ (setq new (custom-repeat-insert-entry parent))
+ (custom-field-value-set parent
+ (custom-insert-before (custom-field-value parent)
+ field new))))
+
+(defun custom-repeat-delete (data)
+ "Delete list entry."
+ (let ((inhibit-point-motion-hooks t)
+ (inhibit-read-only t)
+ (before-change-functions nil)
+ (after-change-functions nil)
+ (parent (aref data 0))
+ (field (aref data 1)))
+ (delete-region (aref data 2) (1+ (aref data 3)))
+ (custom-field-untouch (aref data 1))
+ (custom-field-value-set parent
+ (delq field (custom-field-value parent)))))
+
+(defun custom-repeat-match (custom values)
+ "Match CUSTOM with VALUES."
+ (let* ((child (custom-data custom))
+ (match (custom-match child values))
+ matches)
+ (while (not (eq (car match) custom-nil))
+ (setq matches (cons (car match) matches)
+ values (cdr match)
+ match (custom-match child values)))
+ (cons (nreverse matches) values)))
+
+(defun custom-repeat-extract (custom field)
+ "Extract list of childrens values."
+ (let ((values (custom-field-value field))
+ (data (custom-data custom))
+ result)
+ (if (eq values custom-nil)
+ ()
+ (while values
+ (setq result (append result (custom-field-extract data (car values)))
+ values (cdr values))))
+ result))
+
+(defun custom-repeat-validate (custom field)
+ "Validate children."
+ (let ((values (custom-field-value field))
+ (data (custom-data custom))
+ result)
+ (if (eq values custom-nil)
+ (setq result (cons (custom-field-start field) "Uninitialized list")))
+ (while (and values (not result))
+ (setq result (custom-field-validate data (car values))
+ values (cdr values)))
+ result))
+
+(defun custom-pair-accept (field value &optional original)
+ "Store a new value into field FIELD, taking it from VALUE."
+ (custom-group-accept field (list (car value) (cdr value)) original))
+
+(defun custom-pair-eval (custom value)
+ "Non-nil if CUSTOM's VALUE needs to be evaluated."
+ (custom-group-eval custom (list (car value) (cdr value))))
+
+(defun custom-pair-import (custom value)
+ "Modify CUSTOM's VALUE to match internal expectations."
+ (let ((result (car (custom-group-import custom
+ (list (car value) (cdr value))))))
+ (custom-assert '(eq (length result) 2))
+ (list (cons (nth 0 result) (nth 1 result)))))
+
+(defun custom-pair-quote (custom value)
+ "Quote CUSTOM's VALUE if necessary."
+ (if (custom-eval custom value)
+ (let ((v (car (custom-group-quote custom
+ (list (car value) (cdr value))))))
+ (list (list 'cons (nth 0 v) (nth 1 v))))
+ (custom-default-quote custom value)))
+
+(defun custom-pair-extract (custom field)
+ "Extract cons of childrens values."
+ (let ((values (custom-field-value field))
+ (data (custom-data custom))
+ result)
+ (custom-assert '(eq (length values) (length data)))
+ (while values
+ (setq result (append result
+ (custom-field-extract (car data) (car values)))
+ data (cdr data)
+ values (cdr values)))
+ (custom-assert '(null data))
+ (list (cons (nth 0 result) (nth 1 result)))))
+
+(defun custom-list-quote (custom value)
+ "Quote CUSTOM's VALUE if necessary."
+ (if (custom-eval custom value)
+ (let ((v (car (custom-group-quote custom value))))
+ (list (cons 'list v)))
+ (custom-default-quote custom value)))
+
+(defun custom-list-extract (custom field)
+ "Extract list of childrens values."
+ (let ((values (custom-field-value field))
+ (data (custom-data custom))
+ result)
+ (custom-assert '(eq (length values) (length data)))
+ (while values
+ (setq result (append result
+ (custom-field-extract (car data) (car values)))
+ data (cdr data)
+ values (cdr values)))
+ (custom-assert '(null data))
+ (list result)))
+
+(defun custom-group-validate (custom field)
+ "Validate children."
+ (let ((values (custom-field-value field))
+ (data (custom-data custom))
+ result)
+ (if (eq values custom-nil)
+ (setq result (cons (custom-field-start field) "Uninitialized list"))
+ (custom-assert '(eq (length values) (length data))))
+ (while (and values (not result))
+ (setq result (custom-field-validate (car data) (car values))
+ data (cdr data)
+ values (cdr values)))
+ result))
+
+(defun custom-group-eval (custom value)
+ "Non-nil if CUSTOM's VALUE needs to be evaluated."
+ (let ((found nil))
+ (mapcar (lambda (c)
+ (or (stringp c)
+ (let ((match (custom-match c value)))
+ (if (custom-eval c (car match))
+ (setq found t))
+ (setq value (cdr match)))))
+ (custom-data custom))
+ found))
+
+(defun custom-group-quote (custom value)
+ "A list of CUSTOM's VALUE members, quoted."
+ (list (apply 'append
+ (mapcar (lambda (c)
+ (if (stringp c)
+ ()
+ (let ((match (custom-match c value)))
+ (prog1 (custom-quote c (car match))
+ (setq value (cdr match))))))
+ (custom-data custom)))))
+
+(defun custom-group-import (custom value)
+ "Modify CUSTOM's VALUE to match internal expectations."
+ (list (apply 'append
+ (mapcar (lambda (c)
+ (if (stringp c)
+ ()
+ (let ((match (custom-match c value)))
+ (prog1 (custom-import c (car match))
+ (setq value (cdr match))))))
+ (custom-data custom)))))
+
+(defun custom-group-initialize (custom)
+ "Initialize `doc' and `default' entries in CUSTOM."
+ (if (custom-name custom)
+ (custom-default-initialize custom)
+ (mapcar 'custom-initialize (custom-data custom))))
+
+(defun custom-group-apply (field)
+ "Reset `value' in FIELD to `original'."
+ (let ((custom (custom-field-custom field))
+ (values (custom-field-value field)))
+ (if (custom-name custom)
+ (custom-default-apply field)
+ (mapcar 'custom-field-apply values))))
+
+(defun custom-group-reset (field)
+ "Reset `value' in FIELD to `original'."
+ (let ((custom (custom-field-custom field))
+ (values (custom-field-value field)))
+ (if (custom-name custom)
+ (custom-default-reset field)
+ (mapcar 'custom-field-reset values))))
+
+(defun custom-group-factory-reset (field)
+ "Reset `value' in FIELD to `default'."
+ (let ((custom (custom-field-custom field))
+ (values (custom-field-value field)))
+ (if (custom-name custom)
+ (custom-default-factory-reset field)
+ (mapcar 'custom-field-factory-reset values))))
+
+(defun custom-group-find (custom tag)
+ "Find child in CUSTOM with `tag' TAG."
+ (let ((data (custom-data custom))
+ (result nil))
+ (while (not result)
+ (custom-assert 'data)
+ (if (equal (custom-tag (car data)) tag)
+ (setq result (car data))
+ (setq data (cdr data))))))
+
+(defun custom-group-accept (field value &optional original)
+ "Store a new value into field FIELD, taking it from VALUE."
+ (let* ((values (custom-field-value field))
+ (custom (custom-field-custom field))
+ (from (custom-field-start field))
+ (face-tag (custom-face-tag custom))
+ current)
+ (if face-tag
+ (put-text-property from (+ from (length (custom-tag custom)))
+ 'face (funcall face-tag field value)))
+ (if original
+ (custom-field-original-set field value))
+ (while values
+ (setq current (car values)
+ values (cdr values))
+ (if current
+ (let* ((custom (custom-field-custom current))
+ (match (custom-match custom value)))
+ (setq value (cdr match))
+ (custom-field-accept current (car match) original))))))
+
+(defun custom-group-insert (custom level)
+ "Insert field for CUSTOM at nesting LEVEL in customization buffer."
+ (let* ((field (custom-field-create custom nil))
+ fields hidden
+ (from (point))
+ (compact (custom-compact custom))
+ (tag (custom-tag custom))
+ (face-tag (custom-face-tag custom)))
+ (cond (face-tag (custom-text-insert tag))
+ (tag (custom-tag-insert tag field)))
+ (or compact (custom-documentation-insert custom))
+ (or compact (custom-text-insert "\n"))
+ (let ((data (custom-data custom)))
+ (while data
+ (setq fields (cons (custom-insert (car data) (if level (1+ level)))
+ fields))
+ (setq hidden (or (stringp (car data))
+ (custom-property (car data) 'hidden)))
+ (setq data (cdr data))
+ (if data (custom-text-insert (cond (hidden "")
+ (compact " ")
+ (t "\n"))))))
+ (if compact (custom-documentation-insert custom))
+ (custom-field-value-set field (nreverse fields))
+ (custom-field-move field from (point))
+ field))
+
+(defun custom-choice-insert (custom level)
+ "Insert field for CUSTOM at nesting LEVEL in customization buffer."
+ (let* ((field (custom-field-create custom nil))
+ (from (point)))
+ (custom-text-insert "lars er en nisse")
+ (custom-field-move field from (point))
+ (custom-documentation-insert custom)
+ (custom-field-reset field)
+ field))
+
+(defun custom-choice-accept (field value &optional original)
+ "Store a new value into field FIELD, taking it from VALUE."
+ (let ((custom (custom-field-custom field))
+ (start (custom-field-start field))
+ (end (custom-field-end field))
+ (inhibit-read-only t)
+ (before-change-functions nil)
+ (after-change-functions nil)
+ from)
+ (cond (original
+ (setq custom-modified-list (delq field custom-modified-list))
+ (custom-field-original-set field value))
+ ((equal value (custom-field-original field))
+ (setq custom-modified-list (delq field custom-modified-list)))
+ (t
+ (add-to-list 'custom-modified-list field)))
+ (custom-field-untouch (custom-field-value field))
+ (delete-region start end)
+ (goto-char start)
+ (setq from (point))
+ (insert-before-markers " ")
+ (backward-char 1)
+ (custom-category-set (point) (1+ (point)) 'custom-hidden-properties)
+ (custom-tag-insert (custom-tag custom) field)
+ (custom-text-insert ": ")
+ (let ((data (custom-data custom))
+ found begin)
+ (while (and data (not found))
+ (if (not (custom-valid (car data) value))
+ (setq data (cdr data))
+ (setq found (custom-insert (car data) nil))
+ (setq data nil)))
+ (if found
+ ()
+ (setq begin (point)
+ found (custom-insert (custom-property custom 'none) nil))
+ (add-text-properties begin (point)
+ (list rear-nonsticky t
+ 'face custom-field-uninitialized-face)))
+ (or original
+ (custom-field-original-set found (custom-field-original field)))
+ (custom-field-accept found value original)
+ (custom-field-value-set field found)
+ (custom-field-move field from end))))
+
+(defun custom-choice-extract (custom field)
+ "Extract childs value."
+ (let ((value (custom-field-value field)))
+ (custom-field-extract (custom-field-custom value) value)))
+
+(defun custom-choice-validate (custom field)
+ "Validate childs value."
+ (let ((value (custom-field-value field))
+ (custom (custom-field-custom field)))
+ (if (or (eq value custom-nil)
+ (eq (custom-field-custom value) (custom-property custom 'none)))
+ (cons (custom-field-start field) "Make a choice")
+ (custom-field-validate (custom-field-custom value) value))))
+
+(defun custom-choice-query (field)
+ "Choose a child."
+ (let* ((custom (custom-field-custom field))
+ (old (custom-field-custom (custom-field-value field)))
+ (default (custom-prompt old))
+ (tag (custom-prompt custom))
+ (data (custom-data custom))
+ current alist)
+ (if (eq (length data) 2)
+ (custom-field-accept field (custom-default (if (eq (nth 0 data) old)
+ (nth 1 data)
+ (nth 0 data))))
+ (while data
+ (setq current (car data)
+ data (cdr data))
+ (setq alist (cons (cons (custom-prompt current) current) alist)))
+ (let ((answer (cond ((and (fboundp 'button-press-event-p)
+ (fboundp 'popup-menu)
+ (button-press-event-p last-input-event))
+ (cdr (assoc (car (custom-x-really-popup-menu
+ last-input-event tag
+ (reverse alist)))
+ alist)))
+ ((listp last-input-event)
+ (x-popup-menu last-input-event
+ (list tag (cons "" (reverse alist)))))
+ (t
+ (let ((choice (completing-read (concat tag
+ " (default "
+ default
+ "): ")
+ alist nil t)))
+ (if (or (null choice) (string-equal choice ""))
+ (setq choice default))
+ (cdr (assoc choice alist)))))))
+ (if answer
+ (custom-field-accept field (custom-default answer)))))))
+
+(defun custom-file-query (field)
+ "Prompt for a file name"
+ (let* ((value (custom-field-value field))
+ (custom (custom-field-custom field))
+ (valid (custom-valid custom value))
+ (directory (custom-property custom 'directory))
+ (default (and (not valid)
+ (custom-property custom 'default-file)))
+ (tag (custom-tag custom))
+ (prompt (if default
+ (concat tag " (" default "): ")
+ (concat tag ": "))))
+ (custom-field-accept field
+ (if (custom-valid custom value)
+ (read-file-name prompt
+ (if (file-name-absolute-p value)
+ ""
+ directory)
+ default nil value)
+ (read-file-name prompt directory default)))))
+
+(defun custom-face-eval (custom value)
+ "Return non-nil if CUSTOM's VALUE needs to be evaluated."
+ (not (symbolp value)))
+
+(defun custom-face-import (custom value)
+ "Modify CUSTOM's VALUE to match internal expectations."
+ (let ((name (symbol-name value)))
+ (list (if (string-match "\
+custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)"
+ name)
+ (list 'custom-face-lookup
+ (match-string 1 name)
+ (match-string 2 name)
+ (match-string 3 name)
+ (intern (match-string 4 name))
+ (intern (match-string 5 name))
+ (intern (match-string 6 name)))
+ value))))
+
+(defun custom-face-lookup (fg bg stipple bold italic underline)
+ "Lookup or create a face with specified attributes.
+FG BG STIPPLE BOLD ITALIC UNDERLINE"
+ (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S"
+ (or fg "default")
+ (or bg "default")
+ (or stipple "default")
+ bold italic underline))))
+ (if (and (custom-facep name)
+ (fboundp 'make-face))
+ ()
+ (make-face name)
+ (modify-face name
+ (if (string-equal fg "default") nil fg)
+ (if (string-equal bg "default") nil bg)
+ (if (string-equal stipple "default") nil stipple)
+ bold italic underline))
+ name))
+
+(defun custom-face-hack (field value)
+ "Face that should be used for highlighting FIELD containing VALUE."
+ (let* ((custom (custom-field-custom field))
+ (face (eval (funcall (custom-property custom 'export)
+ custom value))))
+ (if (custom-facep face) face nil)))
+
+(defun custom-const-insert (custom level)
+ "Insert field for CUSTOM at nesting LEVEL in customization buffer."
+ (let* ((field (custom-field-create custom custom-nil))
+ (face (custom-field-face field))
+ (from (point)))
+ (custom-text-insert (custom-tag custom))
+ (add-text-properties from (point)
+ (list 'face face
+ rear-nonsticky t))
+ (custom-documentation-insert custom)
+ (custom-field-move field from (point))
+ field))
+
+(defun custom-const-update (field)
+ "Update face of FIELD."
+ (let ((from (custom-field-start field))
+ (custom (custom-field-custom field)))
+ (put-text-property from (+ from (length (custom-tag custom)))
+ 'face (custom-field-face field))))
+
+(defun custom-const-valid (custom value)
+ "Non-nil if CUSTOM can validly have the value VALUE."
+ (equal (custom-default custom) value))
+
+(defun custom-const-face (field)
+ "Face used for a FIELD."
+ (custom-default (custom-field-custom field)))
+
+(defun custom-sexp-read (custom string)
+ "Read from CUSTOM an STRING."
+ (save-match-data
+ (save-excursion
+ (set-buffer (get-buffer-create " *Custom Scratch*"))
+ (erase-buffer)
+ (insert string)
+ (goto-char (point-min))
+ (prog1 (read (current-buffer))
+ (or (looking-at
+ (concat (regexp-quote (char-to-string
+ (custom-padding custom)))
+ "*\\'"))
+ (error "Junk at end of expression"))))))
+
+(autoload 'pp-to-string "pp")
+
+(defun custom-sexp-write (custom sexp)
+ "Write CUSTOM SEXP as string."
+ (let ((string (prin1-to-string sexp)))
+ (if (<= (length string) (custom-width custom))
+ string
+ (setq string (pp-to-string sexp))
+ (string-match "[ \t\n]*\\'" string)
+ (concat "\n" (substring string 0 (match-beginning 0))))))
+
+(defun custom-string-read (custom string)
+ "Read string by ignoring trailing padding characters."
+ (let ((last (length string))
+ (padding (custom-padding custom)))
+ (while (and (> last 0)
+ (eq (aref string (1- last)) padding))
+ (setq last (1- last)))
+ (substring string 0 last)))
+
+(defun custom-string-write (custom string)
+ "Write raw string."
+ string)
+
+(defun custom-button-insert (custom level)
+ "Insert field for CUSTOM at nesting LEVEL in customization buffer."
+ (custom-tag-insert (concat "[" (custom-tag custom) "]")
+ (custom-property custom 'query))
+ (custom-documentation-insert custom)
+ nil)
+
+(defun custom-default-export (custom value)
+ ;; Convert CUSTOM's VALUE to external representation.
+ ;; See `custom-import'.
+ (if (custom-eval custom value)
+ (eval (car (custom-quote custom value)))
+ value))
+
+(defun custom-default-quote (custom value)
+ "Quote CUSTOM's VALUE if necessary."
+ (list (if (and (not (custom-eval custom value))
+ (or (and (symbolp value)
+ value
+ (not (eq t value)))
+ (and (listp value)
+ value
+ (not (memq (car value) '(quote function lambda))))))
+ (list 'quote value)
+ value)))
+
+(defun custom-default-initialize (custom)
+ "Initialize `doc' and `default' entries in CUSTOM."
+ (let ((name (custom-name custom)))
+ (if (null name)
+ ()
+ (let ((default (custom-default custom))
+ (doc (custom-documentation custom))
+ (vdoc (documentation-property name 'variable-documentation t)))
+ (if doc
+ (or vdoc (put name 'variable-documentation doc))
+ (if vdoc (custom-property-set custom 'doc vdoc)))
+ (if (eq default custom-nil)
+ (if (boundp name)
+ (custom-property-set custom 'default (symbol-value name)))
+ (or (boundp name)
+ (set name default)))))))
+
+(defun custom-default-insert (custom level)
+ "Insert field for CUSTOM at nesting LEVEL in customization buffer."
+ (let ((field (custom-field-create custom custom-nil))
+ (tag (custom-tag custom)))
+ (if (null tag)
+ ()
+ (custom-tag-insert tag field)
+ (custom-text-insert ": "))
+ (custom-field-insert field)
+ (custom-documentation-insert custom)
+ field))
+
+(defun custom-default-accept (field value &optional original)
+ "Store a new value into field FIELD, taking it from VALUE."
+ (if original
+ (custom-field-original-set field value))
+ (custom-field-value-set field value)
+ (custom-field-update field))
+
+(defun custom-default-apply (field)
+ "Apply any changes in FIELD since the last apply."
+ (let* ((custom (custom-field-custom field))
+ (name (custom-name custom)))
+ (if (null name)
+ (error "This field cannot be applied alone"))
+ (custom-external-set name (custom-name-value name))
+ (custom-field-reset field)))
+
+(defun custom-default-reset (field)
+ "Reset content of editing FIELD to `original'."
+ (custom-field-accept field (custom-field-original field) t))
+
+(defun custom-default-factory-reset (field)
+ "Reset content of editing FIELD to `default'."
+ (let* ((custom (custom-field-custom field))
+ (default (car (custom-import custom (custom-default custom)))))
+ (or (eq default custom-nil)
+ (custom-field-accept field default nil))))
+
+(defun custom-default-query (field)
+ "Prompt for a FIELD"
+ (let* ((custom (custom-field-custom field))
+ (value (custom-field-value field))
+ (initial (custom-write custom value))
+ (prompt (concat (custom-prompt custom) ": ")))
+ (custom-field-accept field
+ (custom-read custom
+ (if (custom-valid custom value)
+ (read-string prompt (cons initial 1))
+ (read-string prompt))))))
+
+(defun custom-default-match (custom values)
+ "Match CUSTOM with VALUES."
+ values)
+
+(defun custom-default-extract (custom field)
+ "Extract CUSTOM's content in FIELD."
+ (list (custom-field-value field)))
+
+(defun custom-default-validate (custom field)
+ "Validate FIELD."
+ (let ((value (custom-field-value field))
+ (start (custom-field-start field)))
+ (cond ((eq value custom-nil)
+ (cons start "Uninitialized field"))
+ ((and (consp value) (eq (car value) custom-invalid))
+ (cons start "Unparseable field content"))
+ ((custom-valid custom value)
+ nil)
+ (t
+ (cons start "Wrong type of field content")))))
+
+(defun custom-default-face (field)
+ "Face used for a FIELD."
+ (let ((value (custom-field-value field)))
+ (cond ((eq value custom-nil)
+ custom-field-uninitialized-face)
+ ((not (custom-valid (custom-field-custom field) value))
+ custom-field-invalid-face)
+ ((not (equal (custom-field-original field) value))
+ custom-field-modified-face)
+ (t
+ custom-field-face))))
+
+(defun custom-default-update (field)
+ "Update the content of FIELD."
+ (let ((inhibit-point-motion-hooks t)
+ (before-change-functions nil)
+ (after-change-functions nil)
+ (start (custom-field-start field))
+ (end (custom-field-end field))
+ (pos (point)))
+ ;; Keep track of how many modified fields we have.
+ (cond ((equal (custom-field-value field) (custom-field-original field))
+ (setq custom-modified-list (delq field custom-modified-list)))
+ ((memq field custom-modified-list))
+ (t
+ (setq custom-modified-list (cons field custom-modified-list))))
+ ;; Update the field.
+ (goto-char end)
+ (insert-before-markers " ")
+ (delete-region start (1- end))
+ (goto-char start)
+ (custom-field-insert field)
+ (goto-char end)
+ (delete-char 1)
+ (goto-char pos)
+ (and (<= start pos)
+ (<= pos end)
+ (custom-field-enter field))))
+
+;;; Create Buffer:
+;;
+;; Public functions to create a customization buffer and to insert
+;; various forms of text, fields, and buttons in it.
+
+(defun customize ()
+ "Customize GNU Emacs.
+Create a *Customize* buffer with editable customization information
+about GNU Emacs."
+ (interactive)
+ (custom-buffer-create "*Customize*")
+ (custom-reset-all))
+
+(defun custom-buffer-create (name &optional custom types set get save)
+ "Create a customization buffer named NAME.
+If the optional argument CUSTOM is non-nil, use that as the custom declaration.
+If the optional argument TYPES is non-nil, use that as the local types.
+If the optional argument SET is non-nil, use that to set external data.
+If the optional argument GET is non-nil, use that to get external data.
+If the optional argument SAVE is non-nil, use that for saving changes."
+ (switch-to-buffer name)
+ (buffer-disable-undo (current-buffer))
+ (custom-mode)
+ (setq custom-local-type-properties types)
+ (if (null custom)
+ ()
+ (make-local-variable 'custom-data)
+ (setq custom-data custom))
+ (if (null set)
+ ()
+ (make-local-variable 'custom-external-set)
+ (setq custom-external-set set))
+ (if (null get)
+ ()
+ (make-local-variable 'custom-external)
+ (setq custom-external get))
+ (if (null save)
+ ()
+ (make-local-variable 'custom-save)
+ (setq custom-save save))
+ (let ((inhibit-point-motion-hooks t)
+ (before-change-functions nil)
+ (after-change-functions nil))
+ (erase-buffer)
+ (insert "\n")
+ (goto-char (point-min))
+ (custom-text-insert "This is a customization buffer.\n")
+ (custom-help-insert "\n")
+ (custom-help-button 'custom-forward-field)
+ (custom-help-button 'custom-backward-field)
+ (custom-help-button 'custom-enter-value)
+ (custom-help-button 'custom-field-factory-reset)
+ (custom-help-button 'custom-field-reset)
+ (custom-help-button 'custom-field-apply)
+ (custom-help-button 'custom-save-and-exit)
+ (custom-help-button 'custom-toggle-documentation)
+ (custom-help-insert "\nClick mouse-2 on any button to activate it.\n")
+ (custom-text-insert "\n")
+ (custom-insert custom-data 0)
+ (goto-char (point-min))))
+
+(defun custom-insert (custom level)
+ "Insert custom declaration CUSTOM in current buffer at level LEVEL."
+ (if (stringp custom)
+ (progn
+ (custom-text-insert custom)
+ nil)
+ (and level (null (custom-property custom 'header))
+ (setq level nil))
+ (and level
+ (> level 0)
+ (custom-text-insert (concat "\n" (make-string level ?*) " ")))
+ (let ((field (funcall (custom-property custom 'insert) custom level)))
+ (custom-name-enter (custom-name custom) field)
+ field)))
+
+(defun custom-text-insert (text)
+ "Insert TEXT in current buffer."
+ (insert text))
+
+(defun custom-tag-insert (tag field &optional data)
+ "Insert TAG for FIELD in current buffer."
+ (let ((from (point)))
+ (insert tag)
+ (custom-category-set from (point) 'custom-button-properties)
+ (put-text-property from (point) 'custom-tag field)
+ (if data
+ (add-text-properties from (point) (list 'custom-data data)))))
+
+(defun custom-documentation-insert (custom &rest ignore)
+ "Insert documentation from CUSTOM in current buffer."
+ (let ((doc (custom-documentation custom)))
+ (if (null doc)
+ ()
+ (custom-help-insert "\n" doc))))
+
+(defun custom-help-insert (&rest args)
+ "Insert ARGS as documentation text."
+ (let ((from (point)))
+ (apply 'insert args)
+ (custom-category-set from (point) 'custom-documentation-properties)))
+
+(defun custom-help-button (command)
+ "Describe how to execute COMMAND."
+ (let ((from (point)))
+ (insert "`" (key-description (where-is-internal command nil t)) "'")
+ (set-text-properties from (point)
+ (list 'face custom-button-face
+ mouse-face custom-mouse-face
+ 'custom-jump t ;Make TAB jump over it.
+ 'custom-tag command))
+ (custom-category-set from (point) 'custom-documentation-properties))
+ (custom-help-insert ": " (custom-first-line (documentation command)) "\n"))
+
+;;; Mode:
+;;
+;; The Customization major mode and interactive commands.
+
+(defvar custom-mode-map nil
+ "Keymap for Custum Mode.")
+(if custom-mode-map
+ nil
+ (setq custom-mode-map (make-sparse-keymap))
+ (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button)
+ (define-key custom-mode-map "\t" 'custom-forward-field)
+ (define-key custom-mode-map "\M-\t" 'custom-backward-field)
+ (define-key custom-mode-map "\r" 'custom-enter-value)
+ (define-key custom-mode-map "\C-k" 'custom-kill-line)
+ (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset)
+ (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all)
+ (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset)
+ (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all)
+ (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply)
+ (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all)
+ (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit)
+ (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation))
+
+;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f
+;; forward-field, C-b backward-field, C-n next-field, C-p
+;; previous-field, ? describe-field.
+
+(defun custom-mode ()
+ "Major mode for doing customizations.
+
+\\{custom-mode-map}"
+ (kill-all-local-variables)
+ (setq major-mode 'custom-mode
+ mode-name "Custom")
+ (use-local-map custom-mode-map)
+ (make-local-variable 'before-change-functions)
+ (setq before-change-functions '(custom-before-change))
+ (make-local-variable 'after-change-functions)
+ (setq after-change-functions '(custom-after-change))
+ (if (not (fboundp 'make-local-hook))
+ ;; Emacs 19.28 and earlier.
+ (add-hook 'post-command-hook
+ (lambda ()
+ (if (eq major-mode 'custom-mode)
+ (custom-post-command))))
+ ;; Emacs 19.29.
+ (make-local-hook 'post-command-hook)
+ (add-hook 'post-command-hook 'custom-post-command nil t)))
+
+(defun custom-forward-field (arg)
+ "Move point to the next field or button.
+With optional ARG, move across that many fields."
+ (interactive "p")
+ (while (> arg 0)
+ (let ((next (if (get-text-property (point) 'custom-tag)
+ (next-single-property-change (point) 'custom-tag)
+ (point))))
+ (setq next (or (next-single-property-change next 'custom-tag)
+ (next-single-property-change (point-min) 'custom-tag)))
+ (if next
+ (goto-char next)
+ (error "No customization fields in this buffer.")))
+ (or (get-text-property (point) 'custom-jump)
+ (setq arg (1- arg))))
+ (while (< arg 0)
+ (let ((previous (if (get-text-property (1- (point)) 'custom-tag)
+ (previous-single-property-change (point) 'custom-tag)
+ (point))))
+ (setq previous
+ (or (previous-single-property-change previous 'custom-tag)
+ (previous-single-property-change (point-max) 'custom-tag)))
+ (if previous
+ (goto-char previous)
+ (error "No customization fields in this buffer.")))
+ (or (get-text-property (1- (point)) 'custom-jump)
+ (setq arg (1+ arg)))))
+
+(defun custom-backward-field (arg)
+ "Move point to the previous field or button.
+With optional ARG, move across that many fields."
+ (interactive "p")
+ (custom-forward-field (- arg)))
+
+(defun custom-toggle-documentation (&optional arg)
+ "Toggle display of documentation text.
+If the optional argument is non-nil, show text iff the argument is positive."
+ (interactive "P")
+ (let ((hide (or (and (null arg)
+ (null (custom-category-get
+ 'custom-documentation-properties 'invisible)))
+ (<= (prefix-numeric-value arg) 0))))
+ (custom-category-put 'custom-documentation-properties 'invisible hide)
+ (custom-category-put 'custom-documentation-properties intangible hide))
+ (redraw-display))
+
+(defun custom-enter-value (field data)
+ "Enter value for current customization field or push button."
+ (interactive (list (get-text-property (point) 'custom-tag)
+ (get-text-property (point) 'custom-data)))
+ (cond (data
+ (funcall field data))
+ ((eq field 'custom-enter-value)
+ (error "Don't be silly"))
+ ((and (symbolp field) (fboundp field))
+ (call-interactively field))
+ (field
+ (custom-field-query field))
+ (t
+ (message "Nothing to enter here"))))
+
+(defun custom-kill-line ()
+ "Kill to end of field or end of line, whichever is first."
+ (interactive)
+ (let ((field (get-text-property (point) 'custom-field))
+ (newline (save-excursion (search-forward "\n")))
+ (next (next-single-property-change (point) 'custom-field)))
+ (if (and field (> newline next))
+ (kill-region (point) next)
+ (call-interactively 'kill-line))))
+
+(defun custom-push-button (event)
+ "Activate button below mouse pointer."
+ (interactive "@e")
+ (let* ((pos (event-point event))
+ (field (get-text-property pos 'custom-field))
+ (tag (get-text-property pos 'custom-tag))
+ (data (get-text-property pos 'custom-data)))
+ (cond (data
+ (funcall tag data))
+ ((and (symbolp tag) (fboundp tag))
+ (call-interactively tag))
+ (field
+ (call-interactively (lookup-key global-map (this-command-keys))))
+ (tag
+ (custom-enter-value tag data))
+ (t
+ (error "Nothing to click on here.")))))
+
+(defun custom-reset-all ()
+ "Undo any changes since the last apply in all fields."
+ (interactive (and custom-modified-list
+ (not (y-or-n-p "Discard all changes? "))
+ (error "Reset aborted")))
+ (let ((all custom-name-fields)
+ current field)
+ (while all
+ (setq current (car all)
+ field (cdr current)
+ all (cdr all))
+ (custom-field-reset field))))
+
+(defun custom-field-reset (field)
+ "Undo any changes in FIELD since the last apply."
+ (interactive (list (or (get-text-property (point) 'custom-field)
+ (get-text-property (point) 'custom-tag))))
+ (if (arrayp field)
+ (let* ((custom (custom-field-custom field))
+ (name (custom-name custom)))
+ (save-excursion
+ (if name
+ (custom-field-original-set
+ field (car (custom-import custom (custom-external name)))))
+ (if (not (custom-valid custom (custom-field-original field)))
+ (error "This field cannot be reset alone")
+ (funcall (custom-property custom 'reset) field)
+ (funcall (custom-property custom 'synchronize) field))))))
+
+(defun custom-factory-reset-all ()
+ "Reset all field to their default values."
+ (interactive (and custom-modified-list
+ (not (y-or-n-p "Discard all changes? "))
+ (error "Reset aborted")))
+ (let ((all custom-name-fields)
+ field)
+ (while all
+ (setq field (cdr (car all))
+ all (cdr all))
+ (custom-field-factory-reset field))))
+
+(defun custom-field-factory-reset (field)
+ "Reset FIELD to its default value."
+ (interactive (list (or (get-text-property (point) 'custom-field)
+ (get-text-property (point) 'custom-tag))))
+ (if (arrayp field)
+ (save-excursion
+ (funcall (custom-property (custom-field-custom field) 'factory-reset)
+ field))))
+
+(defun custom-apply-all ()
+ "Apply any changes since the last reset in all fields."
+ (interactive (if custom-modified-list
+ nil
+ (error "No changes to apply.")))
+ (custom-field-parse custom-field-last)
+ (let ((all custom-name-fields)
+ field)
+ (while all
+ (setq field (cdr (car all))
+ all (cdr all))
+ (let ((error (custom-field-validate (custom-field-custom field) field)))
+ (if (null error)
+ ()
+ (goto-char (car error))
+ (error (cdr error))))))
+ (let ((all custom-name-fields)
+ field)
+ (while all
+ (setq field (cdr (car all))
+ all (cdr all))
+ (custom-field-apply field))))
+
+(defun custom-field-apply (field)
+ "Apply any changes in FIELD since the last apply."
+ (interactive (list (or (get-text-property (point) 'custom-field)
+ (get-text-property (point) 'custom-tag))))
+ (custom-field-parse custom-field-last)
+ (if (arrayp field)
+ (let* ((custom (custom-field-custom field))
+ (error (custom-field-validate custom field)))
+ (if error
+ (error (cdr error)))
+ (funcall (custom-property custom 'apply) field))))
+
+(defun custom-toggle-hide (&rest ignore)
+ "Hide or show entry."
+ (interactive)
+ (error "This button is not yet implemented"))
+
+(defun custom-save-and-exit ()
+ "Save and exit customization buffer."
+ (interactive "@")
+ (save-excursion
+ (funcall custom-save))
+ (kill-buffer (current-buffer)))
+
+(defun custom-save ()
+ "Save customization information."
+ (interactive)
+ (custom-apply-all)
+ (let ((new custom-name-fields))
+ (set-buffer (find-file-noselect custom-file))
+ (goto-char (point-min))
+ (save-excursion
+ (let ((old (condition-case nil
+ (read (current-buffer))
+ (end-of-file (append '(setq custom-dummy
+ 'custom-dummy) ())))))
+ (or (eq (car old) 'setq)
+ (error "Invalid customization file: %s" custom-file))
+ (while new
+ (let* ((field (cdr (car new)))
+ (custom (custom-field-custom field))
+ (value (custom-field-original field))
+ (default (car (custom-import custom (custom-default custom))))
+ (name (car (car new))))
+ (setq new (cdr new))
+ (custom-assert '(eq name (custom-name custom)))
+ (if (equal default value)
+ (setcdr old (custom-plist-delq name (cdr old)))
+ (setcdr old (plist-put (cdr old) name
+ (car (custom-quote custom value)))))))
+ (erase-buffer)
+ (insert ";; " custom-file "\
+ --- Automatically generated customization information.
+;;
+;; Feel free to edit by hand, but the entire content should consist of
+;; a single setq. Any other lisp expressions will confuse the
+;; automatic configuration engine.
+
+\(setq ")
+ (setq old (cdr old))
+ (while old
+ (prin1 (car old) (current-buffer))
+ (setq old (cdr old))
+ (insert " ")
+ (pp (car old) (current-buffer))
+ (setq old (cdr old))
+ (if old (insert "\n ")))
+ (insert ")\n")
+ (save-buffer)
+ (kill-buffer (current-buffer))))))
+
+(defun custom-load ()
+ "Save customization information."
+ (interactive (and custom-modified-list
+ (not (equal (list (custom-name-field 'custom-file))
+ custom-modified-list))
+ (not (y-or-n-p "Discard all changes? "))
+ (error "Load aborted")))
+ (load-file (custom-name-value 'custom-file))
+ (custom-reset-all))
+
+;;; Field Editing:
+;;
+;; Various internal functions for implementing the direct editing of
+;; fields in the customization buffer.
+
+(defun custom-field-untouch (field)
+ ;; Remove FIELD and its children from `custom-modified-list'.
+ (setq custom-modified-list (delq field custom-modified-list))
+ (if (arrayp field)
+ (let ((value (custom-field-value field)))
+ (cond ((null (custom-data (custom-field-custom field))))
+ ((arrayp value)
+ (custom-field-untouch value))
+ ((listp value)
+ (mapcar 'custom-field-untouch value))))))
+
+
+(defun custom-field-insert (field)
+ ;; Insert editing FIELD in current buffer.
+ (let ((from (point))
+ (custom (custom-field-custom field))
+ (value (custom-field-value field)))
+ (insert (custom-write custom value))
+ (insert-char (custom-padding custom)
+ (- (custom-width custom) (- (point) from)))
+ (custom-field-move field from (point))
+ (set-text-properties
+ from (point)
+ (list 'custom-field field
+ 'custom-tag field
+ 'face (custom-field-face field)
+ front-sticky t))))
+
+(defun custom-field-read (field)
+ ;; Read the screen content of FIELD.
+ (custom-read (custom-field-custom field)
+ (buffer-substring-no-properties (custom-field-start field)
+ (custom-field-end field))))
+
+;; Fields are shown in a special `active' face when point is inside
+;; it. You activate the field by moving point inside (entering) it
+;; and deactivate the field by moving point outside (leaving) it.
+
+(defun custom-field-leave (field)
+ ;; Deactivate FIELD.
+ (let ((before-change-functions nil)
+ (after-change-functions nil))
+ (put-text-property (custom-field-start field) (custom-field-end field)
+ 'face (custom-field-face field))))
+
+(defun custom-field-enter (field)
+ ;; Activate FIELD.
+ (let* ((start (custom-field-start field))
+ (end (custom-field-end field))
+ (custom (custom-field-custom field))
+ (padding (custom-padding custom))
+ (before-change-functions nil)
+ (after-change-functions nil))
+ (or (eq this-command 'self-insert-command)
+ (let ((pos end))
+ (while (and (< start pos)
+ (eq (char-after (1- pos)) padding))
+ (setq pos (1- pos)))
+ (if (< pos (point))
+ (goto-char pos))))
+ (put-text-property start end 'face custom-field-active-face)))
+
+(defun custom-field-resize (field)
+ ;; Resize FIELD after change.
+ (let* ((custom (custom-field-custom field))
+ (begin (custom-field-start field))
+ (end (custom-field-end field))
+ (pos (point))
+ (padding (custom-padding custom))
+ (width (custom-width custom))
+ (size (- end begin)))
+ (cond ((< size width)
+ (goto-char end)
+ (if (fboundp 'insert-before-markers-and-inherit)
+ ;; Emacs 19.
+ (insert-before-markers-and-inherit
+ (make-string (- width size) padding))
+ ;; XEmacs: BUG: Doesn't work!
+ (insert-before-markers (make-string (- width size) padding)))
+ (goto-char pos))
+ ((> size width)
+ (let ((start (if (and (< (+ begin width) pos) (<= pos end))
+ pos
+ (+ begin width))))
+ (goto-char end)
+ (while (and (< start (point)) (= (preceding-char) padding))
+ (backward-delete-char 1))
+ (goto-char pos))))))
+
+(defvar custom-field-changed nil)
+;; List of fields changed on the screen but whose VALUE attribute has
+;; not yet been updated to reflect the new screen content.
+(make-variable-buffer-local 'custom-field-changed)
+
+(defun custom-field-parse (field)
+ ;; Parse FIELD content iff changed.
+ (if (memq field custom-field-changed)
+ (progn
+ (setq custom-field-changed (delq field custom-field-changed))
+ (custom-field-value-set field (custom-field-read field))
+ (custom-field-update field))))
+
+(defun custom-post-command ()
+ ;; Keep track of their active field.
+ (custom-assert '(eq major-mode 'custom-mode))
+ (let ((field (custom-field-property (point))))
+ (if (eq field custom-field-last)
+ (if (memq field custom-field-changed)
+ (custom-field-resize field))
+ (custom-field-parse custom-field-last)
+ (if custom-field-last
+ (custom-field-leave custom-field-last))
+ (if field
+ (custom-field-enter field))
+ (setq custom-field-last field))
+ (set-buffer-modified-p (or custom-modified-list
+ custom-field-changed))))
+
+(defvar custom-field-was nil)
+;; The custom data before the change.
+(make-variable-buffer-local 'custom-field-was)
+
+(defun custom-before-change (begin end)
+ ;; Check that we the modification is allowed.
+ (if (not (eq major-mode 'custom-mode))
+ (message "Aargh! Why is custom-before-change called here?")
+ (let ((from (custom-field-property begin))
+ (to (custom-field-property end)))
+ (cond ((or (null from) (null to))
+ (error "You can only modify the fields"))
+ ((not (eq from to))
+ (error "Changes must be limited to a single field."))
+ (t
+ (setq custom-field-was from))))))
+
+(defun custom-after-change (begin end length)
+ ;; Keep track of field content.
+ (if (not (eq major-mode 'custom-mode))
+ (message "Aargh! Why is custom-after-change called here?")
+ (let ((field custom-field-was))
+ (custom-assert '(prog1 field (setq custom-field-was nil)))
+ ;; Prevent mixing fields properties.
+ (put-text-property begin end 'custom-field field)
+ ;; Update the field after modification.
+ (if (eq (custom-field-property begin) field)
+ (let ((field-end (custom-field-end field)))
+ (if (> end field-end)
+ (set-marker field-end end))
+ (add-to-list 'custom-field-changed field))
+ ;; We deleted the entire field, reinsert it.
+ (custom-assert '(eq begin end))
+ (save-excursion
+ (goto-char begin)
+ (custom-field-value-set field
+ (custom-read (custom-field-custom field) ""))
+ (custom-field-insert field))))))
+
+(defun custom-field-property (pos)
+ ;; The `custom-field' text property valid for POS.
+ (or (get-text-property pos 'custom-field)
+ (and (not (eq pos (point-min)))
+ (get-text-property (1- pos) 'custom-field))))
+
+;;; Generic Utilities:
+;;
+;; Some utility functions that are not really specific to custom.
+
+(defun custom-assert (expr)
+ "Assert that EXPR evaluates to non-nil at this point"
+ (or (eval expr)
+ (error "Assertion failed: %S" expr)))
+
+(defun custom-first-line (string)
+ "Return the part of STRING before the first newline."
+ (let ((pos 0)
+ (len (length string)))
+ (while (and (< pos len) (not (eq (aref string pos) ?\n)))
+ (setq pos (1+ pos)))
+ (if (eq pos len)
+ string
+ (substring string 0 pos))))
+
+(defun custom-insert-before (list old new)
+ "In LIST insert before OLD a NEW element."
+ (cond ((null list)
+ (list new))
+ ((null old)
+ (nconc list (list new)))
+ ((eq old (car list))
+ (cons new list))
+ (t
+ (let ((list list))
+ (while (not (eq old (car (cdr list))))
+ (setq list (cdr list))
+ (custom-assert '(cdr list)))
+ (setcdr list (cons new (cdr list))))
+ list)))
+
+(defun custom-strip-padding (string padding)
+ "Remove padding from STRING."
+ (let ((regexp (concat (regexp-quote (char-to-string padding)) "+")))
+ (while (string-match regexp string)
+ (setq string (concat (substring string 0 (match-beginning 0))
+ (substring string (match-end 0))))))
+ string)
+
+(defun custom-plist-memq (prop plist)
+ "Return non-nil if PROP is a property of PLIST. Comparison done with EQ."
+ (let (result)
+ (while plist
+ (if (eq (car plist) prop)
+ (setq result plist
+ plist nil)
+ (setq plist (cdr (cdr plist)))))
+ result))
+
+(defun custom-plist-delq (prop plist)
+ "Delete property PROP from property list PLIST."
+ (while (eq (car plist) prop)
+ (setq plist (cdr (cdr plist))))
+ (let ((list plist)
+ (next (cdr (cdr plist))))
+ (while next
+ (if (eq (car next) prop)
+ (progn
+ (setq next (cdr (cdr next)))
+ (setcdr (cdr list) next))
+ (setq list next
+ next (cdr (cdr next))))))
+ plist)
+
+;;; Meta Customization:
+
+(custom-declare '()
+ '((tag . "Meta Customization")
+ (doc . "Customization of the customization support.")
+ (type . group)
+ (data ((type . face-doc))
+ ((tag . "Button Face")
+ (default . bold)
+ (doc . "Face used for tags in customization buffers.")
+ (name . custom-button-face)
+ (synchronize . (lambda (f)
+ (custom-category-put 'custom-button-properties
+ 'face custom-button-face)))
+ (type . face))
+ ((tag . "Mouse Face")
+ (default . highlight)
+ (doc . "\
+Face used when mouse is above a button in customization buffers.")
+ (name . custom-mouse-face)
+ (synchronize . (lambda (f)
+ (custom-category-put 'custom-button-properties
+ mouse-face
+ custom-mouse-face)))
+ (type . face))
+ ((tag . "Field Face")
+ (default . italic)
+ (doc . "Face used for customization fields.")
+ (name . custom-field-face)
+ (type . face))
+ ((tag . "Uninitialized Face")
+ (default . modeline)
+ (doc . "Face used for uninitialized customization fields.")
+ (name . custom-field-uninitialized-face)
+ (type . face))
+ ((tag . "Invalid Face")
+ (default . highlight)
+ (doc . "\
+Face used for customization fields containing invalid data.")
+ (name . custom-field-invalid-face)
+ (type . face))
+ ((tag . "Modified Face")
+ (default . bold-italic)
+ (doc . "Face used for modified customization fields.")
+ (name . custom-field-modified-face)
+ (type . face))
+ ((tag . "Active Face")
+ (default . underline)
+ (doc . "\
+Face used for customization fields while they are being edited.")
+ (name . custom-field-active-face)
+ (type . face)))))
+
+;; custom.el uses two categories.
+
+(custom-category-create 'custom-documentation-properties)
+(custom-category-put 'custom-documentation-properties rear-nonsticky t)
+
+(custom-category-create 'custom-button-properties)
+(custom-category-put 'custom-button-properties 'face custom-button-face)
+(custom-category-put 'custom-button-properties mouse-face custom-mouse-face)
+(custom-category-put 'custom-button-properties rear-nonsticky t)
+
+(custom-category-create 'custom-hidden-properties)
+(custom-category-put 'custom-hidden-properties 'invisible
+ (not (string-match "XEmacs" emacs-version)))
+(custom-category-put 'custom-hidden-properties intangible t)
+
+(if (file-readable-p custom-file)
+ (load-file custom-file))
+
+(provide 'custom)
+
+;;; custom.el ends here
diff --git a/lisp/gnus-cache.el b/lisp/gnus-cache.el
new file mode 100644
index 00000000000..833659862a9
--- /dev/null
+++ b/lisp/gnus-cache.el
@@ -0,0 +1,361 @@
+;;; gnus-cache.el --- cache interface for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+
+(defvar gnus-cache-directory (concat gnus-article-save-directory "cache/")
+ "*The directory where cached articles will be stored.")
+
+(defvar gnus-cache-enter-articles '(ticked dormant)
+ "*Classes of articles to enter into the cache.")
+
+(defvar gnus-cache-remove-articles '(read)
+ "*Classes of articles to remove from the cache.")
+
+
+
+(defvar gnus-cache-buffer nil)
+
+
+
+(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
+ (or 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 groups cache overview
+ (erase-buffer)
+ (let ((file (gnus-cache-file-name group ".overview")))
+ (and (file-exists-p file)
+ (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))))
+
+
+(defun gnus-cache-save-buffers ()
+ ;; save the overview buffer if it exists and has been modified
+ ;; delete empty cache subdirectories
+ (if (null 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
+ (if (buffer-modified-p buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (if (> (buffer-size) 0)
+ ;; non-empty overview, write it out
+ (progn
+ (gnus-make-directory (file-name-directory overview-file))
+ (write-region (point-min) (point-max)
+ overview-file nil 'quietly))
+ ;; empty overview file, remove it
+ (and (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))))
+
+
+;; 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) (memq 'read class))))
+
+(defun gnus-cache-file-name (group article)
+ (concat (file-name-as-directory gnus-cache-directory)
+ (if (gnus-use-long-file-name 'not-cache)
+ group
+ (let ((group (concat group "")))
+ (if (string-match ":" group)
+ (aset group (match-beginning 0) ?/))
+ (gnus-replace-chars-in-string group ?. ?/)))
+ "/" (if (stringp article) article (int-to-string article))))
+
+(defun gnus-cache-possibly-enter-article
+ (group article headers ticked dormant unread)
+ (let ((number (mail-header-number headers))
+ file dir)
+ (if (or (not (vectorp headers)) ; This might be a dummy article.
+ (< number 0) ; Reffed article from other group.
+ (not (gnus-cache-member-of-class
+ gnus-cache-enter-articles ticked dormant unread))
+ (file-exists-p (setq file (gnus-cache-file-name group article))))
+ () ; Do nothing.
+ ;; Possibly create the cache directory.
+ (or (file-exists-p (setq dir (file-name-directory file)))
+ (gnus-make-directory dir))
+ ;; Save the article in the cache.
+ (if (file-exists-p file)
+ t ; The article already is saved, so we end here.
+ (let ((gnus-use-cache nil))
+ (gnus-summary-select-article))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (widen)
+ (write-region (point-min) (point-max) file nil 'quiet))
+ (gnus-cache-change-buffer group)
+ (set-buffer (cdr gnus-cache-buffer))
+ (goto-char (point-max))
+ (forward-line -1)
+ (while (condition-case ()
+ (and (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)
+ (if (< (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) ""))))
+ t))))
+
+(defun gnus-cache-enter-remove-article (article)
+ (setq gnus-cache-removeable-articles
+ (cons article gnus-cache-removeable-articles)))
+
+(defsubst gnus-cache-possibly-remove-article
+ (article ticked dormant unread)
+ (let ((file (gnus-cache-file-name gnus-newsgroup-name article)))
+ (if (or (not (file-exists-p file))
+ (not (gnus-cache-member-of-class
+ gnus-cache-remove-articles ticked dormant unread)))
+ nil
+ (save-excursion
+ (delete-file file)
+ (set-buffer (cdr gnus-cache-buffer))
+ (goto-char (point-min))
+ (if (or (looking-at (concat (int-to-string article) "\t"))
+ (search-forward (concat "\n" (int-to-string article) "\t")
+ (point-max) t))
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))))))
+
+(defun gnus-cache-possibly-remove-articles ()
+ (let ((articles gnus-cache-removeable-articles)
+ (cache-articles (gnus-cache-articles-in-group gnus-newsgroup-name))
+ article)
+ (gnus-cache-change-buffer gnus-newsgroup-name)
+ (while articles
+ (setq article (car articles)
+ articles (cdr articles))
+ (if (memq article 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)
+ (let ((file (gnus-cache-file-name group article)))
+ (if (not (file-exists-p file))
+ ()
+ (erase-buffer)
+ ;; There may be some overlays that we have to kill...
+ (insert "i")
+ (let ((overlays (overlays-at (point-min))))
+ (while overlays
+ (delete-overlay (car overlays))
+ (setq overlays (cdr overlays))))
+ (erase-buffer)
+ (insert-file-contents file)
+ t)))
+
+(defun gnus-cache-articles-in-group (group)
+ (let ((dir (file-name-directory (gnus-cache-file-name group 1)))
+ articles)
+ (if (not (file-exists-p dir))
+ nil
+ (setq articles (directory-files dir nil "^[0-9]+$" t))
+ (if (not articles)
+ nil
+ (sort (mapcar (function (lambda (name)
+ (string-to-int name)))
+ articles)
+ '<)))))
+
+(defun gnus-cache-active-articles (group)
+ (let ((articles (gnus-cache-articles-in-group group)))
+ (and articles
+ (cons (car articles) (gnus-last-element articles)))))
+
+(defun gnus-cache-possibly-alter-active (group active)
+ (let ((cache-active (gnus-cache-active-articles group)))
+ (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)
+ (let* ((cached (gnus-cache-articles-in-group group))
+ (articles (gnus-sorted-complement articles cached))
+ (cache-file (gnus-cache-file-name group ".overview"))
+ type)
+ (let ((gnus-use-cache nil))
+ (setq type (and articles (gnus-retrieve-headers articles group))))
+ (gnus-cache-save-buffers)
+ (save-excursion
+ (cond ((not (file-exists-p cache-file))
+ type)
+ ((null type)
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (insert-file-contents cache-file)
+ 'nov)
+ ((eq type 'nov)
+ (gnus-cache-braid-nov group cached)
+ type)
+ (t
+ (gnus-cache-braid-heads group cached)
+ type)))))
+
+(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)))
+ (if beg (progn (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 " (int-to-string (car cached)) " 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)))
+
+(defun gnus-jog-cache ()
+ "Go through all groups and put the articles into the cache."
+ (interactive)
+ (let ((newsrc (cdr gnus-newsrc-alist))
+ (gnus-cache-enter-articles '(unread))
+ (gnus-mark-article-hook nil)
+ (gnus-expert-user t)
+ (gnus-large-newsgroup nil))
+ (while newsrc
+ (gnus-summary-read-group (car (car newsrc)))
+ (if (not (eq major-mode 'gnus-summary-mode))
+ ()
+ (while gnus-newsgroup-unreads
+ (gnus-summary-select-article t t nil (car gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-unreads (cdr gnus-newsgroup-unreads)))
+ (kill-buffer (current-buffer)))
+ (setq newsrc (cdr newsrc)))))
+
+(provide 'gnus-cache)
+
+;;; gnus-cache.el ends here
diff --git a/lisp/gnus-cite.el b/lisp/gnus-cite.el
new file mode 100644
index 00000000000..a83ea80114b
--- /dev/null
+++ b/lisp/gnus-cite.el
@@ -0,0 +1,585 @@
+;;; gnus-cite.el --- parse citations in articles for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-msg)
+(require 'gnus-ems)
+
+(eval-and-compile
+ (autoload 'gnus-article-add-button "gnus-vis")
+ )
+
+;;; Customization:
+
+(defvar gnus-cite-parse-max-size 25000
+ "Maximum article size (in bytes) where parsing citations is allowed.
+Set it to nil to parse all articles.")
+
+(defvar gnus-cite-prefix-regexp
+ "^[]>|:}+ ]*[]>|:}+]\\(.*>\\)?\\|^.*>"
+ "Regexp matching the longest possible citation prefix on a line.")
+
+(defvar gnus-cite-max-prefix 20
+ "Maximal possible length for a citation prefix.")
+
+(defvar gnus-supercite-regexp
+ (concat "^\\(" gnus-cite-prefix-regexp "\\)? *"
+ ">>>>> +\"\\([^\"\n]+\\)\" +==")
+ "Regexp matching normal SuperCite attribution lines.
+The first regexp group should match a prefix added by another package.")
+
+(defvar gnus-supercite-secondary-regexp "^.*\"\\([^\"\n]+\\)\" +=="
+ "Regexp matching mangled SuperCite attribution lines.
+The first regexp group should match the SuperCite attribution.")
+
+(defvar gnus-cite-minimum-match-count 2
+ "Minimal number of identical prefix'es before we believe it is a citation.")
+
+;see gnus-cus.el
+;(defvar gnus-cite-face-list
+; (if (eq gnus-display-type 'color)
+; (if (eq gnus-background-mode 'dark) 'light 'dark)
+; '(italic))
+; "Faces used for displaying different citations.
+;It is either a list of face names, or one of the following special
+;values:
+
+;dark: Create faces from `gnus-face-dark-name-list'.
+;light: Create faces from `gnus-face-light-name-list'.
+
+;The variable `gnus-make-foreground' determines whether the created
+;faces change the foreground or the background colors.")
+
+(defvar gnus-cite-attribution-prefix "in article\\|in <"
+ "Regexp matching the beginning of an attribution line.")
+
+(defvar gnus-cite-attribution-postfix
+ "\\(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.")
+
+;see gnus-cus.el
+;(defvar gnus-cite-attribution-face 'underline
+; "Face used for attribution lines.
+;It is merged with the face for the cited text belonging to the attribution.")
+
+;see gnus-cus.el
+;(defvar gnus-cite-hide-percentage 50
+; "Only hide cited text if it is larger than this percent of the body.")
+
+;see gnus-cus.el
+;(defvar gnus-cite-hide-absolute 10
+; "Only hide cited text if there is at least this number of cited lines.")
+
+;see gnus-cus.el
+;(defvar gnus-face-light-name-list
+; '("light blue" "light cyan" "light yellow" "light pink"
+; "pale green" "beige" "orange" "magenta" "violet" "medium purple"
+; "turquoise")
+; "Names of light colors.")
+
+;see gnus-cus.el
+;(defvar gnus-face-dark-name-list
+; '("dark salmon" "firebrick"
+; "dark green" "dark orange" "dark khaki" "dark violet"
+; "dark turquoise")
+; "Names of dark colors.")
+
+;;; Internal Variables:
+
+(defvar gnus-article-length nil)
+;; Length of article last time we parsed it.
+;; BUG! KLUDGE! UGLY! FIX ME!
+
+(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.
+
+;;; 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-postfix' and perhaps
+`gnus-cite-attribution-prefix' are considered attribution lines."
+ (interactive (list 'force))
+ ;; Create dark or light faces if necessary.
+ (cond ((eq gnus-cite-face-list 'light)
+ (setq gnus-cite-face-list
+ (mapcar 'gnus-make-face gnus-face-light-name-list)))
+ ((eq gnus-cite-face-list 'dark)
+ (setq gnus-cite-face-list
+ (mapcar 'gnus-make-face gnus-face-dark-name-list))))
+ (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)
+ (if (re-search-forward gnus-cite-attribution-postfix
+ (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-article-hide-citation (&optional force)
+ "Hide all cited text except attribution lines.
+See the documentation for `gnus-article-highlight-citation'."
+ (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)
+ (inhibit-point-motion-hooks t)
+ numbers number)
+ (while alist
+ (setq numbers (cdr (car alist))
+ alist (cdr alist))
+ (while numbers
+ (setq number (car numbers)
+ numbers (cdr numbers))
+ (goto-line number)
+ (or (assq number gnus-cite-attribution-alist)
+ (add-text-properties (point) (progn (forward-line 1) (point))
+ gnus-hidden-properties)))))))
+
+(defun gnus-article-hide-citation-maybe (&optional force)
+ "Hide cited text that has an attribution line.
+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 (list 'force))
+ (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))
+ (re-search-backward gnus-signature-separator nil t)
+ (setq total (count-lines start (point)))
+ (while atts
+ (setq hiden (+ hiden (length (cdr (assoc (cdr (car atts))
+ gnus-cite-prefix-alist))))
+ atts (cdr atts)))
+ (if (or force
+ (and (> (* 100 hiden) (* gnus-cite-hide-percentage total))
+ (> hiden gnus-cite-hide-absolute)))
+ (progn
+ (setq atts gnus-cite-attribution-alist)
+ (while atts
+ (setq total (cdr (assoc (cdr (car atts)) gnus-cite-prefix-alist))
+ atts (cdr atts))
+ (while total
+ (setq hiden (car total)
+ total (cdr total))
+ (goto-line hiden)
+ (or (assq hiden gnus-cite-attribution-alist)
+ (add-text-properties (point)
+ (progn (forward-line 1) (point))
+ gnus-hidden-properties)))))))))
+
+;;; Internal functions:
+
+(defun gnus-cite-parse-maybe (&optional force)
+ ;; Parse if the buffer has changes since last time.
+ (if (eq gnus-article-length (- (point-max) (point-min)))
+ ()
+ ;;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-article-length (- (point-max) (point-min)))
+ (gnus-cite-parse))))
+
+(defun gnus-cite-parse ()
+ ;; Parse and connect citation prefixes and attribution lines.
+
+ ;; Parse current buffer searching for citation prefixes.
+ (goto-char (point-min))
+ (or (search-forward "\n\n" nil t)
+ (goto-char (point-max)))
+ (let ((line (1+ (count-lines (point-min) (point))))
+ (case-fold-search t)
+ (max (save-excursion
+ (goto-char (point-max))
+ (re-search-backward gnus-signature-separator nil t)
+ (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.
+ (if (looking-at gnus-supercite-regexp)
+ (if (match-end 1)
+ (setq end (1+ (match-end 1)))
+ (setq end (1+ begin))))
+ ;; Ignore very long prefixes.
+ (if (> 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))
+ (set-text-properties 0 (length prefix) nil prefix)
+ (setq entry (assoc prefix alist))
+ (if entry
+ (setcdr entry (cons line (cdr entry)))
+ (setq alist (cons (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.
+ (setq gnus-cite-prefix-alist
+ (cons entry gnus-cite-prefix-alist)))
+ (t
+ (setq gnus-cite-prefix-alist (cons 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))))))))
+ ;; 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.
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (while (re-search-forward gnus-cite-attribution-postfix (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)
+ (and (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-postfix
+ start t))
+ (count-lines (point-min) (1+ (point)))))))
+ (if (eq wrote in)
+ (setq in nil))
+ (goto-char end)
+ (setq gnus-cite-loose-attribution-alist
+ (cons (list wrote in prefix tag)
+ gnus-cite-loose-attribution-alist))))
+ ;; Find exact supercite citations.
+ (gnus-cite-match-attributions 'small nil
+ (lambda (prefix tag)
+ (if tag
+ (concat "\\`"
+ (regexp-quote prefix) "[ \t]*"
+ (regexp-quote tag) ">"))))
+ ;; Find loose supercite citations after attributions.
+ (gnus-cite-match-attributions 'small t
+ (lambda (prefix tag)
+ (if tag (concat "\\<"
+ (regexp-quote tag)
+ "\\>"))))
+ ;; Find loose supercite citations anywhere.
+ (gnus-cite-match-attributions 'small nil
+ (lambda (prefix tag)
+ (if 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))
+ (if (< (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 concidered.
+ ;;
+ ;; 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
+ ;; concidered.
+ ;;
+ ;; 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))
+ (setq gnus-cite-attribution-alist
+ (cons (cons wrote (car best)) gnus-cite-attribution-alist))
+ (if in
+ (setq gnus-cite-attribution-alist
+ (cons (cons in (car best)) gnus-cite-attribution-alist)))
+ (if (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))
+ (if (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))
+ (if (string-equal (gnus-cite-find-prefix line) prefix)
+ (setq lines (cons 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.
+ (if face
+ (let ((inhibit-point-motion-hooks t)
+ from to)
+ (goto-line number)
+ (forward-char (length prefix))
+ (skip-chars-forward " \t")
+ (setq from (point))
+ (end-of-line 1)
+ (skip-chars-backward " \t")
+ (setq to (point))
+ (if (< 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
+ (add-text-properties (point) (progn (forward-line 1) (point))
+ 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))
+ (if (memq line (cdr entry))
+ (setq prefix (car entry))))
+ prefix))
+
+(gnus-ems-redefine)
+
+(provide 'gnus-cite)
+
+;;; gnus-cite.el ends here
diff --git a/lisp/gnus-cus.el b/lisp/gnus-cus.el
new file mode 100644
index 00000000000..b4845d8df4d
--- /dev/null
+++ b/lisp/gnus-cus.el
@@ -0,0 +1,546 @@
+;;; gnus-cus.el --- User friendly customization of Gnus
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;;
+;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
+;; Keywords: help, news
+;; Version: 0.1
+
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'custom)
+(require 'gnus-ems)
+
+;; The following is just helper functions and data, not ment to be set
+;; by the user.
+(defun gnus-make-face (color)
+ ;; Create entry for face with COLOR.
+ (custom-face-lookup color nil nil nil nil nil))
+
+(defvar gnus-face-light-name-list
+ '("light blue" "light cyan" "light yellow" "light pink"
+ "pale green" "beige" "orange" "magenta" "violet" "medium purple"
+ "turquoise"))
+
+(defvar gnus-face-dark-name-list
+ '("RoyalBlue" "firebrick"
+ "dark green" "OrangeRed" "dark khaki" "dark violet"
+ "SteelBlue4"))
+; CornflowerBlue SeaGreen OrangeRed SteelBlue4 DeepPink3
+; DarkOlviveGreen4
+
+(custom-declare '()
+ '((tag . "GNUS")
+ (doc . "\
+The coffe-brewing, all singing, all dancing, kitchen sink newsreader.")
+ (type . group)
+ (data ((tag . "Visual")
+ (doc . "\
+GNUS can be made colorful and fun or grey and dull as you wish.")
+ (type . group)
+ (data ((tag . "Visual")
+ (doc . "Enable visual features.
+If `visual' is disabled, there will be no menus and few faces. Most of
+the visual customization options below will be ignored. GNUS will use
+less space and be faster as a result.")
+ (default . t)
+ (name . gnus-visual)
+ (type . toggle))
+ ((tag . "WWW Browser")
+ (doc . "\
+WWW Browser to call when clicking on an URL button in the article buffer.
+
+You can choose between one of the predefined browsers, or `Other'.")
+ (name . gnus-button-url)
+ (calculate . (cond ((boundp 'browse-url-browser-function)
+ browse-url-browser-function)
+ ((fboundp 'w3-fetch)
+ 'w3-fetch)
+ ((eq window-system 'x)
+ 'gnus-netscape-open-url)))
+ (type . choice)
+ (data ((tag . "W3")
+ (type . const)
+ (default . w3-fetch))
+ ((tag . "Netscape")
+ (type . const)
+ (default . gnus-netscape-open-url))
+ ((prompt . "Other")
+ (doc . "\
+You must specify the name of a Lisp function here. The lisp function
+should open a WWW browser when called with an URL (a string).
+")
+ (default . __uninitialized__)
+ (type . symbol))))
+ ((tag . "Mouse Face")
+ (doc . "\
+Face used for group or summary buffer mouse highlighting.
+The line beneath the mouse pointer will be highlighted with this
+face.")
+ (name . gnus-mouse-face)
+ (calculate . (if (boundp 'gnus-mouse-face)
+ gnus-mouse-face
+ 'highlight))
+ (type . face))
+ ((tag . "Article Display")
+ (doc . "Controls how the article buffer will look.
+
+The list below contains various filters you can use to change the look
+of the article. If you leave the list empty, the article will appear
+exactly as it is stored on the disk. The list entries will hide or
+highlight various parts of the article, making it easier to find the
+information you want.")
+ (name . gnus-article-display-hook)
+ (type . list)
+ (default . (gnus-article-hide-headers-if-wanted
+ gnus-article-treat-overstrike
+ gnus-article-maybe-highlight))
+ (data ((type . repeat)
+ (header . nil)
+ (data (tag . "Filter")
+ (type . choice)
+ (data ((tag . "Treat Overstrike")
+ (doc . "\
+Convert use of overstrike into bold and underline.
+
+Two identical letters separated by a backspace are displayed as a
+single bold letter, while a letter followed by a backspace and an
+underscore will be displayed as a single underlined letter. This
+technique was developed for old line printers (think about it), and is
+still in use on some newsgroups, in particular the ClariNet
+hierearchy.
+")
+ (type . const)
+ (default .
+ gnus-article-treat-overstrike))
+ ((tag . "Word Wrap")
+ (doc . "\
+Format too long lines.
+")
+ (type . const)
+ (default . gnus-article-word-wrap))
+ ((tag . "Remove CR")
+ (doc . "\
+Remove carriage returns from an article.
+")
+ (type . const)
+ (default . gnus-article-remove-cr))
+ ((tag . "Display X-Face")
+ (doc . "\
+Look for an X-Face header and display it if present.
+
+See also `X Face Command' for a definition of the external command
+used for decoding and displaying the face.
+")
+ (type . const)
+ (default . gnus-article-display-x-face))
+ ((tag . "Unquote Printable")
+ (doc . "\
+Tranform MIME quoted printable into 8-bit characters.
+
+Quoted printable is often seen by strings like `=EF' where you would
+expect a non-English letter.
+")
+ (type . const)
+ (default .
+ gnus-article-de-quoted-unreadable))
+ ((tag . "Universal Time")
+ (doc . "\
+Convert date header to universal time.
+")
+ (type . const)
+ (default . gnus-article-date-ut))
+ ((tag . "Local Time")
+ (doc . "\
+Convert date header to local timezone.
+")
+ (type . const)
+ (default . gnus-article-date-local))
+ ((tag . "Lapsed Time")
+ (doc . "\
+Replace date header with a header showing the articles age.
+")
+ (type . const)
+ (default . gnus-article-date-lapsed))
+ ((tag . "Highlight")
+ (doc . "\
+Highlight headers, citations, signature, and buttons.
+")
+ (type . const)
+ (default . gnus-article-highlight))
+ ((tag . "Maybe Highlight")
+ (doc . "\
+Highlight headers, signature, and buttons if `Visual' is turned on.
+")
+ (type . const)
+ (default .
+ gnus-article-maybe-highlight))
+ ((tag . "Highlight Some")
+ (doc . "\
+Highlight headers, signature, and buttons.
+")
+ (type . const)
+ (default . gnus-article-highlight-some))
+ ((tag . "Highlight Headers")
+ (doc . "\
+Highlight headers as specified by `Article Header Highligting'.
+")
+ (type . const)
+ (default .
+ gnus-article-highlight-headers))
+ ((tag . "Highlight Signature")
+ (doc . "\
+Highlight the signature as specified by `Article Signature Face'.
+")
+ (type . const)
+ (default .
+ gnus-article-highlight-signature))
+ ((tag . "Citation")
+ (doc . "\
+Highlight the citations as specified by `Citation Faces'.
+")
+ (type . const)
+ (default .
+ gnus-article-highlight-citation))
+ ((tag . "Hide")
+ (doc . "\
+Hide unwanted headers, excess citation, and the signature.
+")
+ (type . const)
+ (default . gnus-article-hide))
+ ((tag . "Hide Headers If Wanted")
+ (doc . "\
+Hide headers, but allow user to display them with `t' or `v'.
+")
+ (type . const)
+ (default .
+ gnus-article-hide-headers-if-wanted))
+ ((tag . "Hide Headers")
+ (doc . "\
+Hide unwanted headers and possibly sort them as well.
+Most likely you want to use `Hide Headers If Wanted' instead.
+")
+ (type . const)
+ (default . gnus-article-hide-headers))
+ ((tag . "Hide Signature")
+ (doc . "\
+Hide the signature.
+")
+ (type . const)
+ (default . gnus-article-hide-signature))
+ ((tag . "Hide Excess Citations")
+ (doc . "\
+Hide excess citation.
+
+Excess is defined by `Citation Hide Percentage' and `Citation Hide Absolute'.
+")
+ (type . const)
+ (default .
+ gnus-article-hide-citation-maybe))
+ ((tag . "Hide Citations")
+ (doc . "\
+Hide all cited text.
+")
+ (type . const)
+ (default . gnus-article-hide-citation))
+ ((tag . "Add Buttons")
+ (doc . "\
+Make URL's into clickable buttons.
+")
+ (type . const)
+ (default . gnus-article-add-buttons))
+ ((prompt . "Other")
+ (doc . "\
+Name of Lisp function to call.
+
+Push the `Filter' button to select one of the predefined filters.
+")
+ (type . symbol)))))))
+ ((tag . "Article Button Face")
+ (doc . "\
+Face used for highlighting buttons in the article buffer.
+
+An article button is a piece of text that you can activate by pressing
+`RET' or `mouse-2' above it.")
+ (name . gnus-article-button-face)
+ (default . bold)
+ (type . face))
+ ((tag . "Article Mouse Face")
+ (doc . "\
+Face used for mouse highlighting in the article buffer.
+
+Article buttons will be displayed in this face when the cursor is
+above them.")
+ (name . gnus-article-mouse-face)
+ (default . highlight)
+ (type . face))
+ ((tag . "Article Signature Face")
+ (doc . "\
+Face used for highlighting a signature in the article buffer.")
+ (name . gnus-signature-face)
+ (default . italic)
+ (type . face))
+ ((tag . "Article Header Highlighting")
+ (doc . "\
+Controls highlighting of article header.
+
+Below is a list of article header names, and the faces used for
+displaying the name and content of the header. The `Header' field
+should contain the name of the header. The field actually contains a
+regular expression that should match the beginning of the header line,
+but if you don't know what a regular expression is, just write the
+name of the header. The second field is the `Name' field, which
+determines how the the header name (i.e. the part of the header left
+of the `:') is displayed. The third field is the `Content' field,
+which determines how the content (i.e. the part of the header right of
+the `:') is displayed.
+
+If you leave the last `Header' field in the list empty, the `Name' and
+`Content' fields will determine how headers not listed above are
+displayed.
+
+If you only want to change the display of the name part for a specific
+header, specify `None' in the `Content' field. Similarly, specify
+`None' in the `Name' field if you only want to leave the name part
+alone.")
+ (name . gnus-header-face-alist)
+ (type . list)
+ (calculate . (cond ((not (eq gnus-display-type 'color))
+ '(("" bold italic)))
+ ((eq gnus-background-mode 'dark)
+ (list (list "From" nil
+ (custom-face-lookup
+ "dark blue" nil nil t t nil))
+ (list "Subject" nil
+ (custom-face-lookup
+ "pink" nil nil t t nil))
+ (list "Newsgroups:.*," nil
+ (custom-face-lookup
+ "yellow" nil nil t t nil))
+ (list ""
+ (custom-face-lookup
+ "cyan" nil nil t nil nil)
+ (custom-face-lookup
+ "forestgreen"
+ nil nil nil t nil))))
+ (t
+ (list (list "From" nil
+ (custom-face-lookup
+ "RoyalBlue"
+ nil nil t t nil))
+ (list "Subject" nil
+ (custom-face-lookup
+ "firebrick"
+ nil nil t t nil))
+ (list "Newsgroups:.*," nil
+ (custom-face-lookup
+ "indianred" nil nil t t nil))
+ (list ""
+ (custom-face-lookup
+ "DarkGreen"
+ nil nil t nil nil)
+ (custom-face-lookup
+ "DarkGreen"
+ nil nil nil t nil))))))
+ (data ((type . repeat)
+ (header . nil)
+ (data (type . list)
+ (compact . t)
+ (data ((type . string)
+ (prompt . "Header")
+ (tag . "Header "))
+ "\n "
+ ((type . face)
+ (prompt . "Name")
+ (tag . "Name "))
+ "\n "
+ ((type . face)
+ (tag . "Content"))
+ "\n")))))
+ ((tag . "Attribution Face")
+ (doc . "\
+Face used for attribution lines.
+It is merged with the face for the cited text belonging to the attribution.")
+ (name . gnus-cite-attribution-face)
+ (default . underline)
+ (type . face))
+ ((tag . "Citation Faces")
+ (doc . "\
+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.")
+ (name . gnus-cite-face-list)
+ (import . gnus-custom-import-cite-face-list)
+ (type . list)
+ (calculate . (cond ((not (eq gnus-display-type 'color))
+ '(italic))
+ ((eq gnus-background-mode 'dark)
+ (mapcar 'gnus-make-face
+ gnus-face-light-name-list))
+ (t
+ (mapcar 'gnus-make-face
+ gnus-face-dark-name-list))))
+ (data ((type . repeat)
+ (header . nil)
+ (data (type . face)
+ (tag . "Face")))))
+ ((tag . "Citation Hide Percentage")
+ (doc . "\
+Only hide excess citation if above this percentage of the body.")
+ (name . gnus-cite-hide-percentage)
+ (default . 50)
+ (type . integer))
+ ((tag . "Citation Hide Absolute")
+ (doc . "\
+Only hide excess citation if above this number of lines in the body.")
+ (name . gnus-cite-hide-absolute)
+ (default . 10)
+ (type . integer))
+ ((tag . "Summary Selected Face")
+ (doc . "\
+Face used for highlighting the current article in the summary buffer.")
+ (name . gnus-summary-selected-face)
+ (default . underline)
+ (type . face))
+ ((tag . "Summary Line Highlighting")
+ (doc . "\
+Controls the higlighting of summary buffer lines.
+
+Below is a list of `Form'/`Face' pairs. When deciding how a a
+particular summary line should be displayed, each form is
+evaluated. The content of the face field after the first true form is
+used. You can change how those summary lines are displayed, by
+editing the face field.
+
+It is also possible to change and add form fields, but currently that
+requires an understanding of Lisp expressions. Hopefully this will
+change in a future release. For now, you can use the following
+variables in the Lisp expression:
+
+score: The article's score
+default: The default article score.
+below: The score below which articles are automatically marked as read.
+mark: The article's mark.")
+ (name . gnus-summary-highlight)
+ (type . list)
+ (calculate . (cond ((not (eq gnus-display-type 'color))
+ '(((> score default) . bold)
+ ((< score default) . italic)))
+ ((eq gnus-background-mode 'dark)
+ (list (cons '(= mark gnus-canceled-mark)
+ (custom-face-lookup "yellow" "black" nil nil nil nil))
+ (cons '(and (> score default)
+ (or (= mark gnus-dormant-mark)
+ (= mark gnus-ticked-mark)))
+ (custom-face-lookup "pink" nil nil t nil nil))
+ (cons '(and (< score default)
+ (or (= mark gnus-dormant-mark)
+ (= mark gnus-ticked-mark)))
+ (custom-face-lookup "pink" nil nil nil t nil))
+ (cons '(or (= mark gnus-dormant-mark)
+ (= mark gnus-ticked-mark))
+ (custom-face-lookup "pink" nil nil nil nil nil))
+
+ (cons '(and (> score default) (= mark gnus-ancient-mark))
+ (custom-face-lookup "dark blue" nil nil t nil nil))
+ (cons '(and (< score default) (= mark gnus-ancient-mark))
+ (custom-face-lookup "SkyBlue" nil nil nil t nil))
+ (cons '(= mark gnus-ancient-mark)
+ (custom-face-lookup "SkyBlue" nil nil nil nil nil))
+
+ (cons '(and (> score default) (= mark gnus-unread-mark))
+ (custom-face-lookup "white" nil nil t nil nil))
+ (cons '(and (< score default) (= mark gnus-unread-mark))
+ (custom-face-lookup "white" nil nil nil t nil))
+ (cons '(= mark gnus-unread-mark)
+ (custom-face-lookup "white" nil nil nil nil nil))
+
+ (cons '(> score default) 'bold)
+ (cons '(< score default) 'italic)))
+ (t
+ (list (cons '(= mark gnus-canceled-mark)
+ (custom-face-lookup "yellow" "black" nil nil nil nil))
+ (cons '(and (> score default)
+ (or (= mark gnus-dormant-mark)
+ (= mark gnus-ticked-mark)))
+ (custom-face-lookup "firebrick" nil nil t nil nil))
+ (cons '(and (< score default)
+ (or (= mark gnus-dormant-mark)
+ (= mark gnus-ticked-mark)))
+ (custom-face-lookup "firebrick" nil nil nil t nil))
+ (cons '(or (= mark gnus-dormant-mark)
+ (= mark gnus-ticked-mark))
+ (custom-face-lookup "firebrick" nil nil nil nil nil))
+
+ (cons '(and (> score default) (= mark gnus-ancient-mark))
+ (custom-face-lookup "RoyalBlue" nil nil t nil nil))
+ (cons '(and (< score default) (= mark gnus-ancient-mark))
+ (custom-face-lookup "RoyalBlue" nil nil nil t nil))
+ (cons '(= mark gnus-ancient-mark)
+ (custom-face-lookup "RoyalBlue" nil nil nil nil nil))
+
+ (cons '(and (> score default) (/= mark gnus-unread-mark))
+ (custom-face-lookup "DarkGreen" nil nil t nil nil))
+ (cons '(and (< score default) (/= mark gnus-unread-mark))
+ (custom-face-lookup "DarkGreen" nil nil nil t nil))
+ (cons '(/= mark gnus-unread-mark)
+ (custom-face-lookup "DarkGreen" nil nil nil nil nil))
+
+ (cons '(> score default) 'bold)
+ (cons '(< score default) 'italic)))))
+ (data ((type . repeat)
+ (header . nil)
+ (data (type . pair)
+ (compact . t)
+ (data ((type . sexp)
+ (width . 60)
+ (tag . "Form"))
+ "\n "
+ ((type . face)
+ (tag . "Face"))
+ "\n")))))
+ ;; Do not define `gnus-button-alist' before we have
+ ;; some `complexity' attribute so we can hide it from
+ ;; beginners.
+ )))))
+
+(defun gnus-custom-import-cite-face-list (custom alist)
+ ;; Backward compatible groking of light and dark.
+ (cond ((eq alist 'light)
+ (setq alist (mapcar 'gnus-make-face gnus-face-light-name-list)))
+ ((eq alist 'dark)
+ (setq alist (mapcar 'gnus-make-face gnus-face-dark-name-list))))
+ (funcall (custom-super custom 'import) custom alist))
+
+;(defun gnus-custom-import-swap-alist (custom alist)
+; ;; Swap key and value in CUSTOM ALIST.
+; (let ((swap (mapcar (lambda (e) (cons (cdr e) (car e))) alist)))
+; (funcall (custom-super custom 'import) custom swap)))
+
+;(defun gnus-custom-export-swap-alist (custom alist)
+; ;; Swap key and value in CUSTOM ALIST.
+; (let ((swap (mapcar (lambda (e) (cons (cdr e) (car e))) alist)))
+; (funcall (custom-super custom 'export) custom swap)))
+
+(provide 'gnus-cus)
+
+;;; gnus-cus.el ends here
diff --git a/lisp/gnus-edit.el b/lisp/gnus-edit.el
new file mode 100644
index 00000000000..964528ae655
--- /dev/null
+++ b/lisp/gnus-edit.el
@@ -0,0 +1,628 @@
+;;; gnus-edit.el --- Gnus SCORE file editing
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+;;
+;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
+;; Keywords: news, help
+;; Version: 0.2
+
+;;; Commentary:
+;;
+;; Type `M-x gnus-score-customize RET' to invoke.
+
+;;; Code:
+
+(require 'custom)
+(require 'gnus-score)
+
+(defconst gnus-score-custom-data
+ '((tag . "Score")
+ (doc . "Customization of Gnus SCORE files.
+
+SCORE files allow you to assign a score to each article when you enter
+a group, and automatically mark the articles as read or delete them
+based on the score. In the summary buffer you can use the score to
+sort the articles by score (`C-c C-s C-s') or to jump to the unread
+article with the highest score (`,').")
+ (type . group)
+ (data "\n"
+ ((header . nil)
+ (doc . "Name of SCORE file to customize.
+
+Enter the name in the `File' field, then push the [Load] button to
+load it. When done editing, push the [Save] button to save the file.
+
+Several score files may apply to each group, and several groups may
+use the same score file. This is controlled implicitly by the name of
+the score file and the value of the global variable
+`gnus-score-find-score-files-function', and explicitly by the the
+`Files' and `Exclude Files' entries.")
+ (compact . t)
+ (type . group)
+ (data ((tag . "Load")
+ (type . button)
+ (query . gnus-score-custom-load))
+ ((tag . "Save")
+ (type . button)
+ (query . gnus-score-custom-save))
+ ((name . file)
+ (tag . "File")
+ (directory . "~/News/")
+ (default-file . "SCORE")
+ (type . file))))
+ ((name . files)
+ (tag . "Files")
+ (doc . "\
+List of score files to load when the the current score file is loaded.
+You can use this to share score entries between multiple score files.
+
+Push the `[INS]' button add a score file to the list, or `[DEL]' to
+delete a score file from the list.")
+ (type . list)
+ (data ((type . repeat)
+ (header . nil)
+ (data (type . file)
+ (directory . "~/News/")))))
+ ((name . exclude-files)
+ (tag . "Exclude Files")
+ (doc . "\
+List of score files to exclude when the the current score file is loaded.
+You can use this if you have a score file you want to share between a
+number of newsgroups, except for the newsgroup this score file
+matches. [ Did anyone get that? ]
+
+Push the `[INS]' button add a score file to the list, or `[DEL]' to
+delete a score file from the list.")
+ (type . list)
+ (data ((type . repeat)
+ (header . nil)
+ (data (type . file)
+ (directory . "~/News/")))))
+ ((name . mark)
+ (tag . "Mark")
+ (doc . "\
+Articles below this score will be automatically marked as read.
+
+This means that when you enter the summary buffer, the articles will
+be shown but will already be marked as read. You can then press `x'
+to get rid of them entirely.
+
+By default articles with a negative score will be marked as read. To
+change this, push the `Mark' button, and choose `Integer'. You can
+then enter a value in the `Mark' field.")
+ (type . gnus-score-custom-maybe-type))
+ ((name . expunge)
+ (tag . "Expunge")
+ (doc . "\
+Articles below this score will not be shown in the summary buffer.")
+ (type . gnus-score-custom-maybe-type))
+ ((name . mark-and-expunge)
+ (tag . "Mark and Expunge")
+ (doc . "\
+Articles below this score will be marked as read, but not shown.
+
+Someone should explain me the difference between this and `expunge'
+alone or combined with `mark'.")
+ (type . gnus-score-custom-maybe-type))
+ ((name . eval)
+ (tag . "Eval")
+ (doc . "\
+Evaluate this lisp expression when the entering summary buffer.")
+ (type . sexp))
+ ((name . read-only)
+ (tag . "Read Only")
+ (doc . "Read-only score files will not be updated or saved.
+Except from this buffer, of course!")
+ (type . toggle))
+ ((type . doc)
+ (doc . "\
+Each news header has an associated list of score entries.
+You can use the [INS] buttons to add new score entries anywhere in the
+list, or the [DEL] buttons to delete specific score entries.
+
+Each score entry should specify a string that should be matched with
+the content actual header in order to determine whether the entry
+applies to that header. Enter that string in the `Match' field.
+
+If the score entry matches, the articles score will be adjusted with
+some amount. Enter that amount in the in the `Score' field. You
+should specify a positive amount for score entries that matches
+articles you find interesting, and a negative amount for score entries
+matching articles you would rather avoid. The final score for the
+article will be the sum of the score of all score entries that match
+the article.
+
+The score entry can be either permanent or expirable. To make the
+entry permanent, push the `Date' button and choose the `Permanent'
+entry. To make the entry expirable, choose instead the `Integer'
+entry. After choosing the you can enter the date the score entry was
+last matched in the `Date' field. The date will be automatically
+updated each time the score entry matches an article. When the date
+become too old, the the score entry will be removed.
+
+For your convenience, the date is specified as the number of days
+elapsed since the (imaginary) Gregorian date Sunday, December 31, 1
+BC.
+
+Finally, you can choose what kind of match you want to perform by
+pushing the `Type' button. For most entries you can choose between
+`Exact' which mean the header content must be exactly identical to the
+match string, or `Substring' meaning the match string should be
+somewhere in the header content, or even `Regexp' to use Emacs regular
+expression matching. The last choice is `Fuzzy' which is like `Exact'
+except that whitespace derivations, a beginning `Re:' or a terminating
+parenthetical remark are all ignored. Each of the four types have a
+variant which will ignore case in the comparison. That variant is
+indicated with a `(fold)' after its name."))
+ ((name . from)
+ (tag . "From")
+ (doc . "Scoring based on the authors email address.")
+ (type . gnus-score-custom-string-type))
+ ((name . subject)
+ (tag . "Subject")
+ (doc . "Scoring based on the articles subject.")
+ (type . gnus-score-custom-string-type))
+ ((name . followup)
+ (tag . "Followup")
+ (doc . "Scoring based on who the article is a followup to.
+
+If you want to see all followups to your own articles, add an entry
+with a positive score matching your email address here. You can also
+put an entry with a negative score matching someone who is so annoying
+that you don't even want to see him quoted in followups.")
+ (type . gnus-score-custom-string-type))
+ ((name . xref)
+ (tag . "Xref")
+ (doc . "Scoring based on article crossposting.
+
+If you want to score based on which newsgroups an article is posted
+to, this is the header to use. The syntax is a little different from
+the `Newsgroups' header, but scoring in `Xref' is much faster. As an
+example, to match all crossposted articles match on `:.*:' using the
+`Regexp' type.")
+ (type . gnus-score-custom-string-type))
+ ((name . references)
+ (tag . "References")
+ (doc . "Scoring based on article references.
+
+The `References' header gives you an alternative way to score on
+followups. If you for example want to see follow all discussions
+where people from `iesd.auc.dk' school participate, you can add a
+substring match on `iesd.auc.dk>' on this header.")
+ (type . gnus-score-custom-string-type))
+ ((name . message-id)
+ (tag . "Message-ID")
+ (doc . "Scoring based on the articles message-id.
+
+This isn't very useful, but Lars like completeness. You can use it to
+match all messaged generated by recent Gnus version with a `Substring'
+match on `.fsf@'.")
+ (type . gnus-score-custom-string-type))
+ ((type . doc)
+ (doc . "\
+WARNING: Scoring on the following three pseudo headers is very slow!
+Scoring on any of the real headers use a technique that avoids
+scanning the entire article, only the actual headers you score on are
+scanned, and this scanning has been heavily optimized. Using just a
+single entry for one the three pseudo-headers `Head', `Body', and
+`All' will require GNUS to retrieve and scan the entire article, which
+can be very slow on large groups. However, if you add one entry for
+any of these headers, you can just as well add several. Each
+subsequent entry cost relatively little extra time."))
+ ((name . head)
+ (tag . "Head")
+ (doc . "Scoring based on the article header.
+
+Instead of matching the content of a single header, the entire header
+section of the article is matched. You can use this to match on
+arbitrary headers, foe example to single out TIN lusers, use a substring
+match on `Newsreader: TIN'. That should get 'em!")
+ (type . gnus-score-custom-string-type))
+ ((name . body)
+ (tag . "Body")
+ (doc . "Scoring based on the article body.
+
+If you think any article that mentions `Kibo' is inherently
+interesting, do a substring match on His name. You Are Allowed.")
+ (type . gnus-score-custom-string-type))
+ ((name . all)
+ (tag . "All")
+ (doc . "Scoring based on the whole article.")
+ (type . gnus-score-custom-string-type))
+ ((name . date)
+ (tag . "Date")
+ (doc . "Scoring based on article date.
+
+You can change the score of articles that have been posted before,
+after, or at a specific date. You should add the date in the `Match'
+field, and then select `before', `after', or `at' by pushing the
+`Type' button. Imagine you want to lower the score of very old
+articles, or want to raise the score of articles from the future (such
+things happen!). Then you can't use date scoring for that. In fact,
+I can't imagine anything you would want to use this for.
+
+For your convenience, the date is specified in Usenet date format.")
+ (type . gnus-score-custom-date-type))
+ ((type . doc)
+ (doc . "\
+The Lines and Chars headers use integer based scoring.
+
+This means that you should write an integer in the `Match' field, and
+the push the `Type' field to if the `Chars' or `Lines' header should
+be larger, equal, or smaller than the number you wrote in the match
+field."))
+ ((name . chars)
+ (tag . "Characters")
+ (doc . "Scoring based on the number of characters in the article.")
+ (type . gnus-score-custom-integer-type))
+ ((name . lines)
+ (tag . "Lines")
+ (doc . "Scoring based on the number of lines in the article.")
+ (type . gnus-score-custom-integer-type))
+ ((name . orphan)
+ (tag . "Orphan")
+ (doc . "Score to add to articles with no parents.")
+ (type . gnus-score-custom-maybe-type))
+ ((name . adapt)
+ (tag . "Adapt")
+ (doc . "Adapting the score files to your newsreading habits.
+
+When you have finished reading a group GNUS can automatically create
+new score entries based on which articles you read and which you
+skipped. This is normally controled by the two global variables
+`gnus-use-adaptive-scoring' and `gnus-default-adaptive-score-alist',
+The first determines whether adaptive scoring should be enabled or
+not, while the second determines what score entries should be created.
+
+You can overwrite the setting of `gnus-use-adaptive-scoring' by
+selecting `Enable' or `Disable' by pressing the `Adapt' button.
+Selecting `Custom' will allow you to specify the exact adaption
+rules (overwriting `gnus-default-adaptive-score-alist').")
+ (type . choice)
+ (data ((tag . "Default")
+ (default . nil)
+ (type . const))
+ ((tag . "Enable")
+ (default . t)
+ (type . const))
+ ((tag . "Disable")
+ (default . ignore)
+ (type . const))
+ ((tag . "Custom")
+ (doc . "Customization of adaptive scoring.
+
+Each time you read an article it will be marked as read. Likewise, if
+you delete it it will be marked as deleted, and if you tick it it will
+be marked as ticked. When you leave a group, GNUS can automatically
+create score file entries based on these marks, so next time you enter
+the group articles with subjects that you read last time have higher
+score and articles with subjects that deleted will have lower score.
+
+Below is a list of such marks. You can insert new marks to the list
+by pushing on one of the `[INS]' buttons in the left margin to create
+a new entry and then pushing the `Mark' button to select the mark.
+For each mark there is another list, this time of article headers,
+which determine how the mark should affect that header. The `[INS]'
+buttons of this list are indented to indicate that the belong to the
+mark above. Push the `Header' button to choose a header, and then
+enter a score value in the `Score' field.
+
+For each article that are marked with `Mark' when you leave the
+group, a temporary score entry for the articles `Header' with the
+value of `Score' will be added the adapt file. If the score entry
+already exists, `Score' will be added to its value. If you understood
+that, you are smart.
+
+You can select the special value `Other' when pressing the `Mark' or
+`Header' buttons. This is because Lars might add more useful values
+there. If he does, it is up to you to figure out what they are named.")
+ (type . list)
+ (default . ((__uninitialized__)))
+ (data ((type . repeat)
+ (header . nil)
+ (data . ((type . list)
+ (header . nil)
+ (compact . t)
+ (data ((type . choice)
+ (tag . "Mark")
+ (data ((tag . "Unread")
+ (default . gnus-unread-mark)
+ (type . const))
+ ((tag . "Ticked")
+ (default . gnus-ticked-mark)
+ (type . const))
+ ((tag . "Dormant")
+ (default . gnus-dormant-mark)
+ (type . const))
+ ((tag . "Deleted")
+ (default . gnus-del-mark)
+ (type . const))
+ ((tag . "Read")
+ (default . gnus-read-mark)
+ (type . const))
+ ((tag . "Expirable")
+ (default . gnus-expirable-mark)
+ (type . const))
+ ((tag . "Killed")
+ (default . gnus-killed-mark)
+ (type . const))
+ ((tag . "Kill-file")
+ (default . gnus-kill-file-mark)
+ (type . const))
+ ((tag . "Low-score")
+ (default . gnus-low-score-mark)
+ (type . const))
+ ((tag . "Catchup")
+ (default . gnus-catchup-mark)
+ (type . const))
+ ((tag . "Ancient")
+ (default . gnus-ancient-mark)
+ (type . const))
+ ((tag . "Canceled")
+ (default . gnus-canceled-mark)
+ (type . const))
+ ((prompt . "Other")
+ (default . ??)
+ (type . sexp))))
+ ((type . repeat)
+ (prefix . " ")
+ (data . ((type . list)
+ (compact . t)
+ (data ((tag . "Header")
+ (type . choice)
+ (data ((tag . "Subject")
+ (default . subject)
+ (type . const))
+ ((prompt . "From")
+ (tag . "From ")
+ (default . from)
+ (type . const))
+ ((prompt . "Other")
+ (width . 7)
+ (default . nil)
+ (type . symbol))))
+ ((tag . "Score")
+ (type . integer))))))))))))))
+ ((name . local)
+ (tag . "Local")
+ (doc . "\
+List of local variables to set when this score file is loaded.
+
+Using this entry can provide a convenient way to set variables that
+will affect the summary mode for only some specific groups, i.e. those
+groups matched by the current score file.")
+ (type . list)
+ (data ((type . repeat)
+ (header . nil)
+ (data . ((type . list)
+ (compact . t)
+ (data ((tag . "Name")
+ (width . 26)
+ (type . symbol))
+ ((tag . "Value")
+ (width . 26)
+ (type . sexp)))))))))))
+
+(defconst gnus-score-custom-type-properties
+ '((gnus-score-custom-maybe-type
+ (type . choice)
+ (data ((type . integer)
+ (default . 0))
+ ((tag . "Default")
+ (type . const)
+ (default . nil))))
+ (gnus-score-custom-string-type
+ (type . list)
+ (data ((type . repeat)
+ (header . nil)
+ (data . ((type . list)
+ (compact . t)
+ (data ((tag . "Match")
+ (width . 59)
+ (type . string))
+ "\n "
+ ((tag . "Score")
+ (type . integer))
+ ((tag . "Date")
+ (type . choice)
+ (data ((type . integer)
+ (default . 0)
+ (width . 9))
+ ((tag . "Permanent")
+ (type . const)
+ (default . nil))))
+ ((tag . "Type")
+ (type . choice)
+ (data ((tag . "Exact")
+ (default . E)
+ (type . const))
+ ((tag . "Substring")
+ (default . S)
+ (type . const))
+ ((tag . "Regexp")
+ (default . R)
+ (type . const))
+ ((tag . "Fuzzy")
+ (default . F)
+ (type . const))
+ ((tag . "Exact (fold)")
+ (default . e)
+ (type . const))
+ ((tag . "Substring (fold)")
+ (default . s)
+ (type . const))
+ ((tag . "Regexp (fold)")
+ (default . r)
+ (type . const))
+ ((tag . "Fuzzy (fold)")
+ (default . f)
+ (type . const))))))))))
+ (gnus-score-custom-integer-type
+ (type . list)
+ (data ((type . repeat)
+ (header . nil)
+ (data . ((type . list)
+ (compact . t)
+ (data ((tag . "Match")
+ (type . integer))
+ ((tag . "Score")
+ (type . integer))
+ ((tag . "Date")
+ (type . choice)
+ (data ((type . integer)
+ (default . 0)
+ (width . 9))
+ ((tag . "Permanent")
+ (type . const)
+ (default . nil))))
+ ((tag . "Type")
+ (type . choice)
+ (data ((tag . "<")
+ (default . <)
+ (type . const))
+ ((tag . ">")
+ (default . >)
+ (type . const))
+ ((tag . "=")
+ (default . =)
+ (type . const))
+ ((tag . ">=")
+ (default . >=)
+ (type . const))
+ ((tag . "<=")
+ (default . <=)
+ (type . const))))))))))
+ (gnus-score-custom-date-type
+ (type . list)
+ (data ((type . repeat)
+ (header . nil)
+ (data . ((type . list)
+ (compact . t)
+ (data ((tag . "Match")
+ (width . 59)
+ (type . string))
+ "\n "
+ ((tag . "Score")
+ (type . integer))
+ ((tag . "Date")
+ (type . choice)
+ (data ((type . integer)
+ (default . 0)
+ (width . 9))
+ ((tag . "Permanent")
+ (type . const)
+ (default . nil))))
+ ((tag . "Type")
+ (type . choice)
+ (data ((tag . "Before")
+ (default . before)
+ (type . const))
+ ((tag . "After")
+ (default . after)
+ (type . const))
+ ((tag . "At")
+ (default . at)
+ (type . const))))))))))))
+
+(defvar gnus-score-custom-file nil
+ "Name of SCORE file being customized.")
+
+(defun gnus-score-customize ()
+ "Create a buffer for editing gnus SCORE files."
+ (interactive)
+ (let (gnus-score-alist)
+ (custom-buffer-create "*Score Edit*" gnus-score-custom-data
+ gnus-score-custom-type-properties
+ 'gnus-score-custom-set
+ 'gnus-score-custom-get
+ 'gnus-score-custom-save))
+ (make-local-variable 'gnus-score-custom-file)
+ (setq gnus-score-custom-file (expand-file-name "SCORE" "~/News"))
+ (make-local-variable 'gnus-score-alist)
+ (setq gnus-score-alist nil)
+ (custom-reset-all))
+
+(defun gnus-score-custom-get (name)
+ (if (eq name 'file)
+ gnus-score-custom-file
+ (let ((entry (assoc (symbol-name name) gnus-score-alist)))
+ (if entry
+ (mapcar 'gnus-score-custom-sanify (cdr entry))
+ (setq entry (assoc name gnus-score-alist))
+ (if (or (memq name '(files exclude-files local))
+ (and (eq name 'adapt)
+ (not (symbolp (car (cdr entry))))))
+ (cdr entry)
+ (car (cdr entry)))))))
+
+(defun gnus-score-custom-set (name value)
+ (cond ((eq name 'file)
+ (setq gnus-score-custom-file value))
+ ((assoc (symbol-name name) gnus-score-alist)
+ (if value
+ (setcdr (assoc (symbol-name name) gnus-score-alist) value)
+ (setq gnus-score-alist (delq (assoc (symbol-name name)
+ gnus-score-alist)
+ gnus-score-alist))))
+ ((assoc (symbol-name name) gnus-header-index)
+ (if value
+ (setq gnus-score-alist
+ (cons (cons (symbol-name name) value) gnus-score-alist))))
+ ((assoc name gnus-score-alist)
+ (cond ((null value)
+ (setq gnus-score-alist (delq (assoc name gnus-score-alist)
+ gnus-score-alist)))
+ ((and (listp value) (not (eq name 'eval)))
+ (setcdr (assoc name gnus-score-alist) value))
+ (t
+ (setcdr (assoc name gnus-score-alist) (list value)))))
+ ((null value))
+ ((and (listp value) (not (eq name 'eval)))
+ (setq gnus-score-alist (cons (cons name value) gnus-score-alist)))
+ (t
+ (setq gnus-score-alist
+ (cons (cons name (list value)) gnus-score-alist)))))
+
+(defun gnus-score-custom-sanify (entry)
+ (list (nth 0 entry)
+ (or (nth 1 entry) gnus-score-interactive-default-score)
+ (nth 2 entry)
+ (cond ((null (nth 3 entry))
+ 's)
+ ((memq (nth 3 entry) '(before after at >= <=))
+ (nth 3 entry))
+ (t
+ (intern (substring (symbol-name (nth 3 entry)) 0 1))))))
+
+(defvar gnus-score-cache nil)
+
+(defun gnus-score-custom-load ()
+ (interactive)
+ (let ((file (custom-name-value 'file)))
+ (if (eq file custom-nil)
+ (error "You must specify a file name"))
+ (setq file (expand-file-name file "~/News"))
+ (gnus-score-load file)
+ (setq gnus-score-custom-file file)
+ (custom-reset-all)
+ (message "Loaded")))
+
+(defun gnus-score-custom-save ()
+ (interactive)
+ (custom-apply-all)
+ (gnus-score-remove-from-cache gnus-score-custom-file)
+ (let ((file gnus-score-custom-file)
+ (score gnus-score-alist)
+ emacs-lisp-mode-hook)
+ (save-excursion
+ (set-buffer (get-buffer-create "*Score*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (pp score (current-buffer))
+ (gnus-make-directory (file-name-directory file))
+ (write-region (point-min) (point-max) file nil 'silent)
+ (kill-buffer (current-buffer))))
+ (message "Saved"))
+
+(provide 'gnus-edit)
+
+;;; gnus-edit.el end here
diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el
new file mode 100644
index 00000000000..e0b2244ab0e
--- /dev/null
+++ b/lisp/gnus-ems.el
@@ -0,0 +1,693 @@
+;;; gnus-ems.el --- functions for making Gnus work under different Emacsen
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(defvar gnus-mouse-2 [mouse-2])
+(defvar gnus-group-mode-hook ())
+(defvar gnus-summary-mode-hook ())
+(defvar gnus-article-mode-hook ())
+
+(defalias 'gnus-make-overlay 'make-overlay)
+(defalias 'gnus-overlay-put 'overlay-put)
+(defalias 'gnus-move-overlay 'move-overlay)
+
+(or (fboundp 'mail-file-babyl-p)
+ (fset 'mail-file-babyl-p 'rmail-file-p))
+
+;; Don't warn about these undefined variables.
+ ;defined in gnus.el
+(defvar gnus-active-hashtb)
+(defvar gnus-article-buffer)
+(defvar gnus-auto-center-summary)
+(defvar gnus-buffer-list)
+(defvar gnus-current-headers)
+(defvar gnus-level-killed)
+(defvar gnus-level-zombie)
+(defvar gnus-newsgroup-bookmarks)
+(defvar gnus-newsgroup-dependencies)
+(defvar gnus-newsgroup-headers-hashtb-by-number)
+(defvar gnus-newsgroup-selected-overlay)
+(defvar gnus-newsrc-hashtb)
+(defvar gnus-read-mark)
+(defvar gnus-refer-article-method)
+(defvar gnus-reffed-article-number)
+(defvar gnus-unread-mark)
+(defvar gnus-version)
+(defvar gnus-view-pseudos)
+(defvar gnus-view-pseudos-separately)
+(defvar gnus-visual)
+(defvar gnus-zombie-list)
+ ;defined in gnus-msg.el
+(defvar gnus-article-copy)
+(defvar gnus-check-before-posting)
+ ;defined in gnus-vis.el
+(defvar gnus-article-button-face)
+(defvar gnus-article-mouse-face)
+(defvar gnus-summary-selected-face)
+
+
+;; We do not byte-compile this file, because error messages are such a
+;; bore.
+
+(defun gnus-set-text-properties-xemacs (start end props &optional buffer)
+ "You should NEVER use this function. It is ideologically blasphemous.
+It is provided only to ease porting of broken FSF Emacs programs."
+ (if (and (stringp buffer) (not (setq buffer (get-buffer buffer))))
+ nil
+ (map-extents (lambda (extent ignored)
+ (remove-text-properties
+ start end
+ (list (extent-property extent 'text-prop) nil)
+ buffer))
+ buffer start end nil nil 'text-prop)
+ (add-text-properties start end props buffer)))
+
+(eval
+ '(progn
+ (if (string-match "XEmacs\\|Lucid" emacs-version)
+ ()
+ ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
+ (defvar gnus-display-type
+ (condition-case nil
+ (let ((display-resource (x-get-resource ".displayType" "DisplayType")))
+ (cond (display-resource (intern (downcase display-resource)))
+ ((x-display-color-p) 'color)
+ ((x-display-grayscale-p) 'grayscale)
+ (t 'mono)))
+ (error 'mono))
+ "A symbol indicating the display Emacs is running under.
+The symbol should be one of `color', `grayscale' or `mono'. If Emacs
+guesses this display attribute wrongly, either set this variable in
+your `~/.emacs' or set the resource `Emacs.displayType' in your
+`~/.Xdefaults'. See also `gnus-background-mode'.
+
+This is a meta-variable that will affect what default values other
+variables get. You would normally not change this variable, but
+pounce directly on the real variables themselves.")
+
+ (defvar gnus-background-mode
+ (condition-case nil
+ (let ((bg-resource (x-get-resource ".backgroundMode"
+ "BackgroundMode"))
+ (params (frame-parameters)))
+ (cond (bg-resource (intern (downcase bg-resource)))
+ ((and (cdr (assq 'background-color params))
+ (< (apply '+ (x-color-values
+ (cdr (assq 'background-color params))))
+ (/ (apply '+ (x-color-values "white")) 3)))
+ 'dark)
+ (t 'light)))
+ (error 'light))
+ "A symbol indicating the Emacs background brightness.
+The symbol should be one of `light' or `dark'.
+If Emacs guesses this frame attribute wrongly, either set this variable in
+your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
+`~/.Xdefaults'.
+See also `gnus-display-type'.
+
+This is a meta-variable that will affect what default values other
+variables get. You would normally not change this variable, but
+pounce directly on the real variables themselves."))
+
+ (cond
+ ((string-match "XEmacs\\|Lucid" emacs-version)
+ ;; XEmacs definitions.
+
+ (setq gnus-mouse-2 [button2])
+
+ (or (memq 'underline (list-faces))
+ (and (fboundp 'make-face)
+ (funcall (intern "make-face") 'underline)))
+ ;; Must avoid calling set-face-underline-p directly, because it
+ ;; is a defsubst in emacs19, and will make the .elc files non
+ ;; portable!
+ (or (face-differs-from-default-p 'underline)
+ (funcall 'set-face-underline-p 'underline t))
+
+ (defalias 'gnus-make-overlay 'make-extent)
+ (defalias 'gnus-overlay-put 'set-extent-property)
+ (defun gnus-move-overlay (extent start end &optional buffer)
+ (set-extent-endpoints extent start end))
+
+ (require 'text-props)
+ (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
+
+ (or (boundp 'standard-display-table) (setq standard-display-table nil))
+ (or (boundp 'read-event) (fset 'read-event 'next-command-event))
+
+ ;; Fix by "jeff (j.d.) sparkes" <jsparkes@bnr.ca>.
+ (defvar gnus-display-type (device-class)
+ "A symbol indicating the display Emacs is running under.
+The symbol should be one of `color', `grayscale' or `mono'. If Emacs
+guesses this display attribute wrongly, either set this variable in
+your `~/.emacs' or set the resource `Emacs.displayType' in your
+`~/.Xdefaults'. See also `gnus-background-mode'.
+
+This is a meta-variable that will affect what default values other
+variables get. You would normally not change this variable, but
+pounce directly on the real variables themselves.")
+
+
+ (or (fboundp 'x-color-values)
+ (fset 'x-color-values
+ (lambda (color)
+ (color-instance-rgb-components
+ (make-color-instance color)))))
+
+ (defvar gnus-background-mode
+ (let ((bg-resource
+ (condition-case ()
+ (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
+ (error nil)))
+ (params (frame-parameters)))
+ (cond (bg-resource (intern (downcase bg-resource)))
+ ((and (assq 'background-color params)
+ (< (apply '+ (x-color-values
+ (cdr (assq 'background-color params))))
+ (/ (apply '+ (x-color-values "white")) 3)))
+ 'dark)
+ (t 'light)))
+ "A symbol indicating the Emacs background brightness.
+The symbol should be one of `light' or `dark'.
+If Emacs guesses this frame attribute wrongly, either set this variable in
+your `~/.emacs' or set the resource `Emacs.backgroundMode' in your
+`~/.Xdefaults'.
+See also `gnus-display-type'.
+
+This is a meta-variable that will affect what default values other
+variables get. You would normally not change this variable, but
+pounce directly on the real variables themselves.")
+
+
+ (defun gnus-install-mouse-tracker ()
+ (require 'mode-motion)
+ (setq mode-motion-hook 'mode-motion-highlight-line)))
+
+ ((and (not (string-match "28.9" emacs-version))
+ (not (string-match "29" emacs-version)))
+ ;; 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)))
+ (and props (setcdr props (cdr (cdr (cdr props))))))
+ (or (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
+ (or (fboundp (car funcs))
+ (fset (car funcs) 'gnus-dummy-func))
+ (setq funcs (cdr funcs))))))
+ (or (fboundp 'file-regular-p)
+ (defun file-regular-p (file)
+ (and (not (file-directory-p file))
+ (not (file-symlink-p file))
+ (file-exists-p file))))
+ (or (fboundp 'face-list)
+ (defun face-list (&rest args)))
+ )
+
+(defun gnus-highlight-selected-summary-xemacs ()
+ ;; Highlight selected article in summary buffer
+ (if gnus-summary-selected-face
+ (progn
+ (if gnus-newsgroup-selected-overlay
+ (delete-extent gnus-newsgroup-selected-overlay))
+ (setq gnus-newsgroup-selected-overlay
+ (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
+ (set-extent-face gnus-newsgroup-selected-overlay
+ gnus-summary-selected-face))))
+
+(defun gnus-summary-recenter-xemacs ()
+ (let* ((top (cond ((< (window-height) 4) 0)
+ ((< (window-height) 7) 1)
+ (t 2)))
+ (height (- (window-height) 2))
+ (bottom (save-excursion (goto-char (point-max))
+ (forward-line (- height))
+ (point)))
+ (window (get-buffer-window (current-buffer))))
+ (and
+ ;; The user has to want it,
+ gnus-auto-center-summary
+ ;; the article buffer must be displayed,
+ (get-buffer-window gnus-article-buffer)
+ ;; 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
+ window (min bottom (save-excursion (forward-line (- top))
+ (point)))))))
+
+(defun gnus-group-insert-group-line-info-xemacs (group)
+ (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
+ (beg (point))
+ active info)
+ (if entry
+ (progn
+ (setq info (nth 2 entry))
+ (gnus-group-insert-group-line
+ nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
+ (setq active (gnus-gethash group gnus-active-hashtb))
+
+ (gnus-group-insert-group-line
+ nil group (if (member group gnus-zombie-list) gnus-level-zombie
+ gnus-level-killed)
+ nil (if active (- (1+ (cdr active)) (car active)) 0) nil))
+ (save-excursion
+ (goto-char beg)
+ (remove-text-properties
+ (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
+ '(gnus-group nil)))))
+
+(defun gnus-summary-refer-article-xemacs (message-id)
+ "Refer article specified by MESSAGE-ID.
+NOTE: This command only works with newsgroups that use real or simulated NNTP."
+ (interactive "sMessage-ID: ")
+ (if (or (not (stringp message-id))
+ (zerop (length message-id)))
+ ()
+ ;; Construct the correct Message-ID if necessary.
+ ;; Suggested by tale@pawl.rpi.edu.
+ (or (string-match "^<" message-id)
+ (setq message-id (concat "<" message-id)))
+ (or (string-match ">$" message-id)
+ (setq message-id (concat message-id ">")))
+ (let ((header (car (gnus-gethash (downcase message-id)
+ gnus-newsgroup-dependencies))))
+ (if header
+ (or (gnus-summary-goto-article (mail-header-number header))
+ ;; The header has been read, but the article had been
+ ;; expunged, so we insert it again.
+ (let ((beg (point)))
+ (gnus-summary-insert-line
+ nil header 0 nil gnus-read-mark nil nil
+ (mail-header-subject header))
+ (save-excursion
+ (goto-char beg)
+ (remove-text-properties
+ (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
+ '(gnus-number nil gnus-mark nil gnus-level nil)))
+ (forward-line -1)
+ (mail-header-number header)))
+ (let ((gnus-override-method gnus-refer-article-method)
+ (gnus-ancient-mark gnus-read-mark)
+ (tmp-point (window-start
+ (get-buffer-window gnus-article-buffer)))
+ number tmp-buf)
+ (and gnus-refer-article-method
+ (gnus-check-server gnus-refer-article-method))
+ ;; Save the old article buffer.
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (gnus-kill-buffer " *temp Article*")
+ (setq tmp-buf (rename-buffer " *temp Article*")))
+ (prog1
+ (if (gnus-article-prepare
+ message-id nil (gnus-read-header message-id))
+ (progn
+ (setq number (mail-header-number gnus-current-headers))
+ (gnus-rebuild-thread message-id)
+ (gnus-summary-goto-subject number)
+ (gnus-summary-recenter)
+ (gnus-article-set-window-start
+ (cdr (assq number gnus-newsgroup-bookmarks)))
+ message-id)
+ ;; We restore the old article buffer.
+ (save-excursion
+ (kill-buffer gnus-article-buffer)
+ (set-buffer tmp-buf)
+ (rename-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (and tmp-point
+ (set-window-start (get-buffer-window (current-buffer))
+ tmp-point)))))))))))
+
+(defun gnus-summary-insert-pseudos-xemacs (pslist &optional not-view)
+ (let ((buffer-read-only nil)
+ (article (gnus-summary-article-number))
+ b)
+ (or (gnus-summary-goto-subject article)
+ (error (format "No such article: %d" article)))
+ (or gnus-newsgroup-headers-hashtb-by-number
+ (gnus-make-headers-hashtable-by-number))
+ (gnus-summary-position-cursor)
+ ;; If all commands are to be bunched up on one line, we collect
+ ;; them here.
+ (if gnus-view-pseudos-separately
+ ()
+ (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
+ files action)
+ (while ps
+ (setq action (cdr (assq 'action (car ps))))
+ (setq files (list (cdr (assq 'name (car ps)))))
+ (while (and ps (cdr ps)
+ (string= (or action "1")
+ (or (cdr (assq 'action (car (cdr ps)))) "2")))
+ (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
+ (setcdr ps (cdr (cdr ps))))
+ (if (not files)
+ ()
+ (if (not (string-match "%s" action))
+ (setq files (cons " " files)))
+ (setq files (cons " " files))
+ (and (assq 'execute (car ps))
+ (setcdr (assq 'execute (car ps))
+ (funcall (if (string-match "%s" action)
+ 'format 'concat)
+ action
+ (mapconcat (lambda (f) f) files " ")))))
+ (setq ps (cdr ps)))))
+ (if (and gnus-view-pseudos (not not-view))
+ (while pslist
+ (and (assq 'execute (car pslist))
+ (gnus-execute-command (cdr (assq 'execute (car pslist)))
+ (eq gnus-view-pseudos 'not-confirm)))
+ (setq pslist (cdr pslist)))
+ (save-excursion
+ (while pslist
+ (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
+ (gnus-summary-article-number)))
+ (forward-line 1)
+ (setq b (point))
+ (insert " "
+ (file-name-nondirectory (cdr (assq 'name (car pslist))))
+ ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
+ (add-text-properties
+ b (1+ b) (list 'gnus-number gnus-reffed-article-number
+ 'gnus-mark gnus-unread-mark
+ 'gnus-level 0
+ 'gnus-pseudo (car pslist)))
+ ;; Fucking XEmacs redisplay bug with truncated lines.
+ (goto-char b)
+ (sit-for 0)
+ ;; Grumble.. Fucking XEmacs stickyness of text properties.
+ (remove-text-properties
+ (1+ b) (1+ (gnus-point-at-eol))
+ '(gnus-number nil gnus-mark nil gnus-level nil))
+ (forward-line -1)
+ (gnus-sethash (int-to-string gnus-reffed-article-number)
+ (car pslist) gnus-newsgroup-headers-hashtb-by-number)
+ (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
+ (setq pslist (cdr pslist)))))))
+
+
+(defun gnus-copy-article-buffer-xemacs (&optional article-buffer)
+ (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
+ (buffer-disable-undo gnus-article-copy)
+ (or (memq gnus-article-copy gnus-buffer-list)
+ (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
+ (let ((article-buffer (or article-buffer gnus-article-buffer))
+ buf)
+ (if (and (get-buffer article-buffer)
+ (buffer-name (get-buffer article-buffer)))
+ (save-excursion
+ (set-buffer article-buffer)
+ (widen)
+ (setq buf (buffer-substring (point-min) (point-max)))
+ (set-buffer gnus-article-copy)
+ (erase-buffer)
+ (insert (format "%s" buf))))))
+
+(defun gnus-article-push-button-xemacs (event)
+ "Check text under the mouse pointer for a callback function.
+If the text under the mouse pointer has a `gnus-callback' property,
+call it with the value of the `gnus-data' text property."
+ (interactive "e")
+ (set-buffer (window-buffer (event-window event)))
+ (let* ((pos (event-closest-point event))
+ (data (get-text-property pos 'gnus-data))
+ (fun (get-text-property pos 'gnus-callback)))
+ (if fun (funcall fun data))))
+
+;; Re-build the thread containing ID.
+(defun gnus-rebuild-thread-xemacs (id)
+ (let ((dep gnus-newsgroup-dependencies)
+ (buffer-read-only nil)
+ parent headers refs thread art)
+ (while (and id (setq headers
+ (car (setq art (gnus-gethash (downcase id)
+ dep)))))
+ (setq parent art)
+ (setq id (and (setq refs (mail-header-references headers))
+ (string-match "\\(<[^>]+>\\) *$" refs)
+ (substring refs (match-beginning 1) (match-end 1)))))
+ (setq thread (gnus-make-sub-thread (car parent)))
+ (gnus-rebuild-remove-articles thread)
+ (let ((beg (point)))
+ (gnus-summary-prepare-threads (list thread) 0)
+ (save-excursion
+ (while (and (>= (point) beg)
+ (not (bobp)))
+ (or (eobp)
+ (remove-text-properties
+ (1+ (gnus-point-at-bol)) (1+ (gnus-point-at-eol))
+ '(gnus-number nil gnus-mark nil gnus-level nil)))
+ (forward-line -1)))
+ (gnus-summary-update-lines beg (point)))))
+
+
+;; Fixed by Christopher Davis <ckd@loiosh.kei.com>.
+(defun gnus-article-add-button-xemacs (from to fun &optional data)
+ "Create a button between FROM and TO with callback FUN and data DATA."
+ (and gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay from to) 'face gnus-article-button-face))
+ (add-text-properties from to
+ (append
+ (and gnus-article-mouse-face
+ (list 'mouse-face gnus-article-mouse-face))
+ (list 'gnus-callback fun)
+ (and data (list 'gnus-data data))
+ (list 'highlight t))))
+
+(defun gnus-window-top-edge-xemacs (&optional window)
+ (nth 1 (window-pixel-edges window)))
+
+;; Select the lowest window on the frame.
+(defun gnus-appt-select-lowest-window-xemacs ()
+ (let* ((lowest-window (selected-window))
+ (bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
+ (last-window (previous-window))
+ (window-search t))
+ (while window-search
+ (let* ((this-window (next-window))
+ (next-bottom-edge (car (cdr (cdr (cdr
+ (window-pixel-edges
+ this-window)))))))
+ (if (< bottom-edge next-bottom-edge)
+ (progn
+ (setq bottom-edge next-bottom-edge)
+ (setq lowest-window this-window)))
+
+ (select-window this-window)
+ (if (eq last-window this-window)
+ (progn
+ (select-window lowest-window)
+ (setq window-search nil)))))))
+
+(defun gnus-ems-redefine ()
+ (cond
+ ((string-match "XEmacs\\|Lucid" emacs-version)
+ ;; XEmacs definitions.
+ (fset 'gnus-mouse-face-function 'identity)
+ (fset 'gnus-summary-make-display-table (lambda () nil))
+ (fset 'gnus-visual-turn-off-edit-menu 'identity)
+ (fset 'gnus-highlight-selected-summary
+ 'gnus-highlight-selected-summary-xemacs)
+ (fset 'gnus-summary-recenter 'gnus-summary-recenter-xemacs)
+ (fset 'gnus-group-insert-group-line-info
+ 'gnus-group-insert-group-line-info-xemacs)
+ (fset 'gnus-copy-article-buffer 'gnus-copy-article-buffer-xemacs)
+ (fset 'gnus-summary-refer-article 'gnus-summary-refer-article-xemacs)
+ (fset 'gnus-summary-insert-pseudos 'gnus-summary-insert-pseudos-xemacs)
+ (fset 'gnus-article-push-button 'gnus-article-push-button-xemacs)
+ (fset 'gnus-rebuild-thread 'gnus-rebuild-thread-xemacs)
+ (fset 'gnus-article-add-button 'gnus-article-add-button-xemacs)
+ (fset 'gnus-window-top-edge 'gnus-window-top-edge-xemacs)
+ (fset 'set-text-properties 'gnus-set-text-properties-xemacs)
+
+ (or (fboundp 'appt-select-lowest-window)
+ (fset 'appt-select-lowest-window
+ 'gnus-appt-select-lowest-window-xemacs))
+
+ (if (not gnus-visual)
+ ()
+ (setq gnus-group-mode-hook
+ (cons
+ '(lambda ()
+ (easy-menu-add gnus-group-reading-menu)
+ (easy-menu-add gnus-group-group-menu)
+ (easy-menu-add gnus-group-misc-menu)
+ (gnus-install-mouse-tracker))
+ gnus-group-mode-hook))
+ (setq gnus-summary-mode-hook
+ (cons
+ '(lambda ()
+ (easy-menu-add gnus-summary-article-menu)
+ (easy-menu-add gnus-summary-thread-menu)
+ (easy-menu-add gnus-summary-misc-menu)
+ (easy-menu-add gnus-summary-post-menu)
+ (easy-menu-add gnus-summary-kill-menu)
+ (gnus-install-mouse-tracker))
+ gnus-summary-mode-hook))
+ (setq gnus-article-mode-hook
+ (cons
+ '(lambda ()
+ (easy-menu-add gnus-article-article-menu)
+ (easy-menu-add gnus-article-treatment-menu))
+ gnus-article-mode-hook)))
+
+ (defvar gnus-logo (make-glyph (make-specifier 'image)))
+
+ (defun gnus-group-startup-xmessage (&optional x y)
+ "Insert startup message in current buffer."
+ ;; Insert the message.
+ (erase-buffer)
+ (if (featurep 'xpm)
+ (progn
+ (set-glyph-property gnus-logo 'image "~/tmp/gnus.xpm")
+ (set-glyph-image gnus-logo "~/tmp/gnus.xpm" 'global 'x)
+
+ (insert " ")
+ (set-extent-begin-glyph (make-extent (point) (point)) gnus-logo)
+ (insert "
+ Gnus * A newsreader for Emacsen
+ A Praxis Release * larsi@ifi.uio.no")
+ (goto-char (point-min))
+ (while (not (eobp))
+ (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
+ ? ))
+ (forward-line 1))
+ (goto-char (point-min))
+ ;; +4 is fuzzy factor.
+ (insert-char ?\n (/ (max (- (window-height) (or y 24)) 0) 2)))
+
+ (insert
+ (format "
+ %s
+ A newsreader
+ for GNU Emacs
+
+ Based on GNUS
+ written by
+ Masanobu UMEDA
+
+ A Praxis Release
+ larsi@ifi.uio.no
+"
+ gnus-version))
+ ;; And then hack it.
+ ;; 18 is the longest line.
+ (indent-rigidly (point-min) (point-max)
+ (/ (max (- (window-width) (or x 28)) 0) 2))
+ (goto-char (point-min))
+ ;; +4 is fuzzy factor.
+ (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2)))
+
+ ;; Fontify some.
+ (goto-char (point-min))
+ (search-forward "Praxis")
+ (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
+ (goto-char (point-min)))
+
+
+
+ )
+
+ ((boundp 'MULE)
+ ;; Mule definitions
+ (if (not (fboundp 'truncate-string))
+ (defun truncate-string (str width)
+ (let ((w (string-width str))
+ (col 0) (idx 0) (p-idx 0) chr)
+ (if (<= w width)
+ str
+ (while (< col width)
+ (setq chr (aref str idx)
+ col (+ col (char-width chr))
+ p-idx idx
+ idx (+ idx (char-bytes chr))
+ ))
+ (substring str 0 (if (= col width)
+ idx
+ p-idx))
+ )))
+ )
+ (defalias 'gnus-truncate-string 'truncate-string)
+
+ (defun gnus-cite-add-face (number prefix face)
+ ;; At line NUMBER, ignore PREFIX and add FACE to the rest of the line.
+ (if 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))
+ (if (< from to)
+ (gnus-overlay-put (gnus-make-overlay from to) 'face face)))))
+
+ (defun gnus-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))))
+
+ (fset 'gnus-summary-make-display-table (lambda () nil))
+
+ (if (boundp 'gnus-check-before-posting)
+ (setq gnus-check-before-posting
+ (delq 'long-lines
+ (delq 'control-chars gnus-check-before-posting)))
+ )
+ )
+ ))
+
+(provide 'gnus-ems)
+
+;; Local Variables:
+;; byte-compile-warnings: '(redefine callargs)
+;; End:
+
+;;; gnus-ems.el ends here
diff --git a/lisp/gnus-kill.el b/lisp/gnus-kill.el
new file mode 100644
index 00000000000..781651acdd1
--- /dev/null
+++ b/lisp/gnus-kill.el
@@ -0,0 +1,633 @@
+;;; gnus-kill.el --- kill commands for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+
+(defvar gnus-kill-file-mode-hook nil
+ "*A hook for Gnus kill file mode.")
+
+(defvar gnus-kill-expiry-days 7
+ "*Number of days before expiring unused kill file entries.")
+
+(defvar gnus-kill-save-kill-file nil
+ "*If non-nil, will save kill files after processing them.")
+
+(defvar gnus-winconf-kill-file nil)
+
+
+
+(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)
+
+(if gnus-kill-file-mode-map
+ nil
+ (setq gnus-kill-file-mode-map (copy-keymap emacs-lisp-mode-map))
+ (define-key gnus-kill-file-mode-map
+ "\C-c\C-k\C-s" 'gnus-kill-file-kill-by-subject)
+ (define-key gnus-kill-file-mode-map
+ "\C-c\C-k\C-a" 'gnus-kill-file-kill-by-author)
+ (define-key gnus-kill-file-mode-map
+ "\C-c\C-k\C-t" 'gnus-kill-file-kill-by-thread)
+ (define-key gnus-kill-file-mode-map
+ "\C-c\C-k\C-x" 'gnus-kill-file-kill-by-xref)
+ (define-key gnus-kill-file-mode-map
+ "\C-c\C-a" 'gnus-kill-file-apply-buffer)
+ (define-key gnus-kill-file-mode-map
+ "\C-c\C-e" 'gnus-kill-file-apply-last-sexp)
+ (define-key gnus-kill-file-mode-map
+ "\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)
+ ;; Enter kill file entry.
+ ;; FIELD: String containing the name of the header field to kill.
+ ;; REGEXP: The string to kill.
+ (save-excursion
+ (let (string)
+ (or (eq major-mode 'gnus-kill-file-mode)
+ (gnus-kill-set-kill-buffer))
+ (current-buffer)
+ (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)))
+ "")))
+
+(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))
+ "")))
+
+(defun gnus-kill-file-kill-by-thread ()
+ "Kill by author."
+ (interactive "p")
+ (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))
+ (if (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) ":"))))
+ (gnus-kill-file-enter-kill "Xref" ""))))
+
+(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))
+ (message "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) (message "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) (message "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.
+ (and (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.
+ (and 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
+ (or gnus-kill-files-directory "~/News")))
+ (gnus-use-long-file-name
+ ;; Append ".KILL" to capitalized newsgroup name.
+ (expand-file-name (concat (gnus-capitalize-newsgroup newsgroup)
+ "." gnus-kill-file-name)
+ (or gnus-kill-files-directory "~/News")))
+ (t
+ ;; Place "KILL" under the hierarchical directory.
+ (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
+ "/" gnus-kill-file-name)
+ (or gnus-kill-files-directory "~/News")))))
+
+(defun gnus-expunge (marks)
+ "Remove lines marked with MARKS."
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-remove-lines-marked-with marks)))
+
+(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)
+ (or gnus-newsgroup-headers-hashtb-by-number
+ (gnus-make-headers-hashtable-by-number))
+ ;; 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
+ (or (gnus-member-of-range
+ (mail-header-number (car headers))
+ gnus-newsgroup-killed)
+ (setq gnus-newsgroup-kill-headers
+ (cons (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)))
+ ()
+ (message "Processing kill file %s..." (car kill-files))
+ (find-file (car kill-files))
+ (gnus-add-current-to-buffer-list)
+ (goto-char (point-min))
+
+ (if (consp (condition-case nil (read (current-buffer))
+ (error nil)))
+ (gnus-kill-parse-gnus-kill-file)
+ (gnus-kill-parse-rn-kill-file))
+
+ (message "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)
+ (message "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" (car (car 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 (condition-case () (read (current-buffer))
+ (error nil))))
+ (or (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)
+ (condition-case () (eval form) (error nil)))))
+ (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.
+ (and (string-match "\\+" commands)
+ (progn
+ (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)))
+ (if (> (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)))
+ (if (> (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)
+ (if (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))
+ (if (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 (cdr (car (cdr (nth 2 object))))))))
+ (concat "\n" (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 (car (cdr (nth 2 object))))
+ (first t))
+ (while klist
+ (insert (if first (progn (setq first nil) "") "\n ")
+ (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)))))
+ "'" "")
+ (prin1-to-string (nth 3 object))))
+ (and (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.
+ (or (stringp value)
+ (setq value (prin1-to-string value)))
+ (setq did-kill (string-match regexp value)))
+ (if (stringp form) ;Keyboard macro.
+ (execute-kbd-macro form)
+ (funcall 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.
+ (message "Searching for article: %d..." (mail-header-number header))
+ (gnus-article-setup-buffer)
+ (gnus-article-prepare (mail-header-number header) t)
+ (if (save-excursion
+ (set-buffer gnus-article-buffer)
+ (goto-char (point-min))
+ (setq did-kill (re-search-forward regexp nil t)))
+ (if (stringp form) ;Keyboard macro.
+ (execute-kbd-macro form)
+ (eval form))))))
+ did-kill)))
+
+(defun gnus-execute (field regexp form &optional backward ignore-marked)
+ "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 IGNORE-MARKED is non-nil, articles which are
+marked as read or ticked are ignored."
+ (save-excursion
+ (let ((killed-no 0)
+ function article header)
+ (if (or (null field) (string-equal field ""))
+ (setq function nil)
+ ;; Get access function of header filed.
+ (setq function (intern-soft (concat "gnus-header-" (downcase field))))
+ (if (and function (fboundp function))
+ (setq function (symbol-function function))
+ (error "Unknown header field: \"%s\"" field))
+ ;; Make FORM funcallable.
+ (if (and (listp form) (not (eq (car form) 'lambda)))
+ (setq form (list 'lambda nil form))))
+ ;; Starting from the current article.
+ (while (or (and (not article)
+ (setq article (gnus-summary-article-number))
+ t)
+ (setq article
+ (gnus-summary-search-subject
+ backward (not ignore-marked))))
+ (and (or (null gnus-newsgroup-kill-headers)
+ (memq article gnus-newsgroup-kill-headers))
+ (vectorp (setq header (gnus-get-header-by-number article)))
+ (gnus-execute-1 function regexp form header)
+ (setq killed-no (1+ killed-no))))
+ killed-no)))
+
diff --git a/lisp/gnus-mh.el b/lisp/gnus-mh.el
new file mode 100644
index 00000000000..369b6a5fb2e
--- /dev/null
+++ b/lisp/gnus-mh.el
@@ -0,0 +1,226 @@
+;;; gnus-mh.el --- mh-e interface for Gnus
+;; Copyright (C) 1994,95 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, 675 Mass Ave, Cambridge, MA 02139, 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 'mh-e)
+(require 'mh-comp)
+(require 'gnus)
+(require 'gnus-msg)
+
+(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
+ (or folder
+ (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*")))
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (save-restriction
+ (widen)
+ (unwind-protect
+ (call-process-region (point-min) (point-max)
+ (expand-file-name "rcvstore" mh-lib)
+ 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-mail-reply-using-mhe (&optional yank)
+ "Compose reply mail using mh-e.
+Optional argument YANK means yank original article.
+The command \\[mh-yank-cur-msg] yank the original message into current buffer."
+ (let (from cc subject date to reply-to to-userid orig-to
+ references message-id
+ (config (current-window-configuration))
+ buffer)
+ (pop-to-buffer gnus-article-buffer)
+ (setq buffer (current-buffer))
+ (save-excursion
+ (save-restriction
+ (or gnus-user-login-name ; we need this
+ (setq gnus-user-login-name (or (getenv "USER")
+ (getenv "LOGNAME"))))
+
+ (gnus-article-show-all-headers);; so colors are happy
+ ;; lots of junk to avoid mh-send deleting other windows
+ (setq from (or (gnus-fetch-field "from") "")
+ subject (let ((subject (or (gnus-fetch-field "subject")
+ "(None)")))
+ (if (and subject
+ (not (string-match "^[Rr][Ee]:.+$" subject)))
+ (concat "Re: " subject) subject))
+ reply-to (gnus-fetch-field "reply-to")
+ cc (gnus-fetch-field "cc")
+ orig-to (or (gnus-fetch-field "to") "")
+ date (gnus-fetch-field "date")
+ references (gnus-fetch-field "references")
+ message-id (gnus-fetch-field "message-id"))
+ (setq to (or reply-to from))
+ (setq to-userid (mail-strip-quoted-names orig-to))
+ (if (or (string-match "," orig-to)
+ (not (string-match (substring to-userid 0
+ (string-match "@" to-userid))
+ gnus-user-login-name)))
+ (setq cc (concat (if cc (concat cc ", ") "") orig-to)))
+ ;; mh-yank-cur-msg needs to have mh-show-buffer set in the
+ ;; *Article* buffer
+ (setq mh-show-buffer buffer)))
+
+ (mh-find-path)
+ (mh-send-sub (or to "") (or cc "")
+ (or subject "(None)") config);; Erik Selberg 1/23/94
+
+ (let ((draft (current-buffer))
+ (gnus-mail-buffer (current-buffer))
+ mail-buf)
+ (if (not yank)
+ (gnus-configure-windows 'reply 'force)
+ (gnus-configure-windows 'reply-yank 'force))
+ (setq mail-buf gnus-mail-buffer)
+ (pop-to-buffer mail-buf);; always in the display, so won't have window probs
+ (switch-to-buffer draft))
+
+ ;; (mh-send to (or cc "") subject);; shouldn't use according to mhe
+
+ ;; note - current buffer is now draft!
+ (save-excursion
+ (mh-insert-fields
+ "In-reply-to:"
+ (concat
+ (substring from 0 (string-match " *at \\| *@ \\| *(\\| *<" from))
+ "'s message of " date))
+ (nnheader-insert-references references message-id))
+
+ ;; need this for mh-yank-cur-msg
+ (setq mh-sent-from-folder buffer)
+ (setq mh-sent-from-msg 1)
+ (setq mh-show-buffer buffer)
+ (setq mh-previous-window-config config))
+
+ ;; Then, yank original article if requested.
+ (if yank
+ (let ((last (point)))
+ (mh-yank-cur-msg)
+ (goto-char last)))
+
+ (run-hooks 'gnus-mail-hook))
+
+
+;; gnus-mail-forward-using-mhe is contributed by Jun-ichiro Itoh
+;; <itojun@ingram.mt.cs.keio.ac.jp>
+
+(defun gnus-mail-forward-using-mhe (&optional buffer)
+ "Forward the current message to another user using mh-e."
+ ;; First of all, prepare mhe mail buffer.
+ (let* ((to (read-string "To: "))
+ (cc (read-string "Cc: "))
+ (buffer (or buffer gnus-article-buffer))
+ (config (current-window-configuration));; need to add this - erik
+ (subject (gnus-forward-make-subject buffer)))
+ (setq mh-show-buffer buffer)
+ (mh-find-path)
+ (mh-send-sub to (or cc "") (or subject "(None)") config);; Erik Selberg 1/23/94
+ (let ((draft (current-buffer))
+ (gnus-mail-buffer (current-buffer))
+ mail-buf)
+ (gnus-configure-windows 'reply-yank 'force)
+ (setq mail-buf (eval (cdr (assq 'mail gnus-window-to-buffer))))
+ (pop-to-buffer mail-buf);; always in the display, so won't have window probs
+ (switch-to-buffer draft)
+ )
+ (save-excursion
+ (goto-char (point-max))
+ (insert "\n------- Forwarded Message\n\n")
+ (insert-buffer buffer)
+ (goto-char (point-max))
+ (insert "\n------- End of Forwarded Message\n")
+ (setq mh-sent-from-folder buffer)
+ (setq mh-sent-from-msg 1)
+ (setq mh-previous-window-config config)
+ (run-hooks 'gnus-mail-hook)
+ )))
+
+(defun gnus-mail-other-window-using-mhe ()
+ "Compose mail other window using mh-e."
+ (let ((to (read-string "To: "))
+ (cc (read-string "Cc: "))
+ (subject (read-string "Subject: ")))
+ (gnus-article-show-all-headers) ;I don't think this is really needed.
+ (setq mh-show-buffer (current-buffer))
+ (mh-find-path)
+ (mh-send-other-window to cc subject)
+ (setq mh-sent-from-folder (current-buffer))
+ (setq mh-sent-from-msg 1)
+ (run-hooks 'gnus-mail-hook)))
+
+(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)))))
+
+;;; gnus-mh.el ends here
diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el
new file mode 100644
index 00000000000..89d4c3e98d4
--- /dev/null
+++ b/lisp/gnus-msg.el
@@ -0,0 +1,1803 @@
+;;; gnus-msg.el --- mail and post interface for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'sendmail)
+(require 'gnus-ems)
+
+(defvar gnus-organization-file "/usr/lib/news/organization"
+ "*Local news organization file.")
+
+(defvar gnus-prepare-article-hook (list 'gnus-inews-insert-signature)
+ "*A hook called after preparing body, but before preparing header headers.
+The default hook (`gnus-inews-insert-signature') inserts a signature
+file specified by the variable `gnus-signature-file'.")
+
+(defvar gnus-post-prepare-function nil
+ "*Function that is run after a post buffer has been prepared.
+It is called with the name of the newsgroup that is posted to. It
+might be used, for instance, for inserting signatures based on the
+newsgroup name. (In that case, `gnus-signature-file' and
+`mail-signature' should both be set to nil).")
+
+(defvar gnus-post-prepare-hook nil
+ "*Hook that is run after a post buffer has been prepared.
+If you want to insert the signature, you might put
+`gnus-inews-insert-signature' in this hook.")
+
+(defvar gnus-use-followup-to t
+ "*Specifies what to do with Followup-To header.
+If nil, ignore the header. If it is t, use its value, but ignore
+`poster'. If it is the symbol `ask', query the user before posting.
+If it is the symbol `use', always use the value.")
+
+(defvar gnus-followup-to-function nil
+ "*A variable that contains a function that returns a followup address.
+The function will be called in the buffer of the article that is being
+followed up. The buffer will be narrowed to the headers of the
+article. To pick header headers, one might use `mail-fetch-field'. The
+function will be called with the name of the current newsgroup as the
+argument.
+
+Here's an example `gnus-followup-to-function':
+
+(setq gnus-followup-to-function
+ (lambda (group)
+ (cond ((string= group \"mail.list\")
+ (or (mail-fetch-field \"sender\")
+ (mail-fetch-field \"from\")))
+ (t
+ (or (mail-fetch-field \"reply-to\")
+ (mail-fetch-field \"from\"))))))")
+
+(defvar gnus-reply-to-function nil
+ "*A variable that contains a function that returns a reply address.
+See the `gnus-followup-to-function' variable for an explanation of how
+this variable is used.
+
+This function should return a string that will be used to fill in the
+header. This function may also return a list. In that case, every
+list element should be a cons where the first car should be a string
+with the header name, and the cdr should be a string with the header
+value.")
+
+(defvar gnus-author-copy (getenv "AUTHORCOPY")
+ "*Save outgoing articles in this file.
+Initialized from the AUTHORCOPY environment variable.
+
+If this variable begins with the character \"|\", outgoing articles
+will be piped to the named program. It is possible to save an article
+in an MH folder as follows:
+
+\(setq gnus-author-copy \"|/usr/local/lib/mh/rcvstore +Article\")
+
+If the first character is not a pipe, articles are saved using the
+function specified by the `gnus-author-copy-saver' variable.")
+
+(defvar gnus-mail-self-blind nil
+ "*Non-nil means insert a BCC header in all outgoing articles.
+This will result in having a copy of the article mailed to yourself.
+The BCC header is inserted when the post buffer is initialized, so you
+can remove or alter the BCC header to override the default.")
+
+(defvar gnus-author-copy-saver (function rmail-output)
+ "*A function called to save outgoing articles.
+This function will be called with the same of the file to store the
+article in. The default function is `rmail-output' which saves in Unix
+mailbox format.")
+
+(defvar gnus-user-login-name nil
+ "*The login name of the user.
+Got from the function `user-login-name' if undefined.")
+
+(defvar gnus-user-full-name nil
+ "*The full name of the user.
+Got from the NAME environment variable if undefined.")
+
+(defvar gnus-user-from-line nil
+ "*Your full, complete e-mail address.
+Overrides the other Gnus variables if it is non-nil.
+
+Here are two example values of this variable:
+
+ \"Lars Magne Ingebrigtsen <larsi@ifi.uio.no>\"
+
+and
+
+ \"larsi@ifi.uio.no (Lars Magne Ingebrigtsen)\"
+
+The first version is recommended, but the name has to be quoted if it
+contains non-alphanumerical characters.")
+
+(defvar gnus-signature-file "~/.signature"
+ "*Your signature file.
+If the variable is a string that doesn't correspond to a file, the
+string itself is inserted.")
+
+(defvar gnus-signature-function nil
+ "*A function that should return a signature file name.
+The function will be called with the name of the newsgroup being
+posted to.
+If the function returns a string that doesn't correspond to a file, the
+string itself is inserted.
+If the function returns nil, the `gnus-signature-file' variable will
+be used instead.")
+
+(defvar gnus-required-headers
+ '(From Date Newsgroups Subject Message-ID Organization Lines X-Newsreader)
+ "*Headers to be generated or prompted for when posting an article.
+RFC977 and RFC1036 require From, Date, Newsgroups, Subject,
+Message-ID. Organization, Lines and X-Newsreader are optional. If
+you want Gnus not to insert some header, remove it from this list.")
+
+(defvar gnus-deletable-headers '(Message-ID Date)
+ "*Headers to be deleted if they already exists and were generated by Gnus previously.")
+
+(defvar gnus-removable-headers '(NNTP-Posting-Host Bcc Xref)
+ "*Headers to be removed unconditionally before posting.")
+
+(defvar gnus-check-before-posting
+ '(subject-cmsg multiple-headers sendsys message-id from
+ long-lines control-chars size new-text
+ signature)
+ "In non-nil, Gnus will attempt to run some checks on outgoing posts.
+If this variable is t, Gnus will check everything it can. If it is a
+list, then those elements in that list will be checked.")
+
+(defvar gnus-delete-supersedes-headers
+ "^Path:\\|^Date\\|^NNTP-Posting-Host:\\|^Supersedes:"
+ "*Header lines matching this regexp will be deleted before posting.
+It's best to delete old Path and Date headers before posting to avoid
+any confusion.")
+
+(defvar gnus-auto-mail-to-author nil
+ "*If non-nil, mail the authors of articles a copy of your follow-ups.
+If this variable is `ask', the user will be prompted for whether to
+mail a copy. The string given by `gnus-mail-courtesy-message' will be
+inserted at the beginning of the mail copy.
+
+Mail is sent using the function specified by the
+`gnus-mail-send-method' variable.")
+
+;; Added by Ethan Bradford <ethanb@ptolemy.astro.washington.edu>.
+(defvar gnus-mail-courtesy-message
+ "The following message is a courtesy copy of an article\nthat has been posted as well.\n\n"
+ "*This is inserted at the start of a mailed copy of a posted message.
+If this variable is nil, no such courtesy message will be added.")
+
+(defvar gnus-mail-reply-method (function gnus-mail-reply-using-mail)
+ "*Function to compose a reply.
+Three pre-made functions are `gnus-mail-reply-using-mail' (sendmail);
+`gnus-mail-reply-using-mhe' (MH-E); and `gnus-mail-reply-using-vm'.")
+
+(defvar gnus-mail-forward-method (function gnus-mail-forward-using-mail)
+ "*Function to forward the current message to another user.
+Three pre-made functions are `gnus-mail-forward-using-mail' (sendmail);
+`gnus-mail-forward-using-mhe' (MH-E); and `gnus-mail-forward-using-vm'.")
+
+(defvar gnus-mail-other-window-method 'gnus-mail-other-window-using-mail
+ "*Function to compose mail in the other window.
+Three pre-made functions are `gnus-mail-other-window-using-mail'
+(sendmail); `gnus-mail-other-window-using-mhe' (MH-E); and
+`gnus-mail-other-window-using-vm'.")
+
+(defvar gnus-mail-send-method send-mail-function
+ "*Function to mail a message which is also being posted as an article.
+The message must have To or Cc header. The default is copied from
+the variable `send-mail-function'.")
+
+(defvar gnus-inews-article-function 'gnus-inews-article
+ "*Function to post an article.")
+
+(defvar gnus-inews-article-hook (list 'gnus-inews-do-fcc)
+ "*A hook called before finally posting an article.
+The default hook (`gnus-inews-do-fcc') does FCC processing (ie. saves
+the article to a file).")
+
+(defvar gnus-inews-article-header-hook nil
+ "*A hook called after inserting the headers in an article to be posted.
+The hook is called from the *post-news* buffer, narrowed to the
+headers.")
+
+(defvar gnus-mail-hook nil
+ "*A hook called as the last thing after setting up a mail buffer.")
+
+;;; Internal variables.
+
+(defvar gnus-post-news-buffer "*post-news*")
+(defvar gnus-mail-buffer "*mail*")
+(defvar gnus-summary-send-map nil)
+(defvar gnus-article-copy nil)
+(defvar gnus-reply-subject nil)
+
+(eval-and-compile
+ (autoload 'gnus-uu-post-news "gnus-uu" nil t)
+ (autoload 'rmail-output "rmailout"))
+
+
+;;;
+;;; Gnus Posting Functions
+;;;
+
+(define-prefix-command 'gnus-summary-send-map)
+(define-key gnus-summary-mode-map "S" 'gnus-summary-send-map)
+(define-key gnus-summary-send-map "p" 'gnus-summary-post-news)
+(define-key gnus-summary-send-map "f" 'gnus-summary-followup)
+(define-key gnus-summary-send-map "F" 'gnus-summary-followup-with-original)
+(define-key gnus-summary-send-map "b" 'gnus-summary-followup-and-reply)
+(define-key gnus-summary-send-map "B" 'gnus-summary-followup-and-reply-with-original)
+(define-key gnus-summary-send-map "c" 'gnus-summary-cancel-article)
+(define-key gnus-summary-send-map "s" 'gnus-summary-supersede-article)
+(define-key gnus-summary-send-map "r" 'gnus-summary-reply)
+(define-key gnus-summary-send-map "R" 'gnus-summary-reply-with-original)
+(define-key gnus-summary-send-map "m" 'gnus-summary-mail-other-window)
+(define-key gnus-summary-send-map "u" 'gnus-uu-post-news)
+(define-key gnus-summary-send-map "om" 'gnus-summary-mail-forward)
+(define-key gnus-summary-send-map "op" 'gnus-summary-post-forward)
+(define-key gnus-summary-send-map "Om" 'gnus-uu-digest-mail-forward)
+(define-key gnus-summary-send-map "Op" 'gnus-uu-digest-post-forward)
+
+;;; Internal functions.
+
+(defun gnus-number-base36 (num len)
+ (if (if (< len 0) (<= num 0) (= len 0))
+ ""
+ (concat (gnus-number-base36 (/ num 36) (1- len))
+ (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
+ (% num 36))))))
+
+;;; Post news commands of Gnus group mode and summary mode
+
+(defun gnus-group-mail ()
+ "Start composing a mail."
+ (interactive)
+ (funcall gnus-mail-other-window-method))
+
+(defun gnus-group-post-news ()
+ "Post an article."
+ (interactive)
+ (let ((gnus-newsgroup-name nil))
+ (gnus-post-news 'post nil nil gnus-article-buffer)))
+
+(defun gnus-summary-post-news ()
+ "Post an article."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-post-news 'post gnus-newsgroup-name))
+
+(defun gnus-summary-followup (yank &optional yank-articles)
+ "Compose a followup to an article.
+If prefix argument YANK is non-nil, original article is yanked automatically."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (if yank-articles (gnus-summary-goto-subject (car yank-articles)))
+ (save-window-excursion
+ (gnus-summary-select-article))
+ (let ((headers (gnus-get-header-by-number (gnus-summary-article-number)))
+ (gnus-newsgroup-name gnus-newsgroup-name))
+ ;; Check Followup-To: poster.
+ (set-buffer gnus-article-buffer)
+ (if (and gnus-use-followup-to
+ (string-equal "poster" (gnus-fetch-field "followup-to"))
+ (or (not (memq gnus-use-followup-to '(t ask)))
+ (not (gnus-y-or-n-p
+ "Do you want to ignore `Followup-To: poster'? "))))
+ ;; Mail to the poster.
+ (gnus-summary-reply yank)
+ (gnus-post-news nil gnus-newsgroup-name
+ headers gnus-article-buffer
+ (or yank-articles (not (not yank)))))))
+
+(defun gnus-summary-followup-with-original (n)
+ "Compose a followup to an article and include the original article."
+ (interactive "P")
+ (gnus-summary-followup t (gnus-summary-work-articles n)))
+
+;; Suggested by Daniel Quinlan <quinlan@best.com>.
+(defun gnus-summary-followup-and-reply (yank &optional yank-articles)
+ "Compose a followup and do an auto mail to author."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((gnus-auto-mail-to-author t))
+ (gnus-summary-followup yank yank-articles)))
+
+(defun gnus-summary-followup-and-reply-with-original (n)
+ "Compose a followup, include the original, and do an auto mail to author."
+ (interactive "P")
+ (gnus-summary-followup-and-reply t (gnus-summary-work-articles n)))
+
+(defun gnus-summary-cancel-article (n)
+ "Cancel an article you posted."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((articles (gnus-summary-work-articles n)))
+ (while articles
+ (gnus-summary-select-article t nil nil (car articles))
+ (and (gnus-eval-in-buffer-window gnus-article-buffer (gnus-cancel-news))
+ (gnus-summary-mark-as-read (car articles) gnus-canceled-mark))
+ (gnus-summary-remove-process-mark (car articles))
+ (gnus-article-hide-headers-if-wanted)
+ (setq articles (cdr articles)))))
+
+(defun gnus-summary-supersede-article ()
+ "Compose an article that will supersede a previous article.
+This is done simply by taking the old article and adding a Supersedes
+header line with the old Message-ID."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-select-article t)
+ (if (not
+ (string-equal
+ (downcase (mail-strip-quoted-names
+ (mail-header-from gnus-current-headers)))
+ (downcase (mail-strip-quoted-names (gnus-inews-user-name)))))
+ (error "This article is not yours."))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (if (not (re-search-backward "^Message-ID: " nil t))
+ (error "No Message-ID in this article"))))
+ (if (gnus-post-news 'post gnus-newsgroup-name)
+ (progn
+ (erase-buffer)
+ (insert-buffer gnus-article-buffer)
+ (if (search-forward "\n\n" nil t)
+ (forward-char -1)
+ (goto-char (point-max)))
+ (narrow-to-region (point-min) (point))
+ (goto-char (point-min))
+ (and gnus-delete-supersedes-headers
+ (delete-matching-lines gnus-delete-supersedes-headers))
+ (goto-char (point-min))
+ (if (not (re-search-forward "^Message-ID: " nil t))
+ (error "No Message-ID in this article")
+ (replace-match "Supersedes: " t t))
+ (goto-char (point-max))
+ (insert mail-header-separator)
+ (widen)
+ (forward-line 1))))
+
+
+;;;###autoload
+(defalias 'sendnews 'gnus-post-news)
+
+;;;###autoload
+(defalias 'postnews 'gnus-post-news)
+
+(defun gnus-copy-article-buffer (&optional article-buffer)
+ ;; make a copy of the article buffer with all text properties removed
+ ;; this copy is in the buffer gnus-article-copy.
+ ;; if ARTICLE-BUFFER is nil, gnus-article-buffer is used
+ ;; this buffer should be passed to all mail/news reply/post routines.
+ (setq gnus-article-copy (get-buffer-create " *gnus article copy*"))
+ (buffer-disable-undo gnus-article-copy)
+ (or (memq gnus-article-copy gnus-buffer-list)
+ (setq gnus-buffer-list (cons gnus-article-copy gnus-buffer-list)))
+ (let ((article-buffer (or article-buffer gnus-article-buffer)))
+ (if (and (get-buffer article-buffer)
+ (buffer-name (get-buffer article-buffer)))
+ (save-excursion
+ (set-buffer article-buffer)
+ (widen)
+ (copy-to-buffer gnus-article-copy (point-min) (point-max))
+ (set-text-properties (point-min) (point-max)
+ nil gnus-article-copy)))))
+
+(defun gnus-post-news (post &optional group header article-buffer yank subject)
+ "Begin editing a new USENET news article to be posted.
+Type \\[describe-mode] in the buffer to get a list of commands."
+ (interactive (list t))
+ (gnus-copy-article-buffer article-buffer)
+ (if (or (not gnus-novice-user)
+ gnus-expert-user
+ (not (eq 'post
+ (nth 1 (assoc
+ (format "%s" (car (gnus-find-method-for-group
+ gnus-newsgroup-name)))
+ gnus-valid-select-methods))))
+ (and group
+ (assq 'to-address
+ (nth 5 (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))))
+ (gnus-y-or-n-p "Are you sure you want to post to all of USENET? "))
+ (let ((sumart (if (not post)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (cons (current-buffer) gnus-current-article))))
+ (from (and header (mail-header-from header)))
+ (winconf (current-window-configuration))
+ real-group)
+ (and gnus-interactive-post
+ (not gnus-expert-user)
+ post (not group)
+ (progn
+ (setq gnus-newsgroup-name
+ (setq group
+ (completing-read "Group: " gnus-active-hashtb)))
+ (or subject
+ (setq subject (read-string "Subject: ")))))
+ (setq mail-reply-buffer gnus-article-copy)
+
+ (let ((newsgroup-name (or group gnus-newsgroup-name "")))
+ (setq real-group (and group (gnus-group-real-name group)))
+ (setq gnus-post-news-buffer
+ (gnus-request-post-buffer
+ post real-group subject header gnus-article-copy
+ (nth 2 (and group (gnus-gethash group gnus-newsrc-hashtb)))
+ (or (cdr (assq 'to-group
+ (nth 5 (nth 2 (gnus-gethash
+ newsgroup-name
+ gnus-newsrc-hashtb)))))
+ (if (and (boundp 'gnus-followup-to-function)
+ gnus-followup-to-function
+ gnus-article-copy)
+ (save-excursion
+ (set-buffer gnus-article-copy)
+ (funcall gnus-followup-to-function group))))
+ gnus-use-followup-to))
+ (if post
+ (gnus-configure-windows 'post 'force)
+ (if yank
+ (gnus-configure-windows 'followup-yank 'force)
+ (gnus-configure-windows 'followup 'force)))
+ (gnus-overload-functions)
+ (make-local-variable 'gnus-article-reply)
+ (make-local-variable 'gnus-article-check-size)
+ (make-local-variable 'gnus-reply-subject)
+ (setq gnus-reply-subject (and header (mail-header-subject header)))
+ (setq gnus-article-reply sumart)
+ ;; Handle `gnus-auto-mail-to-author'.
+ ;; Suggested by Daniel Quinlan <quinlan@best.com>.
+ ;; Revised to respect Reply-To by Ulrik Dickow <dickow@nbi.dk>.
+ (let ((to (and (not post)
+ (if (if (eq gnus-auto-mail-to-author 'ask)
+ (y-or-n-p "Also send mail to author? ")
+ gnus-auto-mail-to-author)
+ (or (save-excursion
+ (set-buffer gnus-article-copy)
+ (gnus-fetch-field "reply-to"))
+ from)))))
+ (if to
+ (if (mail-fetch-field "To")
+ (progn
+ (beginning-of-line)
+ (insert "Cc: " to "\n"))
+ (mail-position-on-field "To")
+ (insert to))))
+ ;; Handle author copy using BCC field.
+ (if (and gnus-mail-self-blind
+ (not (mail-fetch-field "bcc")))
+ (progn
+ (mail-position-on-field "Bcc")
+ (insert (if (stringp gnus-mail-self-blind)
+ gnus-mail-self-blind
+ (user-login-name)))))
+ ;; Handle author copy using FCC field.
+ (if gnus-author-copy
+ (progn
+ (mail-position-on-field "Fcc")
+ (insert gnus-author-copy)))
+ (goto-char (point-min))
+ (if post
+ (cond ((not group)
+ (re-search-forward "^Newsgroup:" nil t)
+ (end-of-line))
+ ((not subject)
+ (re-search-forward "^Subject:" nil t)
+ (end-of-line))
+ (t
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (if (not yank)
+ ()
+ (save-excursion
+ (if (not (listp yank))
+ (news-reply-yank-original nil)
+ (setq yank (reverse yank))
+ (while yank
+ (save-excursion
+ (save-window-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-select-article nil nil nil (car yank))
+ (gnus-summary-remove-process-mark (car yank)))
+ (let ((mail-reply-buffer gnus-article-copy))
+ (gnus-copy-article-buffer)
+ (let ((news-reply-yank-message-id
+ (save-excursion
+ (set-buffer gnus-article-copy)
+ (mail-fetch-field "message-id")))
+ (news-reply-yank-from
+ (save-excursion
+ (set-buffer gnus-article-copy)
+ (mail-fetch-field "from"))))
+ (news-reply-yank-original nil))
+ (setq yank (cdr yank)))))))))
+ (if gnus-post-prepare-function
+ (funcall gnus-post-prepare-function group))
+ (run-hooks 'gnus-post-prepare-hook)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf))))
+ (setq gnus-article-check-size (cons (buffer-size) (gnus-article-checksum)))
+ (message "")
+ t)
+
+(defun gnus-inews-news (&optional use-group-method)
+ "Send a news message.
+If given a prefix, and the group is a foreign group, this function
+will attempt to use the foreign server to post the article."
+ (interactive "P")
+ (or gnus-current-select-method
+ (setq gnus-current-select-method gnus-select-method))
+ (let* ((case-fold-search nil)
+ (server-running (gnus-server-opened gnus-current-select-method))
+ (reply gnus-article-reply)
+ error post-result)
+ (save-excursion
+ ;; Connect to default NNTP server if necessary.
+ ;; Suggested by yuki@flab.fujitsu.junet.
+ (gnus-start-news-server) ;Use default server.
+ ;; NNTP server must be opened before current buffer is modified.
+ (widen)
+ (goto-char (point-min))
+ (run-hooks 'news-inews-hook)
+ (save-restriction
+ (narrow-to-region
+ (point-min)
+ (progn
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (match-beginning 0)))
+
+ ;; Correct newsgroups field: change sequence of spaces to comma and
+ ;; eliminate spaces around commas. Eliminate imbedded line breaks.
+ (goto-char (point-min))
+ (if (re-search-forward "^Newsgroups: +" nil t)
+ (save-restriction
+ (narrow-to-region
+ (point)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0)
+ (forward-line 1)
+ (point)))
+ (goto-char (point-min))
+ (while (re-search-forward "\n[ \t]+" nil t)
+ (replace-match " " t t)) ;No line breaks (too confusing)
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t\n]*,[ \t\n]*\\|[ \t]+" nil t)
+ (replace-match "," t t))
+ (goto-char (point-min))
+ ;; Remove a trailing comma.
+ (if (re-search-forward ",$" nil t)
+ (replace-match "" t t))))
+
+ ;; Added by Per Abrahamsen <abraham@iesd.auc.dk>.
+ ;; Help save the the world!
+ (or
+ gnus-expert-user
+ (let ((newsgroups (mail-fetch-field "newsgroups"))
+ (followup-to (mail-fetch-field "followup-to"))
+ groups to)
+ (if (and newsgroups
+ (string-match "," newsgroups) (not followup-to))
+ (progn
+ (while (string-match "," newsgroups)
+ (setq groups
+ (cons (list (substring newsgroups
+ 0 (match-beginning 0)))
+ groups))
+ (setq newsgroups (substring newsgroups (match-end 0))))
+ (setq groups (nreverse (cons (list newsgroups) groups)))
+
+ (setq to
+ (completing-read "Followups to: (default all groups) "
+ groups))
+ (if (> (length to) 0)
+ (progn
+ (goto-char (point-min))
+ (insert "Followup-To: " to "\n")))))))
+
+ ;; Cleanup Followup-To.
+ (goto-char (point-min))
+ (if (search-forward-regexp "^Followup-To: +" nil t)
+ (save-restriction
+ (narrow-to-region
+ (point)
+ (if (re-search-forward "^[^ \t]" nil 'end)
+ (match-beginning 0)
+ (point-max)))
+ (goto-char (point-min))
+ (replace-regexp "\n[ \t]+" " ") ;No line breaks (too confusing)
+ (goto-char (point-min))
+ (replace-regexp "[ \t\n]*,[ \t\n]*\\|[ \t]+" ",")))
+
+ ;; Mail the message too if To:, Bcc:. or Cc: exists.
+ (let* ((types '("to" "bcc" "cc"))
+ (ty types)
+ fcc-line)
+ (while ty
+ (or (mail-fetch-field (car ty) nil t)
+ (setq types (delete (car ty) types)))
+ (setq ty (cdr ty)))
+
+ (if (not types)
+ ;; We do not want to send mail.
+ ()
+ (if (not gnus-mail-send-method)
+ (progn
+ (ding)
+ (gnus-message
+ 1 "No mailer defined. To: and/or Cc: fields ignored.")
+ (sit-for 1))
+ (save-excursion
+ ;; We want to remove Fcc, because we want to handle
+ ;; that one ourselves...
+
+ (goto-char (point-min))
+ (if (re-search-forward "^Fcc: " nil t)
+ (progn
+ (setq fcc-line
+ (buffer-substring
+ (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
+ (forward-line -1)
+ (gnus-delete-line)))
+
+ ;; We generate a Message-ID so that the mail and the
+ ;; news copy of the message both get the same ID.
+ (or (mail-fetch-field "message-id")
+ (not (memq 'Message-ID gnus-required-headers))
+ (progn
+ (goto-char (point-max))
+ (insert "Message-ID: " (gnus-inews-message-id) "\n")))
+
+ (save-restriction
+ (widen)
+ (gnus-message 5 "Sending via mail...")
+
+ (if (and gnus-mail-courtesy-message
+ (or (member "to" types)
+ (member "cc" types)))
+ ;; We only want to insert the courtesy mail
+ ;; message if we use to or cc; bcc should not
+ ;; have one. Well, if both bcc and to are
+ ;; present, it will get one anyway.
+ (progn
+ ;; Insert "courtesy" mail message.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote
+ mail-header-separator) "$"))
+ (forward-line 1)
+ (insert gnus-mail-courtesy-message)
+ (funcall gnus-mail-send-method)
+ (goto-char (point-min))
+ (search-forward gnus-mail-courtesy-message)
+ (replace-match "" t t))
+ (funcall gnus-mail-send-method))
+
+ (gnus-message 5 "Sending via mail...done")
+
+ (goto-char (point-min))
+ (narrow-to-region
+ (point)
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$")))
+ (goto-char (point-min))
+ (while (re-search-forward "^BCC:" nil t)
+ (delete-region (match-beginning 0)
+ ;; There might be continuation headers.
+ (if (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0)
+ ;; Uhm... or something like this.
+ (forward-line 1)
+ (point)))))
+ (if fcc-line
+ (progn
+ (goto-char (point-max))
+ (insert fcc-line))))))))
+
+ ;; Send to server.
+ (gnus-message 5 "Posting to USENET...")
+ (setq post-result (funcall gnus-inews-article-function use-group-method))
+ (cond ((eq post-result 'illegal)
+ (setq error t)
+ (ding))
+ (post-result
+ (gnus-message 5 "Posting to USENET...done")
+ (if (gnus-buffer-exists-p (car-safe reply))
+ (progn
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-mark-article-as-replied
+ (cdr reply)))))
+ (set-buffer-modified-p nil))
+ (t
+ ;; We cannot signal an error.
+ (setq error t)
+ (ding)
+ (gnus-message 1 "Article rejected: %s"
+ (gnus-status-message gnus-select-method)))))
+ ;; If NNTP server is opened by gnus-inews-news, close it by myself.
+ (or server-running
+ (gnus-close-server (gnus-find-method-for-group gnus-newsgroup-name)))
+ (let ((conf gnus-prev-winconf))
+ (if (not error)
+ (progn
+ (bury-buffer)
+ ;; Restore last window configuration.
+ (and conf (set-window-configuration conf)))))))
+
+(defun gnus-inews-check-post ()
+ "Check whether the post looks ok."
+ (or
+ (not gnus-check-before-posting)
+ (and
+ ;; We narrow to the headers and check them first.
+ (save-excursion
+ (save-restriction
+ (goto-char (point-min))
+ (narrow-to-region
+ (point)
+ (progn
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (match-beginning 0)))
+ (goto-char (point-min))
+ (and
+ ;; Check for commands in Subject.
+ (or
+ (gnus-check-before-posting 'subject-cmsg)
+ (save-excursion
+ (if (string-match "^cmsg " (mail-fetch-field "subject"))
+ (gnus-y-or-n-p
+ "The control code \"cmsg \" is in the subject. Really post? ")
+ t)))
+ ;; Check for multiple identical headers.
+ (or (gnus-check-before-posting 'multiple-headers)
+ (save-excursion
+ (let (found)
+ (while (and (not found) (re-search-forward "^[^ \t:]+: "
+ nil t))
+ (save-excursion
+ (or (re-search-forward
+ (concat "^" (setq found
+ (buffer-substring
+ (match-beginning 0)
+ (- (match-end 0) 2))))
+ nil t)
+ (setq found nil))))
+ (if found
+ (gnus-y-or-n-p
+ (format "Multiple %s headers. Really post? " found))
+ t))))
+ ;; Check for version and sendsys.
+ (or (gnus-check-before-posting 'sendsys)
+ (save-excursion
+ (if (re-search-forward "^Sendsys:\\|^Version:" nil t)
+ (gnus-y-or-n-p
+ (format "The article contains a %s command. Really post? "
+ (buffer-substring (match-beginning 0)
+ (1- (match-end 0)))))
+ t)))
+ ;; Check the Message-Id header.
+ (or (gnus-check-before-posting 'message-id)
+ (save-excursion
+ (let* ((case-fold-search t)
+ (message-id (mail-fetch-field "message-id")))
+ (or (not message-id)
+ (and (string-match "@" message-id)
+ (string-match "@[^\\.]*\\." message-id))
+ (gnus-y-or-n-p
+ (format
+ "The Message-ID looks strange: \"%s\". Really post? "
+ message-id))))))
+ ;; Check the From header.
+ (or (gnus-check-before-posting 'from)
+ (save-excursion
+ (let* ((case-fold-search t)
+ (from (mail-fetch-field "from")))
+ (cond
+ ((not from)
+ (gnus-y-or-n-p "There is no From line. Really post? "))
+ ((not (string-match "@[^\\.]*\\." from))
+ (gnus-y-or-n-p
+ (format
+ "The address looks strange: \"%s\". Really post? " from)))
+ ((string-match "(.*).*(.*)" from)
+ (gnus-y-or-n-p
+ (format
+ "The From header looks strange: \"%s\". Really post? "
+ from)))
+ (t t)))))
+ )))
+ ;; Check for long lines.
+ (or (gnus-check-before-posting 'long-lines)
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (while (and
+ (progn
+ (end-of-line)
+ (< (current-column) 80))
+ (zerop (forward-line 1))))
+ (or (bolp)
+ (eobp)
+ (gnus-y-or-n-p
+ (format
+ "You have lines longer than 79 characters. Really post? ")))))
+ ;; Check for control characters.
+ (or (gnus-check-before-posting 'control-chars)
+ (save-excursion
+ (if (re-search-forward "[\000-\007\013\015-\037\200-\237]" nil t)
+ (gnus-y-or-n-p
+ "The article contains control characters. Really post? ")
+ t)))
+ ;; Check excessive size.
+ (or (gnus-check-before-posting 'size)
+ (if (> (buffer-size) 60000)
+ (gnus-y-or-n-p
+ (format "The article is %d octets long. Really post? "
+ (buffer-size)))
+ t))
+ ;; Use the (size . checksum) variable to see whether the
+ ;; article is empty or has only quoted text.
+ (or
+ (gnus-check-before-posting 'new-text)
+ (if (and (= (buffer-size) (car gnus-article-check-size))
+ (= (gnus-article-checksum) (cdr gnus-article-check-size)))
+ (gnus-y-or-n-p
+ "It looks like there's no new text in your article. Really post? ")
+ t))
+ ;; Check the length of the signature.
+ (or (gnus-check-before-posting 'signature)
+ (progn
+ (goto-char (point-max))
+ (if (not (re-search-backward gnus-signature-separator nil t))
+ t
+ (if (> (count-lines (point) (point-max)) 5)
+ (gnus-y-or-n-p
+ (format
+ "Your .sig is %d lines; it should be max 4. Really post? "
+ (count-lines (point) (point-max))))
+ t)))))))
+
+(defun gnus-article-checksum ()
+ (let ((sum 0))
+ (save-excursion
+ (while (not (eobp))
+ (setq sum (logxor sum (following-char)))
+ (forward-char 1)))
+ sum))
+
+;; Returns non-nil if this type is not to be checked.
+(defun gnus-check-before-posting (type)
+ (not
+ (or (not gnus-check-before-posting)
+ (if (listp gnus-check-before-posting)
+ (memq type gnus-check-before-posting)
+ t))))
+
+(defun gnus-cancel-news ()
+ "Cancel an article you posted."
+ (interactive)
+ (if (or gnus-expert-user
+ (gnus-yes-or-no-p "Do you really want to cancel this article? "))
+ (let ((from nil)
+ (newsgroups nil)
+ (message-id nil)
+ (distribution nil))
+ (or (gnus-member-of-valid 'post gnus-newsgroup-name)
+ (error "This backend does not support canceling"))
+ (save-excursion
+ ;; Get header info. from original article.
+ (save-restriction
+ (gnus-article-show-all-headers)
+ (goto-char (point-min))
+ (search-forward "\n\n" nil 'move)
+ (narrow-to-region (point-min) (point))
+ (setq from (mail-fetch-field "from"))
+ (setq newsgroups (mail-fetch-field "newsgroups"))
+ (setq message-id (mail-fetch-field "message-id"))
+ (setq distribution (mail-fetch-field "distribution")))
+ ;; Verify if the article is absolutely user's by comparing
+ ;; user id with value of its From: field.
+ (if (not
+ (string-equal
+ (downcase (mail-strip-quoted-names from))
+ (downcase (mail-strip-quoted-names (gnus-inews-user-name)))))
+ (progn
+ (ding) (gnus-message 3 "This article is not yours.")
+ nil)
+ ;; Make control article.
+ (set-buffer (get-buffer-create " *Gnus-canceling*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert "Newsgroups: " newsgroups "\n"
+ "Subject: cancel " message-id "\n"
+ "Control: cancel " message-id "\n"
+ (if distribution
+ (concat "Distribution: " distribution "\n")
+ "")
+ mail-header-separator "\n"
+ "This is a cancel message from " from ".\n")
+ ;; Send the control article to NNTP server.
+ (gnus-message 5 "Canceling your article...")
+ (prog1
+ (if (funcall gnus-inews-article-function)
+ (gnus-message 5 "Canceling your article...done")
+ (progn
+ (ding)
+ (gnus-message 1 "Cancel failed; %s"
+ (gnus-status-message gnus-newsgroup-name))
+ nil)
+ t)
+ ;; Kill the article buffer.
+ (kill-buffer (current-buffer))))))))
+
+
+;;; Lowlevel inews interface
+
+(defun gnus-inews-article (&optional use-group-method)
+ "Post an article in current buffer using NNTP protocol."
+ (let ((artbuf (current-buffer))
+ (tmpbuf (get-buffer-create " *Gnus-posting*")))
+ (widen)
+ (goto-char (point-max))
+ ;; require a newline at the end for inews to append .signature to
+ (or (= (preceding-char) ?\n)
+ (insert ?\n))
+ ;; Prepare article headers. All message body such as signature
+ ;; must be inserted before Lines: field is prepared.
+ (save-restriction
+ (goto-char (point-min))
+ (narrow-to-region
+ (point-min)
+ (save-excursion
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (match-beginning 0)))
+ (gnus-inews-remove-headers)
+ (gnus-inews-insert-headers)
+ (run-hooks 'gnus-inews-article-header-hook)
+ (widen))
+ ;; Check whether the article is a good Net Citizen.
+ (if (and gnus-article-check-size
+ (not (gnus-inews-check-post)))
+ ;; Aber nein!
+ 'illegal
+ ;; Looks ok, so we do the nasty.
+ (save-excursion
+ (set-buffer tmpbuf)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-buffer-substring artbuf)
+ ;; Remove the header separator.
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (replace-match "" t t)
+ ;; This hook may insert a signature.
+ (save-excursion
+ (goto-char (point-min))
+ (let ((gnus-newsgroup-name (or (mail-fetch-field "newsgroups")
+ gnus-newsgroup-name)))
+ (run-hooks 'gnus-prepare-article-hook)))
+ ;; Run final inews hooks. This hook may do FCC.
+ ;; The article must be saved before being posted because
+ ;; `gnus-request-post' modifies the buffer.
+ (run-hooks 'gnus-inews-article-hook)
+ ;; Post an article to NNTP server.
+ ;; Return NIL if post failed.
+ (prog1
+ (gnus-request-post
+ (if use-group-method
+ (gnus-find-method-for-group gnus-newsgroup-name)
+ gnus-select-method) use-group-method)
+ (kill-buffer (current-buffer)))))))
+
+(defun gnus-inews-remove-headers ()
+ (let ((case-fold-search t)
+ (headers gnus-removable-headers))
+ ;; Remove toxic headers.
+ (while headers
+ (goto-char (point-min))
+ (and (re-search-forward
+ (concat "^" (downcase (format "%s" (car headers))))
+ nil t)
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
+ (setq headers (cdr headers)))))
+
+(defun gnus-inews-insert-headers ()
+ "Prepare article headers.
+Headers already prepared in the buffer are not modified.
+Headers in `gnus-required-headers' will be generated."
+ (let ((Date (gnus-inews-date))
+ (Message-ID (gnus-inews-message-id))
+ (Organization (gnus-inews-organization))
+ (From (gnus-inews-user-name))
+ (Path (gnus-inews-path))
+ (Subject nil)
+ (Newsgroups nil)
+ (Distribution nil)
+ (Lines (gnus-inews-lines))
+ (X-Newsreader gnus-version)
+ (headers gnus-required-headers)
+ (case-fold-search t)
+ header value elem)
+ ;; First we remove any old generated headers.
+ (let ((headers gnus-deletable-headers))
+ (while headers
+ (goto-char (point-min))
+ (and (re-search-forward
+ (concat "^" (symbol-name (car headers)) ": *") nil t)
+ (get-text-property (1+ (match-beginning 0)) 'gnus-deletable)
+ (gnus-delete-line))
+ (setq headers (cdr headers))))
+ ;; If there are References, and no "Re: ", then the thread has
+ ;; changed name. See Son-of-1036.
+ (if (and (mail-fetch-field "references")
+ (get-buffer gnus-article-buffer))
+ (let ((psubject (gnus-simplify-subject-re
+ (mail-fetch-field "subject"))))
+ (or (and psubject gnus-reply-subject
+ (string= (gnus-simplify-subject-re gnus-reply-subject)
+ psubject))
+ (progn
+ (string-match "@" Message-ID)
+ (setq Message-ID
+ (concat (substring Message-ID 0 (match-beginning 0))
+ "_-_"
+ (substring Message-ID (match-beginning 0))))))))
+ ;; Go through all the required headers and see if they are in the
+ ;; articles already. If they are not, or are empty, they are
+ ;; inserted automatically - except for Subject, Newsgroups and
+ ;; Distribution.
+ (while headers
+ (goto-char (point-min))
+ (setq elem (car headers))
+ (if (consp elem)
+ (setq header (car elem))
+ (setq header elem))
+ (if (or (not (re-search-forward
+ (concat "^" (downcase (symbol-name header)) ":") nil t))
+ (progn
+ ;; The header was found. We insert a space after the
+ ;; colon, if there is none.
+ (if (/= (following-char) ? ) (insert " "))
+ ;; Find out whether the header is empty...
+ (looking-at "[ \t]*$")))
+ ;; So we find out what value we should insert.
+ (progn
+ (setq value
+ (or (if (consp elem)
+ ;; The element is a cons. Either the cdr is
+ ;; a string to be inserted verbatim, or it
+ ;; is a function, and we insert the value
+ ;; returned from this function.
+ (or (and (stringp (cdr elem)) (cdr elem))
+ (and (fboundp (cdr elem)) (funcall (cdr elem))))
+ ;; The element is a symbol. We insert the
+ ;; value of this symbol, if any.
+ (and (boundp header) (symbol-value header)))
+ ;; We couldn't generate a value for this header,
+ ;; so we just ask the user.
+ (read-from-minibuffer
+ (format "Empty header for %s; enter value: " header))))
+ ;; Finally insert the header.
+ (save-excursion
+ (if (bolp)
+ (progn
+ (goto-char (point-max))
+ (insert (symbol-name header) ": " value "\n")
+ (forward-line -1))
+ (replace-match value t t))
+ ;; Add the deletable property to the headers that require it.
+ (and (memq header gnus-deletable-headers)
+ (progn (beginning-of-line) (looking-at "[^:]+: "))
+ (add-text-properties
+ (point) (match-end 0)
+ '(gnus-deletable t face italic) (current-buffer))))))
+ (setq headers (cdr headers)))
+ ;; Insert new Sender if the From is strange.
+ (let ((from (mail-fetch-field "from"))
+ (sender (mail-fetch-field "sender")))
+ (if (and from
+ (not (string=
+ (downcase (car (gnus-extract-address-components from)))
+ (downcase (gnus-inews-real-user-address))))
+ (or (null sender)
+ (not
+ (string=
+ (downcase (car (gnus-extract-address-components sender)))
+ (downcase (gnus-inews-real-user-address))))))
+ (progn
+ (goto-char (point-min))
+ (and (re-search-forward "^Sender:" nil t)
+ (progn
+ (beginning-of-line)
+ (insert "Original-")
+ (beginning-of-line)))
+ (insert "Sender: " (gnus-inews-real-user-address) "\n"))))))
+
+
+(defun gnus-inews-insert-signature ()
+ "Insert a signature file.
+If `gnus-signature-function' is bound and returns a string, this
+string is used instead of the variable `gnus-signature-file'.
+In either case, if the string is a file name, this file is
+inserted. If the string is not a file name, the string itself is
+inserted.
+
+If you never want any signature inserted, set both of these variables to
+nil."
+ (save-excursion
+ (let ((signature
+ (or (and gnus-signature-function
+ (funcall gnus-signature-function gnus-newsgroup-name))
+ gnus-signature-file)))
+ (if (and signature
+ (or (file-exists-p signature)
+ (string-match " " signature)
+ (not (string-match
+ "^/[^/]+/" (expand-file-name signature)))))
+ (progn
+ (goto-char (point-max))
+ (if (and mail-signature (search-backward "\n-- \n" nil t))
+ ()
+ ;; Delete any previous signatures.
+ (if (search-backward "\n-- \n" nil t)
+ (delete-region (point) (point-max)))
+ (or (eolp) (insert "\n"))
+ (insert "-- \n")
+ (if (file-exists-p signature)
+ (insert-file-contents signature)
+ (insert signature))
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))))))))
+
+;; Written by "Mr. Per Persson" <pp@solace.mh.se>.
+(defun gnus-inews-insert-mime-headers ()
+ (let ((mail-header-separator ""))
+ (or (mail-position-on-field "Mime-Version")
+ (insert "1.0")
+ (cond ((save-excursion
+ (beginning-of-buffer)
+ (re-search-forward "[\200-\377]" nil t))
+ (or (mail-position-on-field "Content-Type")
+ (insert "text/plain; charset=ISO-8859-1"))
+ (or (mail-position-on-field "Content-Transfer-Encoding")
+ (insert "8bit")))
+ (t (or (mail-position-on-field "Content-Type")
+ (insert "text/plain; charset=US-ASCII"))
+ (or (mail-position-on-field "Content-Transfer-Encoding")
+ (insert "7bit")))))))
+
+(defun gnus-inews-do-fcc ()
+ "Process FCC: fields in current article buffer.
+Unless the first character of the field is `|', the article is saved
+to the specified file using the function specified by the variable
+gnus-author-copy-saver. The default function rmail-output saves in
+Unix mailbox format.
+If the first character is `|', the contents of the article is send to
+a program specified by the rest of the value."
+ (let ((fcc-list nil)
+ (fcc-file nil)
+ (case-fold-search t)) ;Should ignore case.
+ (save-excursion
+ (save-restriction
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (narrow-to-region (point-min) (point))
+ (goto-char (point-min))
+ (while (re-search-forward "^FCC:[ \t]*" nil t)
+ (setq fcc-list
+ (cons (buffer-substring
+ (point)
+ (progn
+ (end-of-line)
+ (skip-chars-backward " \t")
+ (point)))
+ fcc-list))
+ (delete-region (match-beginning 0)
+ (progn (forward-line 1) (point))))
+ ;; Process FCC operations.
+ (widen)
+ (while fcc-list
+ (setq fcc-file (car fcc-list))
+ (setq fcc-list (cdr fcc-list))
+ (cond ((string-match "^[ \t]*|[ \t]*\\(.*\\)[ \t]*$" fcc-file)
+ (let ((program (substring fcc-file
+ (match-beginning 1) (match-end 1))))
+ ;; Suggested by yuki@flab.fujitsu.junet.
+ ;; Send article to named program.
+ (call-process-region (point-min) (point-max) shell-file-name
+ nil nil nil "-c" program)))
+ (t
+ ;; Suggested by hyoko@flab.fujitsu.junet.
+ ;; Save article in Unix mail format by default.
+ (gnus-make-directory (file-name-directory fcc-file))
+ (if (and gnus-author-copy-saver
+ (not (eq gnus-author-copy-saver 'rmail-output)))
+ (funcall gnus-author-copy-saver fcc-file)
+ (if (and (file-readable-p fcc-file)
+ (mail-file-babyl-p fcc-file))
+ (gnus-output-to-rmail fcc-file)
+ (rmail-output fcc-file 1 t t))))))))))
+
+(defun gnus-inews-path ()
+ "Return uucp path."
+ (let ((login-name (gnus-inews-login-name)))
+ (cond ((null gnus-use-generic-path)
+ (concat (nth 1 gnus-select-method) "!" login-name))
+ ((stringp gnus-use-generic-path)
+ ;; Support GENERICPATH. Suggested by vixie@decwrl.dec.com.
+ (concat gnus-use-generic-path "!" login-name))
+ (t login-name))))
+
+(defun gnus-inews-user-name ()
+ "Return user's network address as \"NAME@DOMAIN (FULL-NAME)\"."
+ (let ((full-name (gnus-inews-full-name))
+ (address (if (or gnus-user-login-name gnus-use-generic-from
+ gnus-local-domain (getenv "DOMAINNAME"))
+ (concat (gnus-inews-login-name) "@"
+ (gnus-inews-domain-name gnus-use-generic-from))
+ user-mail-address)))
+ (or gnus-user-from-line
+ (concat address
+ ;; User's full name.
+ (cond ((string-equal full-name "&") ;Unix hack.
+ (concat " (" (user-login-name) ")"))
+ ((string-match "[^ ]+@[^ ]+ +(.*)" address)
+ "")
+ (t
+ (concat " (" full-name ")")))))))
+
+(defun gnus-inews-real-user-address ()
+ "Return the \"real\" user address.
+This function tries to ignore all user modifications, and
+give as trustworthy answer as possible."
+ (concat (user-login-name) "@" (gnus-inews-full-address)))
+
+(defun gnus-inews-login-name ()
+ "Return login name."
+ (or gnus-user-login-name (getenv "LOGNAME") (user-login-name)))
+
+(defun gnus-inews-full-name ()
+ "Return full user name."
+ (or gnus-user-full-name (getenv "NAME") (user-full-name)))
+
+(defun gnus-inews-domain-name (&optional genericfrom)
+ "Return user's domain name.
+If optional argument GENERICFROM is a string, use it as the domain
+name; if it is non-nil, strip off local host name from the domain name.
+If the function `system-name' returns full internet name and the
+domain is undefined, the domain name is got from it."
+ (if (or genericfrom gnus-local-domain (getenv "DOMAINNAME"))
+ (let* ((system-name (system-name))
+ (domain
+ (or (if (stringp genericfrom) genericfrom)
+ (getenv "DOMAINNAME")
+ gnus-local-domain
+ ;; Function `system-name' may return full internet name.
+ ;; Suggested by Mike DeCorte <mrd@sun.soe.clarkson.edu>.
+ (if (string-match "\\." system-name)
+ (substring system-name (match-end 0)))
+ (read-string "Domain name (no host): ")))
+ (host (or (if (string-match "\\." system-name)
+ (substring system-name 0 (match-beginning 0)))
+ system-name)))
+ (if (string-equal "." (substring domain 0 1))
+ (setq domain (substring domain 1)))
+ ;; Support GENERICFROM as same as standard Bnews system.
+ ;; Suggested by ohm@kaba.junet and vixie@decwrl.dec.com.
+ (cond ((null genericfrom)
+ (concat host "." domain))
+ ;;((stringp genericfrom) genericfrom)
+ (t domain)))
+ (if (string-match "\\." (system-name))
+ (system-name)
+ (substring user-mail-address
+ (1+ (string-match "@" user-mail-address))))))
+
+(defun gnus-inews-full-address ()
+ (let ((domain (gnus-inews-domain-name))
+ (system (system-name))
+ (case-fold-search t))
+ (if (string-match "\\." system) system
+ (if (string-match (concat "^" (regexp-quote system)) domain) domain
+ (concat system "." domain)))))
+
+(defun gnus-inews-message-id ()
+ "Generate unique Message-ID for user."
+ ;; Message-ID should not contain a slash and should be terminated by
+ ;; a number. I don't know the reason why it is so.
+ (concat "<" (gnus-inews-unique-id) "@" (gnus-inews-full-address) ">"))
+
+(defvar gnus-unique-id-char nil)
+
+;; If you ever change this function, make sure the new version
+;; cannot generate IDs that the old version could.
+;; You might for example insert a "." somewhere (not next to another dot
+;; or string boundary), or modify the newsreader name to "Ding".
+(defun gnus-inews-unique-id ()
+ ;; Dont use microseconds from (current-time), they may be unsupported.
+ ;; Instead we use this randomly inited counter.
+ (setq gnus-unique-id-char
+ (% (1+ (or gnus-unique-id-char (logand (random t) (1- (lsh 1 20)))))
+ ;; (current-time) returns 16-bit ints,
+ ;; and 2^16*25 just fits into 4 digits i base 36.
+ (* 25 25)))
+ (let ((tm (if (fboundp 'current-time)
+ (current-time) '(12191 46742 287898))))
+ (concat
+ (if (memq system-type '(ms-dos emx vax-vms))
+ (let ((user (downcase (gnus-inews-login-name))))
+ (while (string-match "[^a-z0-9_]" user)
+ (aset user (match-beginning 0) ?_))
+ user)
+ (gnus-number-base36 (user-uid) -1))
+ (gnus-number-base36 (+ (car tm) (lsh (% gnus-unique-id-char 25) 16)) 4)
+ (gnus-number-base36 (+ (nth 1 tm) (lsh (/ gnus-unique-id-char 25) 16)) 4)
+ ;; Append the newsreader name, because while the generated
+ ;; ID is unique to this newsreader, other newsreaders might
+ ;; otherwise generate the same ID via another algorithm.
+ ".fsf")))
+
+
+(defun gnus-inews-date ()
+ "Current time string."
+ (timezone-make-date-arpa-standard
+ (current-time-string) (current-time-zone)))
+
+(defun gnus-inews-organization ()
+ "Return user's organization.
+The ORGANIZATION environment variable is used if defined.
+If not, the variable `gnus-local-organization' is used instead.
+If it is a function, the function will be called with the current
+newsgroup name as the argument.
+If this is a file name, the contents of this file will be used as the
+organization."
+ (let* ((organization
+ (or (getenv "ORGANIZATION")
+ (if gnus-local-organization
+ (if (and (symbolp gnus-local-organization)
+ (fboundp gnus-local-organization))
+ (funcall gnus-local-organization gnus-newsgroup-name)
+ gnus-local-organization))
+ gnus-organization-file
+ "~/.organization")))
+ (and (stringp organization)
+ (> (length organization) 0)
+ (or (file-exists-p organization)
+ (string-match " " organization)
+ (not (string-match "^/usr/lib/" organization)))
+ (save-excursion
+ (gnus-set-work-buffer)
+ (if (file-exists-p organization)
+ (insert-file-contents organization)
+ (insert organization))
+ (goto-char (point-min))
+ (while (re-search-forward " *\n *" nil t)
+ (replace-match " " t t))
+ (buffer-substring (point-min) (point-max))))))
+
+(defun gnus-inews-lines ()
+ "Count the number of lines and return numeric string."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (int-to-string (count-lines (point) (point-max))))))
+
+
+;;;
+;;; Gnus Mail Functions
+;;;
+
+;;; Mail reply commands of Gnus summary mode
+
+(defun gnus-summary-reply (yank &optional yank-articles)
+ "Reply mail to news author.
+If prefix argument YANK is non-nil, original article is yanked automatically.
+Customize the variable gnus-mail-reply-method to use another mailer."
+ (interactive "P")
+ ;; Bug fix by jbw@bigbird.bu.edu (Joe Wells)
+ ;; Stripping headers should be specified with mail-yank-ignored-headers.
+ (gnus-set-global-variables)
+ (if yank-articles (gnus-summary-goto-subject (car yank-articles)))
+ (gnus-summary-select-article)
+ (let ((gnus-newsgroup-name gnus-newsgroup-name))
+ (bury-buffer gnus-article-buffer)
+ (funcall gnus-mail-reply-method (or yank-articles (not (not yank))))))
+
+(defun gnus-summary-reply-with-original (n)
+ "Reply mail to news author with original article.
+Customize the variable gnus-mail-reply-method to use another mailer."
+ (interactive "P")
+ (gnus-summary-reply t (gnus-summary-work-articles n)))
+
+(defun gnus-summary-mail-forward (post)
+ "Forward the current message to another user.
+Customize the variable gnus-mail-forward-method to use another mailer."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-select-article)
+ (gnus-copy-article-buffer)
+ (let ((gnus-newsgroup-name gnus-newsgroup-name))
+ (if post
+ (gnus-forward-using-post gnus-article-copy)
+ (funcall gnus-mail-forward-method gnus-article-copy))))
+
+(defun gnus-summary-post-forward ()
+ "Forward the current article to a newsgroup."
+ (interactive)
+ (gnus-summary-mail-forward t))
+
+(defvar gnus-nastygram-message
+ "The following article was inappropriately posted to %s.\n"
+ "Format string to insert in nastygrams.
+The current group name will be inserted at \"%s\".")
+
+(defun gnus-summary-mail-nastygram (n)
+ "Send a nastygram to the author of the current article."
+ (interactive "P")
+ (if (or gnus-expert-user
+ (gnus-y-or-n-p
+ "Really send a nastygram to the author of the current article? "))
+ (let ((group gnus-newsgroup-name))
+ (gnus-summary-reply-with-original n)
+ (set-buffer gnus-mail-buffer)
+ (insert (format gnus-nastygram-message group))
+ (gnus-mail-send-and-exit))))
+
+(defun gnus-summary-mail-other-window ()
+ "Compose mail in other window.
+Customize the variable `gnus-mail-other-window-method' to use another
+mailer."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((gnus-newsgroup-name gnus-newsgroup-name))
+ (funcall gnus-mail-other-window-method)))
+
+(defun gnus-mail-reply-using-mail (&optional yank to-address)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (let ((group (gnus-group-real-name gnus-newsgroup-name))
+ (cur (cons (current-buffer) (cdr gnus-article-current)))
+ (winconf (current-window-configuration))
+ from subject date reply-to message-of
+ references message-id sender follow-to sendto elt)
+ (set-buffer (get-buffer-create gnus-mail-buffer))
+ (mail-mode)
+ (make-local-variable 'gnus-article-reply)
+ (setq gnus-article-reply cur)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf)
+ (if (and (buffer-modified-p)
+ (> (buffer-size) 0)
+ (not (gnus-y-or-n-p
+ "Unsent article being composed; erase it? ")))
+ ()
+ (erase-buffer)
+ (save-excursion
+ (gnus-copy-article-buffer)
+ (save-restriction
+ (set-buffer gnus-article-copy)
+ (gnus-narrow-to-headers)
+ (if (and (boundp 'gnus-reply-to-function)
+ gnus-reply-to-function)
+ (setq follow-to (funcall gnus-reply-to-function group)))
+ (setq from (mail-fetch-field "from"))
+ (setq date (or (mail-fetch-field "date")
+ (mail-header-date gnus-current-headers)))
+ (and from
+ (let ((stop-pos
+ (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (setq message-of
+ (concat (if stop-pos (substring from 0 stop-pos) from)
+ "'s message of " date))))
+ (setq sender (mail-fetch-field "sender"))
+ (setq subject (or (mail-fetch-field "subject")
+ "Re: none"))
+ (or (string-match "^[Rr][Ee]:" subject)
+ (setq subject (concat "Re: " subject)))
+ (setq reply-to (mail-fetch-field "reply-to"))
+ (setq references (mail-fetch-field "references"))
+ (setq message-id (mail-fetch-field "message-id"))
+ (widen))
+ (setq news-reply-yank-from (or from "(nobody)")))
+ (setq news-reply-yank-message-id
+ (or message-id "(unknown Message-ID)"))
+
+ ;; Gather the "to" addresses out of the follow-to list and remove
+ ;; them as we go.
+ (if (and follow-to (listp follow-to))
+ (while (setq elt (assoc "To" follow-to))
+ (setq sendto (concat sendto (and sendto ", ") (cdr elt)))
+ (setq follow-to (delq elt follow-to))))
+
+ (mail-setup (or to-address
+ (if (and follow-to (not (stringp follow-to))) sendto
+ (or follow-to reply-to from sender "")))
+ subject message-of nil gnus-article-copy nil)
+
+ (auto-save-mode auto-save-default)
+ (use-local-map (copy-keymap mail-mode-map))
+ (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
+
+ (if (and follow-to (listp follow-to))
+ (progn
+ (goto-char (point-min))
+ (re-search-forward "^To:" nil t)
+ (beginning-of-line)
+ (forward-line 1)
+ (while follow-to
+ (insert (car (car follow-to)) ": " (cdr (car follow-to)) "\n")
+ (setq follow-to (cdr follow-to)))))
+ (nnheader-insert-references references message-id)
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (if (not yank)
+ (gnus-configure-windows 'reply 'force)
+ (let ((last (point))
+ end)
+ (if (not (listp yank))
+ (progn
+ (save-excursion
+ (mail-yank-original nil))
+ (or mail-yank-hooks mail-citation-hook
+ (run-hooks 'news-reply-header-hook)))
+ (while yank
+ (save-window-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-select-article nil nil nil (car yank))
+ (gnus-summary-remove-process-mark (car yank)))
+ (save-excursion
+ (gnus-copy-article-buffer)
+ (mail-yank-original nil)
+ (setq end (point)))
+ (or mail-yank-hooks mail-citation-hook
+ (run-hooks 'news-reply-header-hook))
+ (goto-char end)
+ (setq yank (cdr yank))))
+ (goto-char last))
+ (gnus-configure-windows 'reply-yank 'force))
+ (run-hooks 'gnus-mail-hook)))))
+
+(defun gnus-mail-yank-original ()
+ (interactive)
+ (save-excursion
+ (mail-yank-original nil))
+ (or mail-yank-hooks mail-citation-hook
+ (run-hooks 'news-reply-header-hook)))
+
+(defun gnus-mail-send-and-exit ()
+ (interactive)
+ (let ((reply gnus-article-reply)
+ (winconf gnus-prev-winconf))
+ (mail-send-and-exit nil)
+ (if (get-buffer gnus-group-buffer)
+ (progn
+ (if (gnus-buffer-exists-p (car-safe reply))
+ (progn
+ (set-buffer (car reply))
+ (and (cdr reply)
+ (gnus-summary-mark-article-as-replied
+ (cdr reply)))))
+ (and winconf (set-window-configuration winconf))))))
+
+(defun gnus-forward-make-subject (buffer)
+ (save-excursion
+ (set-buffer buffer)
+ (concat "[" (if (memq 'mail (assoc (symbol-name
+ (car (gnus-find-method-for-group
+ gnus-newsgroup-name)))
+ gnus-valid-select-methods))
+ (gnus-fetch-field "From")
+ gnus-newsgroup-name)
+ "] " (or (gnus-fetch-field "Subject") ""))))
+
+(defun gnus-forward-insert-buffer (buffer)
+ (let ((beg (goto-char (point-max))))
+ (insert "------- Start of forwarded message -------\n")
+ (insert-buffer buffer)
+ (goto-char (point-max))
+ (insert "------- End of forwarded message -------\n")
+ ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
+ (goto-char beg)
+ (while (setq beg (next-single-property-change (point) 'invisible))
+ (goto-char beg)
+ (delete-region beg (or (next-single-property-change
+ (point) 'invisible)
+ (point-max))))))
+
+(defun gnus-mail-forward-using-mail (&optional buffer)
+ "Forward the current message to another user using mail."
+ ;; This is almost a carbon copy of rmail-forward in rmail.el.
+ (let* ((forward-buffer (or buffer (current-buffer)))
+ (winconf (current-window-configuration))
+ (subject (gnus-forward-make-subject forward-buffer)))
+ (set-buffer forward-buffer)
+ (mail nil nil subject)
+ (use-local-map (copy-keymap (current-local-map)))
+ (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf)
+ (gnus-forward-insert-buffer forward-buffer)
+ (goto-char (point-min))
+ (re-search-forward "^To: " nil t)
+ (gnus-configure-windows 'mail-forward 'force)
+ ;; You have a chance to arrange the message.
+ (run-hooks 'gnus-mail-forward-hook)
+ (run-hooks 'gnus-mail-hook)))
+
+(defun gnus-forward-using-post (&optional buffer)
+ (save-excursion
+ (let* ((forward-buffer (or buffer (current-buffer)))
+ (subject (gnus-forward-make-subject forward-buffer))
+ (gnus-newsgroup-name nil))
+ (gnus-post-news 'post nil nil nil nil subject)
+ (save-excursion
+ (gnus-forward-insert-buffer forward-buffer)
+ ;; You have a chance to arrange the message.
+ (run-hooks 'gnus-mail-forward-hook)))))
+
+(defun gnus-mail-other-window-using-mail ()
+ "Compose mail other window using mail."
+ (let ((winconf (current-window-configuration)))
+ (mail-other-window nil nil nil nil nil (get-buffer gnus-article-buffer))
+ (use-local-map (copy-keymap (current-local-map)))
+ (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf)
+ (run-hooks 'gnus-mail-hook)
+ (gnus-configure-windows 'summary-mail 'force)))
+
+(defun gnus-article-mail (yank)
+ "Send a reply to the address near point.
+If YANK is non-nil, include the original article."
+ (interactive "P")
+ (let ((address
+ (buffer-substring
+ (save-excursion (re-search-backward "[ \t\n]" nil t) (1+ (point)))
+ (save-excursion (re-search-forward "[ \t\n]" nil t) (1- (point))))))
+ (and address
+ (progn
+ (switch-to-buffer gnus-summary-buffer)
+ (funcall gnus-mail-reply-method yank address)))))
+
+(defun gnus-bug ()
+ "Send a bug report to the Gnus maintainers."
+ (interactive)
+ (let ((winconf (current-window-configuration)))
+ (delete-other-windows)
+ (switch-to-buffer "*Gnus Help Bug*")
+ (erase-buffer)
+ (insert gnus-bug-message)
+ (goto-char (point-min))
+ (pop-to-buffer "*Gnus Bug*")
+ (erase-buffer)
+ (mail-mode)
+ (mail-setup gnus-maintainer nil nil nil nil nil)
+ (auto-save-mode auto-save-default)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf)
+ (use-local-map (copy-keymap mail-mode-map))
+ (local-set-key "\C-c\C-c" 'gnus-bug-mail-send-and-exit)
+ (goto-char (point-min))
+ (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line 1)
+ (insert (format "%s\n%s\n\n\n\n\n" (gnus-version) (emacs-version)))
+ (gnus-debug)
+ (goto-char (point-min))
+ (search-forward "Subject: " nil t)
+ (message "")))
+
+(defun gnus-bug-mail-send-and-exit ()
+ "Send the bug message and exit."
+ (interactive)
+ (and (get-buffer "*Gnus Help Bug*")
+ (kill-buffer "*Gnus Help Bug*"))
+ (gnus-mail-send-and-exit))
+
+(defun gnus-debug ()
+ "Attemps to go through the Gnus source file and report what variables have been changed.
+The source file has to be in the Emacs load path."
+ (interactive)
+ (let ((files '("gnus.el" "gnus-msg.el" "gnus-score.el"))
+ file dirs expr olist sym)
+ (message "Please wait while we snoop your variables...")
+ (sit-for 0)
+ (save-excursion
+ (set-buffer (get-buffer-create " *gnus bug info*"))
+ (buffer-disable-undo (current-buffer))
+ (while files
+ (erase-buffer)
+ (setq dirs load-path)
+ (while dirs
+ (if (or (not (car dirs))
+ (not (stringp (car dirs)))
+ (not (file-exists-p
+ (setq file (concat (file-name-as-directory
+ (car dirs)) (car files))))))
+ (setq dirs (cdr dirs))
+ (setq dirs nil)
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (or (re-search-forward "^;;* *Internal variables" nil t)
+ (error "Malformed sources in file %s" file))
+ (narrow-to-region (point-min) (point))
+ (goto-char (point-min))
+ (while (setq expr (condition-case ()
+ (read (current-buffer)) (error nil)))
+ (condition-case ()
+ (and (eq (car expr) 'defvar)
+ (stringp (nth 3 expr))
+ (or (not (boundp (nth 1 expr)))
+ (not (equal (eval (nth 2 expr))
+ (symbol-value (nth 1 expr)))))
+ (setq olist (cons (nth 1 expr) olist)))
+ (error nil)))))
+ (setq files (cdr files)))
+ (kill-buffer (current-buffer)))
+ (insert "------------------- Environment follows -------------------\n\n")
+ (while olist
+ (if (boundp (car olist))
+ (insert "(setq " (symbol-name (car olist))
+ (if (or (consp (setq sym (symbol-value (car olist))))
+ (and (symbolp sym)
+ (not (or (eq sym nil)
+ (eq sym t)))))
+ " '" " ")
+ (prin1-to-string (symbol-value (car olist))) ")\n")
+ (insert ";; (makeunbound '" (symbol-name (car olist)) ")\n"))
+ (setq olist (cdr olist)))
+ (insert "\n\n")
+ ;; Remove any null chars - they seem to cause trouble for some
+ ;; mailers. (Byte-compiled output from the stuff above.)
+ (goto-char (point-min))
+ (while (re-search-forward "[\000\200]" nil t)
+ (replace-match "" t t))))
+
+(gnus-ems-redefine)
+
+(provide 'gnus-msg)
+
+;;; gnus-msg.el ends here
diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el
new file mode 100644
index 00000000000..db30a7551de
--- /dev/null
+++ b/lisp/gnus-score.el
@@ -0,0 +1,1643 @@
+;;; gnus-score.el --- scoring code for Gnus
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: Per Abrahamsen <amanda@iesd.auc.dk>
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+
+(defvar gnus-score-expiry-days 7
+ "*Number of days before unused score file entries are expired.")
+
+(defvar gnus-orphan-score nil
+ "*All orphans get this score added. Set in the score file.")
+
+(defvar gnus-default-adaptive-score-alist
+ '((gnus-kill-file-mark)
+ (gnus-unread-mark)
+ (gnus-read-mark (from 3) (subject 30))
+ (gnus-catchup-mark (subject -10))
+ (gnus-killed-mark (from -1) (subject -20))
+ (gnus-del-mark (from -2) (subject -15)))
+"*Alist of marks and scores.")
+
+(defvar gnus-score-mimic-keymap nil
+ "*Have the score entry functions pretend that they are a keymap.")
+
+(defvar gnus-score-exact-adapt-limit 10
+ "*Number that says how long a match has to be before using substring matching.
+When doing adaptive scoring, one normally uses fuzzy or substring
+matching. However, if the header one matches is short, the possibility
+for false positives is great, so if the length of the match is less
+than this variable, exact matching will be used.
+
+If this variable is nil, exact matching will always be used.")
+
+
+
+;; Internal variables.
+
+(defvar gnus-score-help-winconf nil)
+(defvar gnus-adaptive-score-alist gnus-default-adaptive-score-alist)
+(defvar gnus-score-trace nil)
+(defvar gnus-score-edit-buffer nil)
+
+(defvar gnus-score-alist nil
+ "Alist containing score information.
+The keys can be symbols or strings. The following symbols are defined.
+
+touched: If this alist has been modified.
+mark: Automatically mark articles below this.
+expunge: Automatically expunge articles below this.
+files: List of other score files to load when loading this one.
+eval: Sexp to be evaluated when the score file is loaded.
+
+String entries have the form (HEADER (MATCH TYPE SCORE DATE) ...)
+where HEADER is the header being scored, MATCH is the string we are
+looking for, TYPE is a flag indicating whether it should use regexp or
+substring matching, SCORE is the score to add and DATE is the date
+of the last successful match.")
+
+(defvar gnus-score-cache nil)
+(defvar gnus-scores-articles nil)
+(defvar gnus-header-index nil)
+(defvar gnus-score-index nil)
+
+(eval-and-compile
+ (autoload 'gnus-uu-ctl-map "gnus-uu" nil nil 'keymap)
+ (autoload 'appt-select-lowest-window "appt.el"))
+
+;;; Summary mode score maps.
+
+(defvar gnus-summary-score-map nil)
+
+(define-prefix-command 'gnus-summary-score-map)
+(define-key gnus-summary-mode-map "V" 'gnus-summary-score-map)
+(define-key gnus-summary-score-map "s" 'gnus-summary-set-score)
+(define-key gnus-summary-score-map "a" 'gnus-summary-score-entry)
+(define-key gnus-summary-score-map "S" 'gnus-summary-current-score)
+(define-key gnus-summary-score-map "c" 'gnus-score-change-score-file)
+(define-key gnus-summary-score-map "m" 'gnus-score-set-mark-below)
+(define-key gnus-summary-score-map "x" 'gnus-score-set-expunge-below)
+(define-key gnus-summary-score-map "e" 'gnus-score-edit-alist)
+(define-key gnus-summary-score-map "f" 'gnus-score-edit-file)
+(define-key gnus-summary-score-map "t" 'gnus-score-find-trace)
+(define-key gnus-summary-score-map "C" 'gnus-score-customize)
+
+
+
+;; Summary score file commands
+
+;; Much modification of the kill (ahem, score) code and lots of the
+;; functions are written by Per Abrahamsen <amanda@iesd.auc.dk>.
+
+(defun gnus-summary-lower-score (&optional score)
+ "Make a score entry based on the current article.
+The user will be prompted for header to score on, match type,
+permanence, and the string to be used. The numerical prefix will be
+used as score."
+ (interactive "P")
+ (gnus-summary-increase-score (- (gnus-score-default score))))
+
+(defun gnus-summary-increase-score (&optional score)
+ "Make a score entry based on the current article.
+The user will be prompted for header to score on, match type,
+permanence, and the string to be used. The numerical prefix will be
+used as score."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let* ((nscore (gnus-score-default score))
+ (prefix (if (< nscore 0) ?L ?I))
+ (increase (> nscore 0))
+ (char-to-header
+ '((?a "from" nil nil string)
+ (?s "subject" nil nil string)
+ (?b "body" "" nil body-string)
+ (?h "head" "" nil body-string)
+ (?i "message-id" nil t string)
+ (?t "references" "message-id" t string)
+ (?x "xref" nil nil string)
+ (?l "lines" nil nil number)
+ (?d "date" nil nil date)
+ (?f "followup" nil nil string)))
+ (char-to-type
+ '((?s s "substring" string)
+ (?e e "exact string" string)
+ (?f f "fuzzy string" string)
+ (?r r "regexp string" string)
+ (?s s "substring" body-string)
+ (?r s "regexp string" body-string)
+ (?b before "before date" date)
+ (?a at "at date" date)
+ (?n now "this date" date)
+ (?< < "less than number" number)
+ (?> > "greater than number" number)
+ (?= = "equal to number" number)))
+ (char-to-perm
+ (list (list ?t (current-time-string) "temporary")
+ '(?p perm "permanent") '(?i now "immediate")))
+ (mimic gnus-score-mimic-keymap)
+ hchar entry temporary tchar pchar end type)
+ ;; First we read the header to score.
+ (while (not hchar)
+ (if mimic
+ (progn
+ (sit-for 1)
+ (message "%c-" prefix))
+ (message "%s header (%s?): " (if increase "Increase" "Lower")
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ char-to-header "")))
+ (setq hchar (read-char))
+ (if (not (or (= hchar ??) (= hchar ?\C-h)))
+ ()
+ (setq hchar nil)
+ (gnus-score-insert-help "Match on header" char-to-header 1)))
+
+ (and (get-buffer "*Score Help*")
+ (progn
+ (kill-buffer "*Score Help*")
+ (and gnus-score-help-winconf
+ (set-window-configuration gnus-score-help-winconf))))
+
+ (or (setq entry (assq (downcase hchar) char-to-header))
+ (progn
+ (ding)
+ (setq end t)
+ (if mimic (message "%c %c" prefix hchar) (message ""))))
+ (if (or end (/= (downcase hchar) hchar))
+ (progn
+ ;; This was a majuscle, so we end reading and set the defaults.
+ (if mimic (message "%c %c" prefix hchar) (message ""))
+ (setq type nil
+ temporary (current-time-string)))
+
+ ;; We continue reading - the type.
+ (while (not tchar)
+ (if mimic
+ (progn
+ (sit-for 1)
+ (message "%c %c-" prefix hchar))
+ (message "%s header '%s' with match type (%s?): "
+ (if increase "Increase" "Lower")
+ (nth 1 entry)
+ (mapconcat (lambda (s)
+ (if (eq (nth 4 entry)
+ (nth 3 s))
+ (char-to-string (car s))
+ ""))
+ char-to-type "")))
+ (setq tchar (read-char))
+ (if (not (or (= tchar ??) (= tchar ?\C-h)))
+ ()
+ (setq tchar nil)
+ (gnus-score-insert-help "Match type" char-to-type 2)))
+
+ (and (get-buffer "*Score Help*")
+ (progn
+ (and gnus-score-help-winconf
+ (set-window-configuration gnus-score-help-winconf))
+ (kill-buffer "*Score Help*")))
+
+ (or (setq type (nth 1 (assq (downcase tchar) char-to-type)))
+ (progn
+ (ding)
+ (if mimic (message "%c %c" prefix hchar) (message ""))
+ (setq end t)))
+ (if (or end (/= (downcase tchar) tchar))
+ (progn
+ ;; It was a majuscle, so we end reading and the the default.
+ (if mimic (message "%c %c %c" prefix hchar tchar)
+ (message ""))
+ (setq temporary (current-time-string)))
+
+ ;; We continue reading.
+ (while (not pchar)
+ (if mimic
+ (progn
+ (sit-for 1)
+ (message "%c %c %c-" prefix hchar tchar))
+ (message "%s permanence (%s?): " (if increase "Increase" "Lower")
+ (mapconcat (lambda (s) (char-to-string (car s)))
+ char-to-perm "")))
+ (setq pchar (read-char))
+ (if (not (or (= pchar ??) (= pchar ?\C-h)))
+ ()
+ (setq pchar nil)
+ (gnus-score-insert-help "Match permanence" char-to-perm 2)))
+
+ (and (get-buffer "*Score Help*")
+ (progn
+ (and gnus-score-help-winconf
+ (set-window-configuration gnus-score-help-winconf))
+ (kill-buffer "*Score Help*")))
+
+ (if mimic (message "%c %c %c" prefix hchar tchar pchar)
+ (message ""))
+ (if (setq temporary (nth 1 (assq pchar char-to-perm)))
+ ()
+ (ding)
+ (setq end t)
+ (if mimic
+ (message "%c %c %c %c" prefix hchar tchar pchar)
+ (message "")))))
+
+ ;; We have all the data, so we enter this score.
+ (if end
+ ()
+ (gnus-summary-score-entry
+ (nth 1 entry) ; Header
+ (if (string= (nth 2 entry) "") ""
+ (gnus-summary-header (or (nth 2 entry) (nth 1 entry)))) ; Match
+ type ; Type
+ (if (eq 's score) nil score) ; Score
+ (if (eq 'perm temporary) ; Temp
+ nil
+ temporary)
+ (not (nth 3 entry))) ; Prompt
+ )))
+
+(defun gnus-score-insert-help (string alist idx)
+ (setq gnus-score-help-winconf (current-window-configuration))
+ (save-excursion
+ (set-buffer (get-buffer-create "*Score Help*"))
+ (buffer-disable-undo (current-buffer))
+ (delete-windows-on (current-buffer))
+ (erase-buffer)
+ (insert string ":\n\n")
+ (let ((max -1)
+ (list alist)
+ (i 0)
+ n width pad format)
+ ;; find the longest string to display
+ (while list
+ (setq n (length (nth idx (car list))))
+ (or (> max n)
+ (setq max n))
+ (setq list (cdr list)))
+ (setq max (+ max 4)) ; %c, `:', SPACE, a SPACE at end
+ (setq n (/ (window-width) max)) ; items per line
+ (setq width (/ (window-width) n)) ; width of each item
+ ;; insert `n' items, each in a field of width `width'
+ (while alist
+ (if (< i n)
+ ()
+ (setq i 0)
+ (delete-char -1) ; the `\n' takes a char
+ (insert "\n"))
+ (setq pad (- width 3))
+ (setq format (concat "%c: %-" (int-to-string pad) "s"))
+ (insert (format format (car (car alist)) (nth idx (car alist))))
+ (setq alist (cdr alist))
+ (setq i (1+ i))))
+ ;; display ourselves in a small window at the bottom
+ (appt-select-lowest-window)
+ (split-window)
+ (pop-to-buffer "*Score Help*")
+ (shrink-window-if-larger-than-buffer)
+ (select-window (get-buffer-window gnus-summary-buffer))))
+
+(defun gnus-summary-header (header &optional no-err)
+ ;; Return HEADER for current articles, or error.
+ (let ((article (gnus-summary-article-number))
+ headers)
+ (if article
+ (if (and (setq headers (gnus-get-header-by-number article))
+ (vectorp headers))
+ (aref headers (nth 1 (assoc header gnus-header-index)))
+ (if no-err
+ nil
+ (error "Pseudo-articles can't be scored")))
+ (if no-err
+ (error "No article on current line")
+ nil))))
+
+(defun gnus-summary-score-entry
+ (header match type score date &optional prompt silent)
+ "Enter score file entry.
+HEADER is the header being scored.
+MATCH is the string we are looking for.
+TYPE is the match type: substring, regexp, exact, fuzzy.
+SCORE is the score to add.
+DATE is the expire date, or nil for no expire, or 'now for immediate expire.
+If optional argument `PROMPT' is non-nil, allow user to edit match.
+If optional argument `SILENT' is nil, show effect of score entry."
+ (interactive
+ (list (completing-read "Header: "
+ gnus-header-index
+ (lambda (x) (fboundp (nth 2 x)))
+ t)
+ (read-string "Match: ")
+ (if (y-or-n-p "Use regexp match? ") 'r 's)
+ (and current-prefix-arg
+ (prefix-numeric-value current-prefix-arg))
+ (cond ((not (y-or-n-p "Add to score file? "))
+ 'now)
+ ((y-or-n-p "Expire kill? ")
+ (current-time-string))
+ (t nil))))
+ ;; Regexp is the default type.
+ (if (eq type t) (setq type 'r))
+ ;; Simplify matches...
+ (cond ((or (eq type 'r) (eq type 's) (eq type nil))
+ (setq match (if match (gnus-simplify-subject-re match) "")))
+ ((eq type 'f)
+ (setq match (gnus-simplify-subject-fuzzy match))))
+ (let ((score (gnus-score-default score))
+ (header (downcase header)))
+ (and prompt (setq match (read-string
+ (format "Match %s on %s, %s: "
+ (cond ((eq date 'now)
+ "now")
+ ((stringp date)
+ "temp")
+ (t "permanent"))
+ header
+ (if (< score 0) "lower" "raise"))
+ (if (numberp match)
+ (int-to-string match)
+ match))))
+ (and (>= (nth 1 (assoc header gnus-header-index)) 0)
+ (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-string)
+ (not silent)
+ (gnus-summary-score-effect header match type score))
+
+ ;; If this is an integer comparison, we transform from string to int.
+ (and (eq (nth 2 (assoc header gnus-header-index)) 'gnus-score-integer)
+ (setq match (string-to-int match)))
+
+ (if (eq date 'now)
+ ()
+ (and (= score gnus-score-interactive-default-score)
+ (setq score nil))
+ (let ((new (cond
+ (type
+ (list match score (and date (gnus-day-number date)) type))
+ (date
+ (list match score (gnus-day-number date)))
+ (score
+ (list match score))
+ (t
+ (list match))))
+ (old (gnus-score-get header))
+ elem)
+ ;; We see whether we can collapse some score entries.
+ ;; This isn't quite correct, because there may be more elements
+ ;; later on with the same key that have matching elems... Hm.
+ (if (and old
+ (setq elem (assoc match old))
+ (eq (nth 3 elem) (nth 3 new))
+ (or (and (numberp (nth 2 elem)) (numberp (nth 2 new)))
+ (and (not (nth 2 elem)) (not (nth 2 new)))))
+ ;; Yup, we just add this new score to the old elem.
+ (setcar (cdr elem) (+ (or (nth 1 elem)
+ gnus-score-interactive-default-score)
+ (or (nth 1 new)
+ gnus-score-interactive-default-score)))
+ ;; Nope, we have to add a new elem.
+ (gnus-score-set header (if old (cons new old) (list new)))))
+ (gnus-score-set 'touched '(t)))))
+
+(defun gnus-summary-score-effect (header match type score)
+ "Simulate the effect of a score file entry.
+HEADER is the header being scored.
+MATCH is the string we are looking for.
+TYPE is a flag indicating if it is a regexp or substring.
+SCORE is the score to add."
+ (interactive (list (completing-read "Header: "
+ gnus-header-index
+ (lambda (x) (fboundp (nth 2 x)))
+ t)
+ (read-string "Match: ")
+ (y-or-n-p "Use regexp match? ")
+ (prefix-numeric-value current-prefix-arg)))
+ (save-excursion
+ (or (and (stringp match) (> (length match) 0))
+ (error "No match"))
+ (goto-char (point-min))
+ (let ((regexp (cond ((eq type 'f)
+ (gnus-simplify-subject-fuzzy match))
+ (type match)
+ (t (concat "\\`.*" (regexp-quote match) ".*\\'")))))
+ (while (not (eobp))
+ (let ((content (gnus-summary-header header 'noerr))
+ (case-fold-search t))
+ (and content
+ (if (if (eq type 'f)
+ (string-equal (gnus-simplify-subject-fuzzy content)
+ regexp)
+ (string-match regexp content))
+ (gnus-summary-raise-score score))))
+ (beginning-of-line 2)))))
+
+(defun gnus-summary-score-crossposting (score date)
+ ;; Enter score file entry for current crossposting.
+ ;; SCORE is the score to add.
+ ;; DATE is the expire date.
+ (let ((xref (gnus-summary-header "xref"))
+ (start 0)
+ group)
+ (or xref (error "This article is not crossposted"))
+ (while (string-match " \\([^ \t]+\\):" xref start)
+ (setq start (match-end 0))
+ (if (not (string=
+ (setq group
+ (substring xref (match-beginning 1) (match-end 1)))
+ gnus-newsgroup-name))
+ (gnus-summary-score-entry
+ "xref" (concat " " group ":") nil score date t)))))
+
+
+;;;
+;;; Gnus Score Files
+;;;
+
+;; All score code written by Per Abrahamsen <abraham@iesd.auc.dk>.
+
+;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defun gnus-score-set-mark-below (score)
+ "Automatically mark articles with score below SCORE as read."
+ (interactive
+ (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
+ (string-to-int (read-string "Mark below: ")))))
+ (setq score (or score gnus-summary-default-score 0))
+ (gnus-score-set 'mark (list score))
+ (gnus-score-set 'touched '(t))
+ (setq gnus-summary-mark-below score)
+ (gnus-summary-update-lines))
+
+(defun gnus-score-set-expunge-below (score)
+ "Automatically expunge articles with score below SCORE."
+ (interactive
+ (list (or (and current-prefix-arg (prefix-numeric-value current-prefix-arg))
+ (string-to-int (read-string "Expunge below: ")))))
+ (setq score (or score gnus-summary-default-score 0))
+ (gnus-score-set 'expunge (list score))
+ (gnus-score-set 'touched '(t)))
+
+(defun gnus-score-set (symbol value &optional alist)
+ ;; Set SYMBOL to VALUE in ALIST.
+ (let* ((alist
+ (or alist
+ gnus-score-alist
+ (progn
+ (gnus-score-load (gnus-score-file-name gnus-newsgroup-name))
+ gnus-score-alist)))
+ (entry (assoc symbol alist)))
+ (cond ((gnus-score-get 'read-only alist)
+ ;; This is a read-only score file, so we do nothing.
+ )
+ (entry
+ (setcdr entry value))
+ ((null alist)
+ (error "Empty alist"))
+ (t
+ (setcdr alist
+ (cons (cons symbol value) (cdr alist)))))))
+
+(defun gnus-score-get (symbol &optional alist)
+ ;; Get SYMBOL's definition in ALIST.
+ (cdr (assoc symbol
+ (or alist
+ gnus-score-alist
+ (progn
+ (gnus-score-load
+ (gnus-score-file-name gnus-newsgroup-name))
+ gnus-score-alist)))))
+
+(defun gnus-score-change-score-file (file)
+ "Change current score alist."
+ (interactive
+ (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
+ (gnus-score-load-file file)
+ (gnus-set-mode-line 'summary))
+
+(defun gnus-score-edit-alist (file)
+ "Edit the current score alist."
+ (interactive (list gnus-current-score-file))
+ (let ((winconf (current-window-configuration)))
+ (and (buffer-name gnus-summary-buffer) (gnus-score-save))
+ (setq gnus-score-edit-buffer (find-file-noselect file))
+ (gnus-configure-windows 'edit-score)
+ (gnus-score-mode)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf))
+ (gnus-message
+ 4 (substitute-command-keys
+ "\\<gnus-score-mode-map>\\[gnus-score-edit-done] to save edits")))
+
+(defun gnus-score-edit-file (file)
+ "Edit a score file."
+ (interactive
+ (list (read-file-name "Edit score file: " gnus-kill-files-directory)))
+ (and (buffer-name gnus-summary-buffer) (gnus-score-save))
+ (let ((winconf (current-window-configuration)))
+ (setq gnus-score-edit-buffer (find-file-noselect file))
+ (gnus-configure-windows 'edit-score)
+ (gnus-score-mode)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf))
+ (gnus-message
+ 4 (substitute-command-keys
+ "\\<gnus-score-mode-map>\\[gnus-score-edit-done] to save edits")))
+
+(defun gnus-score-load-file (file)
+ ;; Load score file FILE. Returns a list a retrieved score-alists.
+ (setq gnus-kill-files-directory (or gnus-kill-files-directory "~/News/"))
+ (let* ((file (expand-file-name
+ (or (and (string-match
+ (concat "^" (expand-file-name
+ gnus-kill-files-directory))
+ (expand-file-name file))
+ file)
+ (concat gnus-kill-files-directory file))))
+ (cached (assoc file gnus-score-cache))
+ (global (member file gnus-internal-global-score-files))
+ lists alist)
+ (if cached
+ ;; The score file was already loaded.
+ (setq alist (cdr cached))
+ ;; We load the score file.
+ (setq gnus-score-alist nil)
+ (setq alist (gnus-score-load-score-alist file))
+ ;; We add '(touched) to the alist to signify that it hasn't been
+ ;; touched (yet).
+ (or (assq 'touched alist) (setq alist (cons (list 'touched nil) alist)))
+ ;; If it is a global score file, we make it read-only.
+ (and global
+ (not (assq 'read-only alist))
+ (setq alist (cons (list 'read-only t) alist)))
+ ;; Update cache.
+ (setq gnus-score-cache
+ (cons (cons file alist) gnus-score-cache)))
+ ;; If there are actual scores in the alist, we add it to the
+ ;; return value of this function.
+ (if (memq t (mapcar (lambda (e) (stringp (car e))) alist))
+ (setq lists (list alist)))
+ ;; Treat the other possible atoms in the score alist.
+ (let ((mark (car (gnus-score-get 'mark alist)))
+ (expunge (car (gnus-score-get 'expunge alist)))
+ (mark-and-expunge (car (gnus-score-get 'mark-and-expunge alist)))
+ (files (gnus-score-get 'files alist))
+ (exclude-files (gnus-score-get 'exclude-files alist))
+ (orphan (car (gnus-score-get 'orphan alist)))
+ (adapt (gnus-score-get 'adapt alist))
+ (local (gnus-score-get 'local alist))
+ (eval (car (gnus-score-get 'eval alist))))
+ ;; We do not respect eval and files atoms from global score
+ ;; files.
+ (and files (not global)
+ (setq lists (apply 'append lists
+ (mapcar (lambda (file)
+ (gnus-score-load-file file))
+ files))))
+ (and eval (not global) (eval eval))
+ ;; We then expand any exclude-file directives.
+ (setq gnus-scores-exclude-files
+ (nconc
+ (mapcar
+ (lambda (sfile)
+ (expand-file-name sfile (file-name-directory file)))
+ exclude-files) gnus-scores-exclude-files))
+ (if (not local)
+ ()
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (while local
+ (and (consp (car local))
+ (symbolp (car (car local)))
+ (progn
+ (make-local-variable (car (car local)))
+ (set (car (car local)) (nth 1 (car local)))))
+ (setq local (cdr local)))))
+ (if orphan (setq gnus-orphan-score orphan))
+ (setq gnus-adaptive-score-alist
+ (cond ((equal adapt '(t))
+ (setq gnus-newsgroup-adaptive t)
+ gnus-default-adaptive-score-alist)
+ ((equal adapt '(ignore))
+ (setq gnus-newsgroup-adaptive nil))
+ ((consp adapt)
+ (setq gnus-newsgroup-adaptive t)
+ adapt)
+ (t
+ ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring)
+ gnus-default-adaptive-score-alist)))
+ (setq gnus-summary-mark-below
+ (or mark mark-and-expunge gnus-summary-mark-below))
+ (setq gnus-summary-expunge-below
+ (or expunge mark-and-expunge gnus-summary-expunge-below)))
+ (setq gnus-current-score-file file)
+ (setq gnus-score-alist alist)
+ lists))
+
+(defun gnus-score-load (file)
+ ;; Load score FILE.
+ (let ((cache (assoc file gnus-score-cache)))
+ (if cache
+ (setq gnus-score-alist (cdr cache))
+ (setq gnus-score-alist nil)
+ (gnus-score-load-score-alist file)
+ (or gnus-score-alist
+ (setq gnus-score-alist (copy-alist '((touched nil)))))
+ (setq gnus-score-cache
+ (cons (cons file gnus-score-alist) gnus-score-cache)))))
+
+(defun gnus-score-remove-from-cache (file)
+ (setq gnus-score-cache
+ (delq (assoc file gnus-score-cache) gnus-score-cache)))
+
+(defun gnus-score-load-score-alist (file)
+ (let (alist)
+ (if (file-readable-p file)
+ (progn
+ (save-excursion
+ (gnus-set-work-buffer)
+ (insert-file-contents file)
+ (goto-char (point-min))
+ ;; Only do the loading if the score file isn't empty.
+ (if (save-excursion (re-search-forward "[()0-9a-zA-Z]" nil t))
+ (setq alist
+ (condition-case ()
+ (read (current-buffer))
+ (error
+ (progn
+ (gnus-message 3 "Problem with score file %s" file)
+ (ding)
+ (sit-for 2)
+ nil))))))
+ (if (eq (car alist) 'setq)
+ (setq gnus-score-alist (gnus-score-transform-old-to-new alist))
+ (setq gnus-score-alist alist))
+ (setq gnus-score-alist
+ (gnus-score-check-syntax gnus-score-alist file)))
+ (setq gnus-score-alist nil))))
+
+(defun gnus-score-check-syntax (alist file)
+ (cond
+ ((null alist)
+ nil)
+ ((not (consp alist))
+ (gnus-message 1 "Score file is not a list: %s" file)
+ (ding)
+ nil)
+ (t
+ (let ((a alist)
+ err)
+ (while (and a (not err))
+ (cond ((not (listp (car a)))
+ (gnus-message 3 "Illegal score element %s in %s" (car a) file)
+ (setq err t))
+ ((and (stringp (car (car a)))
+ (not (listp (nth 1 (car a)))))
+ (gnus-message 3 "Illegal header match %s in %s" (nth 1 (car a)) file)
+ (setq err t))
+ (t
+ (setq a (cdr a)))))
+ (if err
+ (progn
+ (ding)
+ nil)
+ alist)))))
+
+(defun gnus-score-transform-old-to-new (alist)
+ (let* ((alist (nth 2 alist))
+ out entry)
+ (if (eq (car alist) 'quote)
+ (setq alist (nth 1 alist)))
+ (while alist
+ (setq entry (car alist))
+ (if (stringp (car entry))
+ (let ((scor (cdr entry)))
+ (setq out (cons entry out))
+ (while scor
+ (setcar scor
+ (list (car (car scor)) (nth 2 (car scor))
+ (and (nth 3 (car scor))
+ (gnus-day-number (nth 3 (car scor))))
+ (if (nth 1 (car scor)) 'r 's)))
+ (setq scor (cdr scor))))
+ (setq out (cons (if (not (listp (cdr entry)))
+ (list (car entry) (cdr entry))
+ entry)
+ out)))
+ (setq alist (cdr alist)))
+ (cons (list 'touched t) (nreverse out))))
+
+(defun gnus-score-save ()
+ ;; Save all score information.
+ (let ((cache gnus-score-cache))
+ (save-excursion
+ (setq gnus-score-alist nil)
+ (set-buffer (get-buffer-create "*Score*"))
+ (buffer-disable-undo (current-buffer))
+ (let (entry score file)
+ (while cache
+ (setq entry (car cache)
+ cache (cdr cache)
+ file (car entry)
+ score (cdr entry))
+ (if (or (not (equal (gnus-score-get 'touched score) '(t)))
+ (gnus-score-get 'read-only score)
+ (and (file-exists-p file)
+ (not (file-writable-p file))))
+ ()
+ (setq score (setcdr entry (delq (assq 'touched score) score)))
+ (erase-buffer)
+ (let (emacs-lisp-mode-hook)
+ (if (string-match (concat gnus-adaptive-file-suffix "$") file)
+ ;; This is an adaptive score file, so we do not run
+ ;; it through `pp'. These files can get huge, and
+ ;; are not meant to be edited by human hands.
+ (insert (format "%S" score))
+ ;; This is a normal score file, so we print it very
+ ;; prettily.
+ (pp score (current-buffer))))
+ (if (not (gnus-make-directory (file-name-directory file)))
+ ()
+ ;; If the score file is empty, we delete it.
+ (if (zerop (buffer-size))
+ (delete-file file)
+ ;; There are scores, so we write the file.
+ (and (file-writable-p file)
+ (write-region (point-min) (point-max)
+ file nil 'silent)))))))
+ (kill-buffer (current-buffer)))))
+
+(defun gnus-score-headers (score-files &optional trace)
+ ;; Score `gnus-newsgroup-headers'.
+ (let (scores)
+ ;; PLM: probably this is not the best place to clear orphan-score
+ (setq gnus-orphan-score nil)
+ (setq gnus-scores-articles nil)
+ (setq gnus-scores-exclude-files nil)
+ ;; Load the score files.
+ (while score-files
+ (if (stringp (car score-files))
+ ;; It is a string, which means that it's a score file name,
+ ;; so we load the score file and add the score alist to
+ ;; the list of alists.
+ (setq scores (nconc (gnus-score-load-file (car score-files)) scores))
+ ;; It is an alist, so we just add it to the list directly.
+ (setq scores (nconc (car score-files) scores)))
+ (setq score-files (cdr score-files)))
+ ;; Prune the score files that are to be excluded, if any.
+ (if (not gnus-scores-exclude-files)
+ ()
+ (let ((s scores)
+ c)
+ (while s
+ (and (setq c (rassq (car s) gnus-score-cache))
+ (member (car c) gnus-scores-exclude-files)
+ (setq scores (delq (car s) scores)))
+ (setq s (cdr s)))))
+ (if (not (and gnus-summary-default-score
+ scores
+ (> (length gnus-newsgroup-headers)
+ (length gnus-newsgroup-scored))))
+ ()
+ (let* ((entries gnus-header-index)
+ (now (gnus-day-number (current-time-string)))
+ (expire (- now gnus-score-expiry-days))
+ (headers gnus-newsgroup-headers)
+ (current-score-file gnus-current-score-file)
+ entry header)
+ (gnus-message 5 "Scoring...")
+ ;; Create articles, an alist of the form `(HEADER . SCORE)'.
+ (while headers
+ (setq header (car headers)
+ headers (cdr headers))
+ ;; WARNING: The assq makes the function O(N*S) while it could
+ ;; be written as O(N+S), where N is (length gnus-newsgroup-headers)
+ ;; and S is (length gnus-newsgroup-scored).
+ (or (assq (mail-header-number header) gnus-newsgroup-scored)
+ (setq gnus-scores-articles ;Total of 2 * N cons-cells used.
+ (cons (cons header (or gnus-summary-default-score 0))
+ gnus-scores-articles))))
+
+ (save-excursion
+ (set-buffer (get-buffer-create "*Headers*"))
+ (buffer-disable-undo (current-buffer))
+
+ ;; Set the global variant of this variable.
+ (setq gnus-current-score-file current-score-file)
+ ;; score orphans
+ (if gnus-orphan-score
+ (progn
+ (setq gnus-score-index
+ (nth 1 (assoc "references" gnus-header-index)))
+ (gnus-score-orphans gnus-orphan-score)))
+ ;; Run each header through the score process.
+ (while entries
+ (setq entry (car entries)
+ header (nth 0 entry)
+ entries (cdr entries))
+ (setq gnus-score-index (nth 1 (assoc header gnus-header-index)))
+ (if (< 0 (apply 'max (mapcar
+ (lambda (score)
+ (length (gnus-score-get header score)))
+ scores)))
+ (funcall (nth 2 entry) scores header now expire trace)))
+ ;; Remove the buffer.
+ (kill-buffer (current-buffer)))
+
+ ;; Add articles to `gnus-newsgroup-scored'.
+ (while gnus-scores-articles
+ (or (= gnus-summary-default-score (cdr (car gnus-scores-articles)))
+ (setq gnus-newsgroup-scored
+ (cons (cons (mail-header-number
+ (car (car gnus-scores-articles)))
+ (cdr (car gnus-scores-articles)))
+ gnus-newsgroup-scored)))
+ (setq gnus-scores-articles (cdr gnus-scores-articles)))
+
+ (gnus-message 5 "Scoring...done")))))
+
+
+(defun gnus-get-new-thread-ids (articles)
+ (let ((index (nth 1 (assoc "message-id" gnus-header-index)))
+ (refind gnus-score-index)
+ id-list art this tref)
+ (while articles
+ (setq art (car articles)
+ this (aref (car art) index)
+ tref (aref (car art) refind)
+ articles (cdr articles))
+ (if (string-equal tref "") ;no references line
+ (setq id-list (cons this id-list))))
+ id-list))
+
+;; Orphan functions written by plm@atcmp.nl (Peter Mutsaers).
+(defun gnus-score-orphans (score)
+ (let ((new-thread-ids (gnus-get-new-thread-ids gnus-scores-articles))
+ alike articles art arts this last this-id)
+
+ (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
+ articles gnus-scores-articles)
+
+ ;;more or less the same as in gnus-score-string
+ (erase-buffer)
+ (while articles
+ (setq art (car articles)
+ this (aref (car art) gnus-score-index)
+ articles (cdr articles))
+ ;;completely skip if this is empty (not a child, so not an orphan)
+ (if (not (string= this ""))
+ (if (equal last this)
+ ;; O(N*H) cons-cells used here, where H is the number of
+ ;; headers.
+ (setq alike (cons art alike))
+ (if last
+ (progn
+ ;; Insert the line, with a text property on the
+ ;; terminating newline refering to the articles with
+ ;; this line.
+ (insert last ?\n)
+ (put-text-property (1- (point)) (point) 'articles alike)))
+ (setq alike (list art)
+ last this))))
+ (and last ; Bwadr, duplicate code.
+ (progn
+ (insert last ?\n)
+ (put-text-property (1- (point)) (point) 'articles alike)))
+
+ ;; PLM: now delete those lines that contain an entry from new-thread-ids
+ (while new-thread-ids
+ (setq this-id (car new-thread-ids)
+ new-thread-ids (cdr new-thread-ids))
+ (goto-char (point-min))
+ (while (search-forward this-id nil t)
+ ;; found a match. remove this line
+ (beginning-of-line)
+ (kill-line 1)))
+
+ ;; now for each line: update its articles with score by moving to
+ ;; every end-of-line in the buffer and read the articles property
+ (goto-char (point-min))
+ (while (eq 0 (progn
+ (end-of-line)
+ (setq arts (get-text-property (point) 'articles))
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (setcdr art (+ score (cdr art))))
+ (forward-line))))))
+
+
+(defun gnus-score-integer (scores header now expire &optional trace)
+ (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
+ entries alist)
+
+ ;; Find matches.
+ (while scores
+ (setq alist (car scores)
+ scores (cdr scores)
+ entries (assoc header alist))
+ (while (cdr entries) ;First entry is the header index.
+ (let* ((rest (cdr entries))
+ (kill (car rest))
+ (match (nth 0 kill))
+ (type (or (nth 3 kill) '>))
+ (score (or (nth 1 kill) gnus-score-interactive-default-score))
+ (date (nth 2 kill))
+ (found nil)
+ (match-func (if (or (eq type '>) (eq type '<) (eq type '<=)
+ (eq type '>=) (eq type '=))
+ type
+ (error "Illegal match type: %s" type)))
+ (articles gnus-scores-articles))
+ ;; Instead of doing all the clever stuff that
+ ;; `gnus-score-string' does to minimize searches and stuff,
+ ;; I will assume that people generally will put so few
+ ;; matches on numbers that any cleverness will take more
+ ;; time than one would gain.
+ (while articles
+ (and (funcall match-func
+ (or (aref (car (car articles)) gnus-score-index) 0)
+ match)
+ (progn
+ (and trace (setq gnus-score-trace
+ (cons (cons (car (car articles)) kill)
+ gnus-score-trace)))
+ (setq found t)
+ (setcdr (car articles) (+ score (cdr (car articles))))))
+ (setq articles (cdr articles)))
+ ;; Update expire date
+ (cond ((null date)) ;Permanent entry.
+ (found ;Match, update date.
+ (gnus-score-set 'touched '(t) alist)
+ (setcar (nthcdr 2 kill) now))
+ ((< date expire) ;Old entry, remove.
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr entries (cdr rest))
+ (setq rest entries)))
+ (setq entries rest))))))
+
+(defun gnus-score-date (scores header now expire &optional trace)
+ (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
+ entries alist)
+
+ ;; Find matches.
+ (while scores
+ (setq alist (car scores)
+ scores (cdr scores)
+ entries (assoc header alist))
+ (while (cdr entries) ;First entry is the header index.
+ (let* ((rest (cdr entries))
+ (kill (car rest))
+ (match (timezone-make-date-sortable (nth 0 kill)))
+ (type (or (nth 3 kill) 'before))
+ (score (or (nth 1 kill) gnus-score-interactive-default-score))
+ (date (nth 2 kill))
+ (found nil)
+ (match-func
+ (cond ((eq type 'after) 'string<)
+ ((eq type 'before) 'gnus-string>)
+ ((eq type 'at) 'string=)
+ (t (error "Illegal match type: %s" type))))
+ (articles gnus-scores-articles)
+ l)
+ ;; Instead of doing all the clever stuff that
+ ;; `gnus-score-string' does to minimize searches and stuff,
+ ;; I will assume that people generally will put so few
+ ;; matches on numbers that any cleverness will take more
+ ;; time than one would gain.
+ (while articles
+ (and
+ (setq l (aref (car (car articles)) gnus-score-index))
+ (funcall match-func match (timezone-make-date-sortable l))
+ (progn
+ (and trace (setq gnus-score-trace
+ (cons (cons (car (car articles)) kill)
+ gnus-score-trace)))
+ (setq found t)
+ (setcdr (car articles) (+ score (cdr (car articles))))))
+ (setq articles (cdr articles)))
+ ;; Update expire date
+ (cond ((null date)) ;Permanent entry.
+ (found ;Match, update date.
+ (gnus-score-set 'touched '(t) alist)
+ (setcar (nthcdr 2 kill) now))
+ ((< date expire) ;Old entry, remove.
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr entries (cdr rest))
+ (setq rest entries)))
+ (setq entries rest))))))
+
+(defun gnus-score-body (scores header now expire &optional trace)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (save-restriction
+ (let* ((buffer-read-only nil)
+ (articles gnus-scores-articles)
+ (last (mail-header-number (car (car gnus-scores-articles))))
+ (all-scores scores)
+ (request-func (cond ((string= "head" (downcase header))
+ 'gnus-request-head)
+ ((string= "body" (downcase header))
+ 'gnus-request-body)
+ (t 'gnus-request-article)))
+ entries alist ofunc article)
+ ;; Not all backends support partial fetching. In that case,
+ ;; we just fetch the entire article.
+ (or (gnus-check-backend-function
+ (and (string-match "^gnus-" (symbol-name request-func))
+ (intern (substring (symbol-name request-func)
+ (match-end 0))))
+ gnus-newsgroup-name)
+ (progn
+ (setq ofunc request-func)
+ (setq request-func 'gnus-request-article)))
+ (while articles
+ (setq article (mail-header-number (car (car articles))))
+ (gnus-message 7 "Scoring on article %s of %s..." article last)
+ (if (not (funcall request-func article gnus-newsgroup-name))
+ ()
+ (widen)
+ (goto-char (point-min))
+ ;; If just parts of the article is to be searched, but the
+ ;; backend didn't support partial fetching, we just narrow
+ ;; to the relevant parts.
+ (if 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))))
+ (setq scores all-scores)
+ ;; Find matches.
+ (while scores
+ (setq alist (car scores)
+ scores (cdr scores)
+ entries (assoc header alist))
+ (while (cdr entries) ;First entry is the header index.
+ (let* ((rest (cdr entries))
+ (kill (car rest))
+ (match (nth 0 kill))
+ (type (or (nth 3 kill) 's))
+ (score (or (nth 1 kill)
+ gnus-score-interactive-default-score))
+ (date (nth 2 kill))
+ (found nil)
+ (case-fold-search
+ (not (or (eq type 'R) (eq type 'S)
+ (eq type 'Regexp) (eq type 'String))))
+ (search-func
+ (cond ((or (eq type 'r) (eq type 'R)
+ (eq type 'regexp) (eq type 'Regexp))
+ 're-search-forward)
+ ((or (eq type 's) (eq type 'S)
+ (eq type 'string) (eq type 'String))
+ 'search-forward)
+ (t
+ (error "Illegal match type: %s" type)))))
+ (goto-char (point-min))
+ (if (funcall search-func match nil t)
+ ;; Found a match, update scores.
+ (progn
+ (setcdr (car articles) (+ score (cdr (car articles))))
+ (setq found t)
+ (and trace (setq gnus-score-trace
+ (cons (cons (car (car articles)) kill)
+ gnus-score-trace)))))
+ ;; Update expire date
+ (cond ((null date)) ;Permanent entry.
+ (found ;Match, update date.
+ (gnus-score-set 'touched '(t) alist)
+ (setcar (nthcdr 2 kill) now))
+ ((< date expire) ;Old entry, remove.
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr entries (cdr rest))
+ (setq rest entries)))
+ (setq entries rest)))))
+ (setq articles (cdr articles)))))))
+
+
+
+(defun gnus-score-followup (scores header now expire &optional trace)
+ ;; Insert the unique article headers in the buffer.
+ (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
+ (current-score-file gnus-current-score-file)
+ (all-scores scores)
+ ;; gnus-score-index is used as a free variable.
+ alike last this art entries alist articles)
+
+ ;; Change score file to the adaptive score file. All entries that
+ ;; this function makes will be put into this file.
+ (gnus-score-load-file (gnus-score-file-name
+ gnus-newsgroup-name gnus-adaptive-file-suffix))
+
+ (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
+ articles gnus-scores-articles)
+
+ (erase-buffer)
+ (while articles
+ (setq art (car articles)
+ this (aref (car art) gnus-score-index)
+ articles (cdr articles))
+ (if (equal last this)
+ (setq alike (cons art alike))
+ (if last
+ (progn
+ (insert last ?\n)
+ (put-text-property (1- (point)) (point) 'articles alike)))
+ (setq alike (list art)
+ last this)))
+ (and last ; Bwadr, duplicate code.
+ (progn
+ (insert last ?\n)
+ (put-text-property (1- (point)) (point) 'articles alike)))
+
+ ;; Find matches.
+ (while scores
+ (setq alist (car scores)
+ scores (cdr scores)
+ entries (assoc header alist))
+ (while (cdr entries) ;First entry is the header index.
+ (let* ((rest (cdr entries))
+ (kill (car rest))
+ (match (nth 0 kill))
+ (type (or (nth 3 kill) 's))
+ (score (or (nth 1 kill) gnus-score-interactive-default-score))
+ (date (nth 2 kill))
+ (found nil)
+ (mt (aref (symbol-name type) 0))
+ (case-fold-search
+ (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
+ (dmt (downcase mt))
+ (search-func
+ (cond ((= dmt ?r) 're-search-forward)
+ ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
+ (t (error "Illegal match type: %s" type))))
+ arts art)
+ (goto-char (point-min))
+ (if (= dmt ?e)
+ (while (funcall search-func match nil t)
+ (and (= (progn (beginning-of-line) (point))
+ (match-beginning 0))
+ (= (progn (end-of-line) (point))
+ (match-end 0))
+ (progn
+ (setq found (setq arts (get-text-property
+ (point) 'articles)))
+ ;; Found a match, update scores.
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (gnus-score-add-followups
+ (car art) score all-scores)))))
+ (while (funcall search-func match nil t)
+ (end-of-line)
+ (setq found (setq arts (get-text-property (point) 'articles)))
+ ;; Found a match, update scores.
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (gnus-score-add-followups (car art) score all-scores))))
+ ;; Update expire date
+ (cond ((null date)) ;Permanent entry.
+ (found ;Match, update date.
+ (gnus-score-set 'touched '(t) alist)
+ (setcar (nthcdr 2 kill) now))
+ ((< date expire) ;Old entry, remove.
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr entries (cdr rest))
+ (setq rest entries)))
+ (setq entries rest))))
+ ;; We change the score file back to the previous one.
+ (gnus-score-load-file current-score-file)))
+
+(defun gnus-score-add-followups (header score scores)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (let* ((id (mail-header-id header))
+ (scores (car scores))
+ entry dont)
+ ;; Don't enter a score if there already is one.
+ (while scores
+ (setq entry (car scores))
+ (and (equal "references" (car entry))
+ (or (null (nth 3 (car (cdr entry))))
+ (eq 's (nth 3 (car (cdr entry)))))
+ (progn
+ (if (assoc id entry)
+ (setq dont t))))
+ (setq scores (cdr scores)))
+ (or dont
+ (gnus-summary-score-entry
+ "references" id 's score (current-time-string) nil t)))))
+
+
+(defun gnus-score-string (score-list header now expire &optional trace)
+ ;; Score ARTICLES according to HEADER in SCORE-LIST.
+ ;; Update matches entries to NOW and remove unmatched entried older
+ ;; than EXPIRE.
+
+ ;; Insert the unique article headers in the buffer.
+ (let ((gnus-score-index (nth 1 (assoc header gnus-header-index)))
+ ;; gnus-score-index is used as a free variable.
+ alike last this art entries alist articles scores fuzzy)
+
+ ;; Sorting the articles costs os O(N*log N) but will allow us to
+ ;; only match with each unique header. Thus the actual matching
+ ;; will be O(M*U) where M is the number of strings to match with,
+ ;; and U is the number of unique headers. It is assumed (but
+ ;; untested) this will be a net win because of the large constant
+ ;; factor involved with string matching.
+ (setq gnus-scores-articles (sort gnus-scores-articles 'gnus-score-string<)
+ articles gnus-scores-articles)
+
+ (erase-buffer)
+ (while articles
+ (setq art (car articles)
+ this (aref (car art) gnus-score-index)
+ articles (cdr articles))
+ (if (equal last this)
+ ;; O(N*H) cons-cells used here, where H is the number of
+ ;; headers.
+ (setq alike (cons art alike))
+ (if last
+ (progn
+ ;; Insert the line, with a text property on the
+ ;; terminating newline refering to the articles with
+ ;; this line.
+ (insert last ?\n)
+ (put-text-property (1- (point)) (point) 'articles alike)))
+ (setq alike (list art)
+ last this)))
+ (and last ; Bwadr, duplicate code.
+ (progn
+ (insert last ?\n)
+ (put-text-property (1- (point)) (point) 'articles alike)))
+
+ ;; Find ordinary matches.
+ (setq scores score-list)
+ (while scores
+ (setq alist (car scores)
+ scores (cdr scores)
+ entries (assoc header alist))
+ (while (cdr entries) ;First entry is the header index.
+ (let* ((rest (cdr entries))
+ (kill (car rest))
+ (match (nth 0 kill))
+ (type (or (nth 3 kill) 's))
+ (score (or (nth 1 kill) gnus-score-interactive-default-score))
+ (date (nth 2 kill))
+ (found nil)
+ (mt (aref (symbol-name type) 0))
+ (case-fold-search
+ (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
+ (dmt (downcase mt))
+ (search-func
+ (cond ((= dmt ?r) 're-search-forward)
+ ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
+ (t (error "Illegal match type: %s" type))))
+ arts art)
+ (if (= dmt ?f)
+ (setq fuzzy t)
+ (goto-char (point-min))
+ (if (= dmt ?e)
+ (while (and (not (eobp))
+ (funcall search-func match nil t))
+ (and (= (progn (beginning-of-line) (point))
+ (match-beginning 0))
+ (= (progn (end-of-line) (point))
+ (match-end 0))
+ (progn
+ (setq found (setq arts (get-text-property
+ (point) 'articles)))
+ ;; Found a match, update scores.
+ (if trace
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (setcdr art (+ score (cdr art)))
+ (setq gnus-score-trace
+ (cons (cons (mail-header-number
+ (car art)) kill)
+ gnus-score-trace)))
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (setcdr art (+ score (cdr art)))))))
+ (forward-line 1))
+ (and (string= match "") (setq match "\n"))
+ (while (and (not (eobp))
+ (funcall search-func match nil t))
+ (goto-char (match-beginning 0))
+ (end-of-line)
+ (setq found (setq arts (get-text-property (point) 'articles)))
+ ;; Found a match, update scores.
+ (if trace
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (setcdr art (+ score (cdr art)))
+ (setq gnus-score-trace
+ (cons (cons (mail-header-number (car art)) kill)
+ gnus-score-trace)))
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (setcdr art (+ score (cdr art)))))
+ (forward-line 1)))
+ ;; Update expire date
+ (cond ((null date)) ;Permanent entry.
+ (found ;Match, update date.
+ (gnus-score-set 'touched '(t) alist)
+ (setcar (nthcdr 2 kill) now))
+ ((< date expire) ;Old entry, remove.
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr entries (cdr rest))
+ (setq rest entries))))
+ (setq entries rest))))
+
+ ;; Find fuzzy matches.
+ (setq scores (and fuzzy score-list))
+ (if fuzzy (gnus-simplify-buffer-fuzzy))
+ (while scores
+ (setq alist (car scores)
+ scores (cdr scores)
+ entries (assoc header alist))
+ (while (cdr entries) ;First entry is the header index.
+ (let* ((rest (cdr entries))
+ (kill (car rest))
+ (match (nth 0 kill))
+ (type (or (nth 3 kill) 's))
+ (score (or (nth 1 kill) gnus-score-interactive-default-score))
+ (date (nth 2 kill))
+ (found nil)
+ (mt (aref (symbol-name type) 0))
+ (case-fold-search
+ (not (or (= mt ?R) (= mt ?S) (= mt ?E) (= mt ?F))))
+ (dmt (downcase mt))
+ (search-func
+ (cond ((= dmt ?r) 're-search-forward)
+ ((or (= dmt ?e) (= dmt ?s) (= dmt ?f)) 'search-forward)
+ (t (error "Illegal match type: %s" type))))
+ arts art)
+ (if (/= dmt ?f)
+ ()
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (funcall search-func match nil t))
+ (and (= (progn (beginning-of-line) (point))
+ (match-beginning 0))
+ (= (progn (end-of-line) (point))
+ (match-end 0))
+ (progn
+ (setq found (setq arts (get-text-property
+ (point) 'articles)))
+ ;; Found a match, update scores.
+ (if trace
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (setcdr art (+ score (cdr art)))
+ (setq gnus-score-trace
+ (cons (cons (mail-header-number
+ (car art)) kill)
+ gnus-score-trace)))
+ (while arts
+ (setq art (car arts)
+ arts (cdr arts))
+ (setcdr art (+ score (cdr art)))))))
+ (forward-line 1))
+ ;; Update expire date
+ (cond ((null date)) ;Permanent entry.
+ (found ;Match, update date.
+ (gnus-score-set 'touched '(t) alist)
+ (setcar (nthcdr 2 kill) now))
+ ((< date expire) ;Old entry, remove.
+ (gnus-score-set 'touched '(t) alist)
+ (setcdr entries (cdr rest))
+ (setq rest entries))))
+ (setq entries rest))))))
+
+(defun gnus-score-string< (a1 a2)
+ ;; Compare headers in articles A2 and A2.
+ ;; The header index used is the free variable `gnus-score-index'.
+ (string-lessp (aref (car a1) gnus-score-index)
+ (aref (car a2) gnus-score-index)))
+
+(defun gnus-score-build-cons (article)
+ ;; Build a `gnus-newsgroup-scored' type cons from ARTICLE.
+ (cons (mail-header-number (car article)) (cdr article)))
+
+(defconst gnus-header-index
+ ;; Name to index alist.
+ '(("number" 0 gnus-score-integer)
+ ("subject" 1 gnus-score-string)
+ ("from" 2 gnus-score-string)
+ ("date" 3 gnus-score-date)
+ ("message-id" 4 gnus-score-string)
+ ("references" 5 gnus-score-string)
+ ("chars" 6 gnus-score-integer)
+ ("lines" 7 gnus-score-integer)
+ ("xref" 8 gnus-score-string)
+ ("head" -1 gnus-score-body)
+ ("body" -1 gnus-score-body)
+ ("all" -1 gnus-score-body)
+ ("followup" 2 gnus-score-followup)))
+
+(defun gnus-current-score-file-nondirectory (&optional score-file)
+ (let ((score-file (or score-file gnus-current-score-file)))
+ (if score-file
+ (gnus-short-group-name (file-name-nondirectory score-file))
+ "none")))
+
+(defun gnus-score-adaptive ()
+ (save-excursion
+ (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
+ (alist malist)
+ (date (current-time-string))
+ elem headers match)
+ ;; First we transform the adaptive rule alist into something
+ ;; that's faster to process.
+ (while malist
+ (setq elem (car malist))
+ (if (symbolp (car elem))
+ (setcar elem (symbol-value (car elem))))
+ (setq elem (cdr elem))
+ (while elem
+ (setcdr (car elem)
+ (cons (symbol-name (car (car elem))) (cdr (car elem))))
+ (setcar (car elem)
+ (intern
+ (concat "gnus-header-"
+ (downcase (symbol-name (car (car elem)))))))
+ (setq elem (cdr elem)))
+ (setq malist (cdr malist)))
+ ;; We change the score file to the adaptive score file.
+ (gnus-score-load-file (gnus-score-file-name
+ gnus-newsgroup-name gnus-adaptive-file-suffix))
+ ;; The we score away.
+ (goto-char (point-min))
+ (while (not (eobp))
+ (setq elem (cdr (assq (gnus-summary-article-mark) alist)))
+ (if (or (not elem)
+ (get-text-property (point) 'gnus-pseudo))
+ ()
+ (setq headers (gnus-get-header-by-number
+ (gnus-summary-article-number)))
+ (while (and elem headers)
+ (setq match (funcall (car (car elem)) headers))
+ (gnus-summary-score-entry
+ (nth 1 (car elem)) match
+ (cond
+ ((numberp match)
+ '=)
+ ((equal (nth 1 (car elem)) "date")
+ 'a)
+ (t
+ ;; Whether we use substring or exact matches are controlled
+ ;; here.
+ (if (or (not gnus-score-exact-adapt-limit)
+ (< (length match) gnus-score-exact-adapt-limit))
+ 'e
+ (if (equal (nth 1 (car elem)) "subject")
+ 'f 's))))
+ (nth 2 (car elem)) date nil t)
+ (setq elem (cdr elem))))
+ (forward-line 1)))))
+
+(defun gnus-score-remove-lines-adaptive (marks)
+ (save-excursion
+ (let* ((malist (gnus-copy-sequence gnus-adaptive-score-alist))
+ (alist malist)
+ (date (current-time-string))
+ (cur-score gnus-current-score-file)
+ elem headers match)
+ ;; First we transform the adaptive rule alist into something
+ ;; that's faster to process.
+ (while malist
+ (setq elem (car malist))
+ (if (symbolp (car elem))
+ (setcar elem (symbol-value (car elem))))
+ (setq elem (cdr elem))
+ (while elem
+ (setcdr (car elem)
+ (cons (symbol-name (car (car elem))) (cdr (car elem))))
+ (setcar (car elem)
+ (intern
+ (concat "gnus-header-"
+ (downcase (symbol-name (car (car elem)))))))
+ (setq elem (cdr elem)))
+ (setq malist (cdr malist)))
+ ;; The we score away.
+ (goto-char (point-min))
+ ;; We change the score file to the adaptive score file.
+ (gnus-score-load-file (gnus-score-file-name
+ gnus-newsgroup-name gnus-adaptive-file-suffix))
+ (while (re-search-forward marks nil t)
+ (beginning-of-line)
+ (setq elem (cdr (assq (gnus-summary-article-mark) alist)))
+ (if (or (not elem)
+ (get-text-property (gnus-point-at-bol) 'gnus-pseudo))
+ ()
+ (setq headers (gnus-get-header-by-number
+ (gnus-summary-article-number)))
+ (while elem
+ (setq match (funcall (car (car elem)) headers))
+ (gnus-summary-score-entry
+ (nth 1 (car elem)) match
+ (if (or (not gnus-score-exact-adapt-limit)
+ (< (length match) gnus-score-exact-adapt-limit))
+ 'e 's)
+ (nth 2 (car elem)) date nil t)
+ (setq elem (cdr elem))))
+ (delete-region (point) (progn (forward-line 1) (point))))
+ ;; Switch back to the old score file.
+ (gnus-score-load-file cur-score))))
+
+;;;
+;;; Score mode.
+;;;
+
+(defvar gnus-score-mode-map nil)
+(defvar gnus-score-mode-hook nil)
+
+(if 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-done)
+ (define-key gnus-score-mode-map "\C-c\C-d" 'gnus-score-edit-insert-date))
+
+(defun gnus-score-mode ()
+ "Mode for editing 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)
+ (set-syntax-table emacs-lisp-mode-syntax-table)
+ (setq major-mode 'gnus-score-mode)
+ (setq mode-name "Score")
+ (lisp-mode-variables nil)
+ (run-hooks 'emacs-lisp-mode-hook 'gnus-score-mode-hook))
+
+(defun gnus-score-edit-insert-date ()
+ "Insert date in numerical format."
+ (interactive)
+ (insert (int-to-string (gnus-day-number (current-time-string)))))
+
+(defun gnus-score-edit-done ()
+ "Save the score file and return to the summary buffer."
+ (interactive)
+ (let ((bufnam (buffer-file-name (current-buffer)))
+ (winconf gnus-prev-winconf))
+ (gnus-make-directory (file-name-directory (buffer-file-name)))
+ (save-buffer)
+ (kill-buffer (current-buffer))
+ (gnus-score-remove-from-cache bufnam)
+ (gnus-score-load-file bufnam)
+ (and winconf (set-window-configuration winconf))))
+
+(defun gnus-score-find-trace ()
+ "Find all score rules applied to this article."
+ (interactive)
+ (let ((gnus-newsgroup-headers
+ (list (gnus-get-header-by-number (gnus-summary-article-number))))
+ (gnus-newsgroup-scored nil)
+ (buf (current-buffer))
+ trace)
+ (setq gnus-score-trace nil)
+ (gnus-possibly-score-headers 'trace)
+ (or (setq trace gnus-score-trace)
+ (error "No score rules apply to the current article."))
+ (pop-to-buffer "*Gnus Scores*")
+ (gnus-add-current-to-buffer-list)
+ (erase-buffer)
+ (while trace
+ (insert (format "%S\n" (cdr (car trace))))
+ (setq trace (cdr trace)))
+ (goto-char (point-min))
+ (pop-to-buffer buf)))
+
+
+(provide 'gnus-score)
+
+;;; gnus-score.el ends here
diff --git a/lisp/gnus-uu.el b/lisp/gnus-uu.el
new file mode 100644
index 00000000000..9ccba3de9ae
--- /dev/null
+++ b/lisp/gnus-uu.el
@@ -0,0 +1,1889 @@
+;;; gnus-uu.el --- extract (uu)encoded files in Gnus
+;; Copyright (C) 1985,86,87,93,94,95 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Created: 2 Oct 1993
+;; Version: v3.0
+;; Keyword: 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-msg)
+
+;; Default viewing action rules
+
+(defvar gnus-uu-default-view-rules
+ '(("\\.te?xt$\\|\\.doc$\\|read.*me\\|\\.c?$\\|\\.h$\\|\\.bat$\\|\\.asm$\\|makefile" "cat %s | sed s/\r//g")
+ ("\\.pas$" "cat %s | sed s/\r//g")
+ ("\\.[1-9]$" "groff -mandoc -Tascii %s | sed s/\b.//g")
+ ("\\.\\(jpe?g\\|gif\\|tiff?\\|p[pgb]m\\|xwd\\|xbm\\|pcx\\)$" "xv")
+ ("\\.tga$" "tgatoppm %s | xv -")
+ ("\\.\\(wav\\|aiff\\|hcom\\|u[blw]\\|s[bfw]\\|voc\\|smp\\)$"
+ "sox -v .5 %s -t .au -u - > /dev/audio")
+ ("\\.au$" "cat %s > /dev/audio")
+ ("\\.mod$" "str32")
+ ("\\.ps$" "ghostview")
+ ("\\.dvi$" "xdvi")
+ ("\\.html$" "xmosaic")
+ ("\\.mpe?g$" "mpeg_play")
+ ("\\.\\(flc\\|fli\\|rle\\|iff\\|pfx\\|avi\\|sme\\|rpza\\|dl\\|qt\\|rsrc\\|mov\\)$" "xanim")
+ ("\\.\\(tar\\|arj\\|zip\\|zoo\\|arc\\|gz\\|Z\\|lzh\\|ar\\|lha\\)$"
+ "gnus-uu-archive"))
+ "*Default actions to be taken when the user asks to view a file.
+To change the behaviour, you can either edit this variable or set
+`gnus-uu-user-view-rules' to something useful.
+
+For example:
+
+To make gnus-uu use 'xli' to display JPEG and GIF files, put the
+following in your .emacs file:
+
+ (setq gnus-uu-user-view-rules '((\"jpg$\\\\|gif$\" \"xli\")))
+
+Both these variables are lists of lists with two string elements. The
+first string is a regular expression. If the file name matches this
+regular expression, the command in the second string is executed with
+the file as an argument.
+
+If the command string contains \"%s\", the file name will be inserted
+at that point in the command string. If there's no \"%s\" in the
+command string, the file name will be appended to the command string
+before executing.
+
+There are several user variables to tailor the behaviour of gnus-uu to
+your needs. First we have `gnus-uu-user-view-rules', which is the
+variable gnus-uu first consults when trying to decide how to view a
+file. If this variable contains no matches, gnus-uu examines the
+default rule variable provided in this package. If gnus-uu finds no
+match here, it uses `gnus-uu-user-view-rules-end' to try to make a
+match.")
+
+(defvar gnus-uu-user-view-rules nil
+ "*Variable detailing what actions are to be taken to view a file.
+See the documentation on the `gnus-uu-default-view-rules' variable for
+details.")
+
+(defvar gnus-uu-user-view-rules-end
+ '(("" "file"))
+ "*Variable saying what actions are to be taken if no rule matched the file name.
+See the documentation on the `gnus-uu-default-view-rules' variable for
+details.")
+
+;; Default unpacking commands
+
+(defvar gnus-uu-default-archive-rules
+ '(("\\.tar$" "tar xf")
+ ("\\.zip$" "unzip -o")
+ ("\\.ar$" "ar x")
+ ("\\.arj$" "unarj x")
+ ("\\.zoo$" "zoo -e")
+ ("\\.\\(lzh\\|lha\\)$" "lha x")
+ ("\\.Z$" "uncompress")
+ ("\\.gz$" "gunzip")
+ ("\\.arc$" "arc -x")))
+
+(defvar gnus-uu-destructive-archivers
+ (list "uncompress" "gunzip"))
+
+(defvar gnus-uu-user-archive-rules nil
+ "*A list that can be set to override the default archive unpacking commands.
+To use, for instance, 'untar' to unpack tar files and 'zip -x' to
+unpack zip files, say the following:
+ (setq gnus-uu-user-archive-rules
+ '((\"\\\\.tar$\" \"untar\")
+ (\"\\\\.zip$\" \"zip -x\")))")
+
+(defvar gnus-uu-ignore-files-by-name nil
+ "*A regular expression saying what files should not be viewed based on name.
+If, for instance, you want gnus-uu to ignore all .au and .wav files,
+you could say something like
+
+ (setq gnus-uu-ignore-files-by-name \"\\\\.au$\\\\|\\\\.wav$\")
+
+Note that this variable can be used in conjunction with the
+`gnus-uu-ignore-files-by-type' variable.")
+
+(defvar gnus-uu-ignore-files-by-type nil
+ "*A regular expression saying what files that shouldn't be viewed, based on MIME file type.
+If, for instance, you want gnus-uu to ignore all audio files and all mpegs,
+you could say something like
+
+ (setq gnus-uu-ignore-files-by-type \"audio/\\\\|video/mpeg\")
+
+Note that this variable can be used in conjunction with the
+`gnus-uu-ignore-files-by-name' variable.")
+
+;; Pseudo-MIME support
+
+(defconst gnus-uu-ext-to-mime-list
+ '(("\\.gif$" "image/gif")
+ ("\\.jpe?g$" "image/jpeg")
+ ("\\.tiff?$" "image/tiff")
+ ("\\.xwd$" "image/xwd")
+ ("\\.pbm$" "image/pbm")
+ ("\\.pgm$" "image/pgm")
+ ("\\.ppm$" "image/ppm")
+ ("\\.xbm$" "image/xbm")
+ ("\\.pcx$" "image/pcx")
+ ("\\.tga$" "image/tga")
+ ("\\.ps$" "image/postscript")
+ ("\\.fli$" "video/fli")
+ ("\\.wav$" "audio/wav")
+ ("\\.aiff$" "audio/aiff")
+ ("\\.hcom$" "audio/hcom")
+ ("\\.voc$" "audio/voc")
+ ("\\.smp$" "audio/smp")
+ ("\\.mod$" "audio/mod")
+ ("\\.dvi$" "image/dvi")
+ ("\\.mpe?g$" "video/mpeg")
+ ("\\.au$" "audio/basic")
+ ("\\.\\(te?xt\\|doc\\|c\\|h\\)$" "text/plain")
+ ("\\.\\(c\\|h\\)$" "text/source")
+ ("read.*me" "text/plain")
+ ("\\.html$" "text/html")
+ ("\\.bat$" "text/bat")
+ ("\\.[1-6]$" "text/man")
+ ("\\.flc$" "video/flc")
+ ("\\.rle$" "video/rle")
+ ("\\.pfx$" "video/pfx")
+ ("\\.avi$" "video/avi")
+ ("\\.sme$" "video/sme")
+ ("\\.rpza$" "video/prza")
+ ("\\.dl$" "video/dl")
+ ("\\.qt$" "video/qt")
+ ("\\.rsrc$" "video/rsrc")
+ ("\\..*$" "unknown/unknown")))
+
+;; Various variables users may set
+
+(defvar gnus-uu-tmp-dir "/tmp/"
+ "*Variable saying where gnus-uu is to do its work.
+Default is \"/tmp/\".")
+
+(defvar gnus-uu-do-not-unpack-archives nil
+ "*Non-nil means that gnus-uu won't peek inside archives looking for files to dispay.
+Default is nil.")
+
+(defvar gnus-uu-view-and-save nil
+ "*Non-nil means that the user will always be asked to save a file after viewing it.
+If the variable is nil, the user will only be asked to save if the
+viewing is unsuccessful. Default is nil.")
+
+(defvar gnus-uu-ignore-default-view-rules nil
+ "*Non-nil means that gnus-uu will ignore the default viewing rules.
+Only the user viewing rules will be consulted. Default is nil.")
+
+(defvar gnus-uu-ignore-default-archive-rules nil
+ "*Non-nil means that gnus-uu will ignore the default archive unpacking commands.
+Only the user unpacking commands will be consulted. Default is nil.")
+
+(defvar gnus-uu-kill-carriage-return t
+ "*Non-nil means that gnus-uu will strip all carriage returns from articles.
+Default is t.")
+
+(defvar gnus-uu-view-with-metamail nil
+ "*Non-nil means that files will be viewed with metamail.
+The gnus-uu viewing functions will be ignored and gnus-uu will try
+to guess at a content-type based on file name suffixes. Default
+it nil.")
+
+(defvar gnus-uu-unmark-articles-not-decoded nil
+ "*Non-nil means that gnus-uu will mark articles that were unsuccessfully decoded as unread.
+Default is nil.")
+
+(defvar gnus-uu-correct-stripped-uucode nil
+ "*Non-nil means that gnus-uu will *try* to fix uuencoded files that have had trailing spaces deleted.
+Default is nil.")
+
+(defvar gnus-uu-save-in-digest nil
+ "*Non-nil means that gnus-uu, when asked to save without decoding, will save in digests.
+If this variable is nil, gnus-uu will just save everything in a
+file without any embellishments. The digesting almost conforms to RFC1153 -
+no easy way to specify any meaningful volume and issue numbers were found,
+so I simply dropped them.")
+
+(defvar gnus-uu-digest-headers
+ '("^Date:" "^From:" "^To:" "^Cc:" "^Subject:" "^Message-ID:" "^Keywords:"
+ "^Summary:" "^References:")
+ "*List of regexps to match headers included in digested messages.
+The headers will be included in the sequence they are matched.")
+
+(defvar gnus-uu-save-separate-articles nil
+ "*Non-nil means that gnus-uu will save articles in separate files.")
+
+;; Internal variables
+
+(defvar gnus-uu-saved-article-name nil)
+
+(defconst gnus-uu-begin-string "^begin[ \t]+[0-7][0-7][0-7][ \t]+\\(.*\\)$")
+(defconst gnus-uu-end-string "^end[ \t]*$")
+
+(defconst gnus-uu-body-line "^M")
+(let ((i 61))
+ (while (> (setq i (1- i)) 0)
+ (setq gnus-uu-body-line (concat gnus-uu-body-line "[^a-z]")))
+ (setq gnus-uu-body-line (concat gnus-uu-body-line ".?$")))
+
+;"^M.............................................................?$"
+
+(defconst gnus-uu-shar-begin-string "^#! */bin/sh")
+
+(defvar gnus-uu-shar-file-name nil)
+(defconst gnus-uu-shar-name-marker "begin [0-7][0-7][0-7][ \t]+\\(\\(\\w\\|\\.\\)*\\b\\)")
+
+(defconst gnus-uu-postscript-begin-string "^%!PS-")
+(defconst gnus-uu-postscript-end-string "^%%EOF$")
+
+(defvar gnus-uu-file-name nil)
+(defconst gnus-uu-uudecode-process nil)
+(defvar gnus-uu-binhex-article-name nil)
+
+(defvar gnus-uu-generated-file-list nil)
+(defvar gnus-uu-work-dir nil)
+
+(defconst gnus-uu-output-buffer-name " *Gnus UU Output*")
+
+(defvar gnus-uu-default-dir default-directory)
+
+;; Keymaps
+
+(defvar gnus-uu-extract-map nil)
+(defvar gnus-uu-extract-view-map nil)
+(defvar gnus-uu-mark-map nil)
+
+(define-prefix-command 'gnus-uu-mark-map)
+(define-key gnus-summary-mark-map "P" 'gnus-uu-mark-map)
+(define-key gnus-uu-mark-map "p" 'gnus-summary-mark-as-processable)
+(define-key gnus-uu-mark-map "u" 'gnus-summary-unmark-as-processable)
+(define-key gnus-uu-mark-map "U" 'gnus-summary-unmark-all-processable)
+(define-key gnus-uu-mark-map "s" 'gnus-uu-mark-series)
+(define-key gnus-uu-mark-map "r" 'gnus-uu-mark-region)
+(define-key gnus-uu-mark-map "R" 'gnus-uu-mark-by-regexp)
+(define-key gnus-uu-mark-map "t" 'gnus-uu-mark-thread)
+(define-key gnus-uu-mark-map "a" 'gnus-uu-mark-all)
+(define-key gnus-uu-mark-map "S" 'gnus-uu-mark-sparse)
+
+(define-prefix-command 'gnus-uu-extract-map)
+(define-key gnus-summary-mode-map "X" 'gnus-uu-extract-map)
+;;(define-key gnus-uu-extract-map "x" 'gnus-uu-extract-any)
+;;(define-key gnus-uu-extract-map "m" 'gnus-uu-extract-mime)
+(define-key gnus-uu-extract-map "u" 'gnus-uu-decode-uu)
+(define-key gnus-uu-extract-map "U" 'gnus-uu-decode-uu-and-save)
+(define-key gnus-uu-extract-map "s" 'gnus-uu-decode-unshar)
+(define-key gnus-uu-extract-map "S" 'gnus-uu-decode-unshar-and-save)
+(define-key gnus-uu-extract-map "o" 'gnus-uu-decode-save)
+(define-key gnus-uu-extract-map "O" 'gnus-uu-decode-save)
+(define-key gnus-uu-extract-map "b" 'gnus-uu-decode-binhex)
+(define-key gnus-uu-extract-map "B" 'gnus-uu-decode-binhex)
+(define-key gnus-uu-extract-map "p" 'gnus-uu-decode-postscript)
+(define-key gnus-uu-extract-map "P" 'gnus-uu-decode-postscript-and-save)
+
+(define-prefix-command 'gnus-uu-extract-view-map)
+(define-key gnus-uu-extract-map "v" 'gnus-uu-extract-view-map)
+(define-key gnus-uu-extract-view-map "u" 'gnus-uu-decode-uu-view)
+(define-key gnus-uu-extract-view-map "U" 'gnus-uu-decode-uu-and-save-view)
+(define-key gnus-uu-extract-view-map "s" 'gnus-uu-decode-unshar-view)
+(define-key gnus-uu-extract-view-map "S" 'gnus-uu-decode-unshar-and-save-view)
+(define-key gnus-uu-extract-view-map "o" 'gnus-uu-decode-save-view)
+(define-key gnus-uu-extract-view-map "O" 'gnus-uu-decode-save-view)
+(define-key gnus-uu-extract-view-map "b" 'gnus-uu-decode-binhex-view)
+(define-key gnus-uu-extract-view-map "B" 'gnus-uu-decode-binhex-view)
+(define-key gnus-uu-extract-view-map "p" 'gnus-uu-decode-postscript-view)
+(define-key gnus-uu-extract-view-map "P" 'gnus-uu-decode-postscript-and-save-view)
+
+
+
+;; Commands.
+
+(defun gnus-uu-decode-uu (n)
+ "Uudecodes the current article."
+ (interactive "P")
+ (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n))
+
+(defun gnus-uu-decode-uu-and-save (n dir)
+ "Decodes and saves the resulting file."
+ (interactive
+ (list current-prefix-arg
+ (file-name-as-directory
+ (read-file-name "Uudecode and save in dir: "
+ gnus-uu-default-dir
+ gnus-uu-default-dir t))))
+ (gnus-uu-decode-with-method 'gnus-uu-uustrip-article n dir))
+
+(defun gnus-uu-decode-unshar (n)
+ "Unshars the current article."
+ (interactive "P")
+ (gnus-uu-decode-with-method 'gnus-uu-unshar-article n nil nil 'scan))
+
+(defun gnus-uu-decode-unshar-and-save (n dir)
+ "Unshars and saves the current article."
+ (interactive
+ (list current-prefix-arg
+ (file-name-as-directory
+ (read-file-name "Unshar and save in dir: "
+ gnus-uu-default-dir
+ gnus-uu-default-dir t))))
+ (gnus-uu-decode-with-method 'gnus-uu-unshar-article n dir nil 'scan))
+
+(defun gnus-uu-decode-save (n file)
+ "Saves the current article."
+ (interactive
+ (list current-prefix-arg
+ (read-file-name
+ (if gnus-uu-save-separate-articles
+ "Save articles is dir: "
+ "Save articles in file: ")
+ gnus-uu-default-dir
+ gnus-uu-default-dir)))
+ (setq gnus-uu-saved-article-name file)
+ (gnus-uu-decode-with-method 'gnus-uu-save-article n nil t)
+ (setq gnus-uu-generated-file-list
+ (delete file gnus-uu-generated-file-list)))
+
+(defun gnus-uu-decode-binhex (n dir)
+ "Unbinhexes the current article."
+ (interactive
+ (list current-prefix-arg
+ (file-name-as-directory
+ (read-file-name "Unbinhex and save in dir: "
+ gnus-uu-default-dir
+ gnus-uu-default-dir))))
+ (setq gnus-uu-binhex-article-name
+ (make-temp-name (concat gnus-uu-work-dir "binhex")))
+ (gnus-uu-decode-with-method 'gnus-uu-binhex-article n dir))
+
+(defun gnus-uu-decode-uu-view (n)
+ "Uudecodes and views the current article."
+ (interactive "P")
+ (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
+ (gnus-uu-decode-uu n)))
+
+(defun gnus-uu-decode-uu-and-save-view (n dir)
+ "Decodes, views and saves the resulting file."
+ (interactive
+ (list current-prefix-arg
+ (read-file-name "Uudecode, view and save in dir: "
+ gnus-uu-default-dir
+ gnus-uu-default-dir t)))
+ (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
+ (gnus-uu-decode-uu-and-save n dir)))
+
+(defun gnus-uu-decode-unshar-view (n)
+ "Unshars and views the current article."
+ (interactive "P")
+ (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
+ (gnus-uu-decode-unshar n)))
+
+(defun gnus-uu-decode-unshar-and-save-view (n dir)
+ "Unshars and saves the current article."
+ (interactive
+ (list current-prefix-arg
+ (read-file-name "Unshar, view and save in dir: "
+ gnus-uu-default-dir
+ gnus-uu-default-dir t)))
+ (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
+ (gnus-uu-decode-unshar-and-save n dir)))
+
+(defun gnus-uu-decode-save-view (n file)
+ "Saves and views the current article."
+ (interactive
+ (list current-prefix-arg
+ (read-file-name (if gnus-uu-save-separate-articles
+ "Save articles is dir: "
+ "Save articles in file: ")
+ gnus-uu-default-dir gnus-uu-default-dir)))
+ (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
+ (gnus-uu-decode-save n file)))
+
+(defun gnus-uu-decode-binhex-view (n file)
+ "Unbinhexes and views the current article."
+ (interactive
+ (list current-prefix-arg
+ (read-file-name "Unbinhex, view and save in dir: "
+ gnus-uu-default-dir gnus-uu-default-dir)))
+ (setq gnus-uu-binhex-article-name
+ (make-temp-name (concat gnus-uu-work-dir "binhex")))
+ (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
+ (gnus-uu-decode-binhex n file)))
+
+
+;; Digest and forward articles
+
+(defun gnus-uu-digest-mail-forward (n &optional post)
+ "Digests and forwards all articles in this series."
+ (interactive "P")
+ (let ((gnus-uu-save-in-digest t)
+ (file (make-temp-name (concat gnus-uu-tmp-dir "forward")))
+ buf)
+ (gnus-uu-decode-save n file)
+ (gnus-uu-add-file file)
+ (setq buf (switch-to-buffer (get-buffer-create " *gnus-uu-forward*")))
+ (gnus-add-current-to-buffer-list)
+ (erase-buffer)
+ (delete-other-windows)
+ (insert-file file)
+ (goto-char (point-min))
+ (and (re-search-forward "^Subject: ")
+ (progn
+ (delete-region (point) (gnus-point-at-eol))
+ (insert "Digested Articles")))
+ (goto-char (point-min))
+ (and (re-search-forward "^From: ")
+ (progn
+ (delete-region (point) (gnus-point-at-eol))
+ (insert "Various")))
+ (if post
+ (gnus-forward-using-post)
+ (funcall gnus-mail-forward-method))
+ (delete-file file)
+ (kill-buffer buf)))
+
+(defun gnus-uu-digest-post-forward (n)
+ "Digest and forward to a newsgroup."
+ (interactive "P")
+ (gnus-uu-digest-mail-forward n t))
+
+;; Process marking.
+
+(defun gnus-uu-mark-by-regexp (regexp)
+ "Ask for a regular expression and set the process mark on all articles that match."
+ (interactive (list (read-from-minibuffer "Mark (regexp): ")))
+ (gnus-set-global-variables)
+ (let ((articles (gnus-uu-find-articles-matching regexp)))
+ (while articles
+ (gnus-summary-set-process-mark (car articles))
+ (setq articles (cdr articles)))
+ (message ""))
+ (gnus-summary-position-cursor))
+
+(defun gnus-uu-mark-series ()
+ "Mark the current series with the process mark."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((articles (gnus-uu-find-articles-matching)))
+ (while articles
+ (gnus-summary-set-process-mark (car articles))
+ (setq articles (cdr articles)))
+ (message ""))
+ (gnus-summary-position-cursor))
+
+(defun gnus-uu-mark-region (beg end)
+ "Marks all articles between point and mark."
+ (interactive "r")
+ (gnus-set-global-variables)
+ (save-excursion
+ (goto-char beg)
+ (while (< (point) end)
+ (gnus-summary-set-process-mark (gnus-summary-article-number))
+ (forward-line 1)))
+ (gnus-summary-position-cursor))
+
+(defun gnus-uu-mark-thread ()
+ "Marks all articles downwards in this thread."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((level (gnus-summary-thread-level)))
+ (while (and (gnus-summary-set-process-mark (gnus-summary-article-number))
+ (zerop (gnus-summary-next-subject 1))
+ (> (gnus-summary-thread-level) level))))
+ (gnus-summary-position-cursor))
+
+(defun gnus-uu-mark-sparse ()
+ "Mark all series that have some articles marked."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((marked (nreverse gnus-newsgroup-processable))
+ subject articles total headers)
+ (or marked (error "No articles marked with the process mark"))
+ (setq gnus-newsgroup-processable nil)
+ (save-excursion
+ (while marked
+ (and (setq headers (gnus-get-header-by-number (car marked)))
+ (setq subject (mail-header-subject headers)
+ articles (gnus-uu-find-articles-matching
+ (gnus-uu-reginize-string subject))
+ total (nconc total articles)))
+ (while articles
+ (gnus-summary-set-process-mark (car articles))
+ (setcdr marked (delq (car articles) (cdr marked)))
+ (setq articles (cdr articles)))
+ (setq marked (cdr marked)))
+ (setq gnus-newsgroup-processable (nreverse total)))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-uu-mark-all ()
+ "Mark all articles in \"series\" order."
+ (interactive)
+ (gnus-set-global-variables)
+ (setq gnus-newsgroup-processable nil)
+ (save-excursion
+ (goto-char (point-min))
+ (let (number)
+ (while (and (not (eobp))
+ (setq number (gnus-summary-article-number)))
+ (if (not (memq number gnus-newsgroup-processable))
+ (save-excursion (gnus-uu-mark-series)))
+ (forward-line 1))))
+ (gnus-summary-position-cursor))
+
+;; All PostScript functions written by Erik Selberg <speed@cs.washington.edu>.
+
+(defun gnus-uu-decode-postscript (n)
+ "Gets postscript of the current article."
+ (interactive "P")
+ (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n))
+
+(defun gnus-uu-decode-postscript-view (n)
+ "Gets and views the current article."
+ (interactive "P")
+ (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
+ (gnus-uu-decode-postscript n)))
+
+(defun gnus-uu-decode-postscript-and-save (n dir)
+ "Extracts postscript and saves the current article."
+ (interactive
+ (list current-prefix-arg
+ (file-name-as-directory
+ (read-file-name "Save in dir: "
+ gnus-uu-default-dir
+ gnus-uu-default-dir t))))
+ (gnus-uu-decode-with-method 'gnus-uu-decode-postscript-article n dir))
+
+
+(defun gnus-uu-decode-postscript-and-save-view (n dir)
+ "Decodes, views and saves the resulting file."
+ (interactive
+ (list current-prefix-arg
+ (read-file-name "Where do you want to save the file(s)? "
+ gnus-uu-default-dir
+ gnus-uu-default-dir t)))
+ (let ((gnus-view-pseudos (or gnus-view-pseudos 'automatic)))
+ (gnus-uu-decode-postscript-and-save n dir)))
+
+
+;; Internal functions.
+
+(defun gnus-uu-decode-with-method (method n &optional save not-insert scan)
+ (gnus-uu-initialize scan)
+ (if save (setq gnus-uu-default-dir save))
+ (let ((articles (gnus-uu-get-list-of-articles n))
+ files)
+ (setq files (gnus-uu-grab-articles articles method t))
+ (let ((gnus-current-article (car articles)))
+ (and scan (setq files (gnus-uu-scan-directory gnus-uu-work-dir))))
+ (and save (gnus-uu-save-files files save))
+ (setq files (gnus-uu-unpack-files files))
+ (gnus-uu-add-file (mapcar (lambda (file) (cdr (assq 'name file))) files))
+ (setq files (nreverse (gnus-uu-get-actions files)))
+ (or not-insert (gnus-summary-insert-pseudos files save))))
+
+;; Return a list of files in dir.
+(defun gnus-uu-scan-directory (dir)
+ (let ((files (directory-files dir t))
+ dirs out)
+ (while files
+ (cond ((string-match "/\\.\\.?$" (car files)))
+ ((file-directory-p (car files))
+ (setq dirs (cons (car files) dirs)))
+ (t (setq out (cons (list (cons 'name (car files))
+ (cons 'article gnus-current-article))
+ out))))
+ (setq files (cdr files)))
+ (apply 'nconc out (mapcar (lambda (d) (gnus-uu-scan-directory d))
+ dirs))))
+
+(defun gnus-uu-save-files (files dir)
+ (let ((len (length files))
+ to-file file)
+ (while files
+ (and
+ (setq file (cdr (assq 'name (car files))))
+ (file-exists-p file)
+ (progn
+ (setq to-file (if (file-directory-p dir)
+ (concat dir (file-name-nondirectory file))
+ dir))
+ (and (or (not (file-exists-p to-file))
+ (gnus-y-or-n-p (format "%s exists; overwrite? "
+ to-file)))
+ (copy-file file to-file t t))))
+ (setq files (cdr files)))
+ (message "Saved %d file%s" len (if (> len 1) "s" ""))))
+
+;; Functions for saving and possibly digesting articles without
+;; any decoding.
+
+;; Function called by gnus-uu-grab-articles to treat each article.
+(defun gnus-uu-save-article (buffer in-state)
+ (cond
+ (gnus-uu-save-separate-articles
+ (save-excursion
+ (set-buffer buffer)
+ (write-region 1 (point-max) (concat gnus-uu-saved-article-name
+ gnus-current-article))
+ (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin))
+ ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name
+ 'begin 'end))
+ ((eq in-state 'last) (list 'end))
+ (t (list 'middle)))))
+ ((not gnus-uu-save-in-digest)
+ (save-excursion
+ (set-buffer buffer)
+ (write-region 1 (point-max) gnus-uu-saved-article-name t)
+ (cond ((eq in-state 'first) (list gnus-uu-saved-article-name 'begin))
+ ((eq in-state 'first-and-last) (list gnus-uu-saved-article-name
+ 'begin 'end))
+ ((eq in-state 'last) (list 'end))
+ (t (list 'middle)))))
+ (t
+ (let ((name (file-name-nondirectory gnus-uu-saved-article-name))
+ beg subj headers headline sorthead body end-string state)
+ (if (or (eq in-state 'first)
+ (eq in-state 'first-and-last))
+ (progn
+ (setq state (list 'begin))
+ (save-excursion (set-buffer (get-buffer-create "*gnus-uu-body*"))
+ (erase-buffer))
+ (save-excursion
+ (set-buffer (get-buffer-create "*gnus-uu-pre*"))
+ (erase-buffer)
+ (insert (format
+ "Date: %s\nFrom: %s\nSubject: %s Digest\n\nTopics:\n"
+ (current-time-string) name name))))
+ (if (not (eq in-state 'end))
+ (setq state (list 'middle))))
+ (save-excursion
+ (set-buffer (get-buffer "*gnus-uu-body*"))
+ (goto-char (setq beg (point-max)))
+ (save-excursion
+ (save-restriction
+ (set-buffer buffer)
+ (let (buffer-read-only)
+ (set-text-properties (point-min) (point-max) nil)
+ ;; These two are necessary for XEmacs 19.12 fascism.
+ (put-text-property (point-min) (point-max) 'invisible nil)
+ (put-text-property (point-min) (point-max) 'intangible nil))
+ (goto-char (point-min))
+ (re-search-forward "\n\n")
+ (setq body (buffer-substring (1- (point)) (point-max)))
+ (narrow-to-region 1 (point))
+ (if (not (setq headers gnus-uu-digest-headers))
+ (setq sorthead (buffer-substring (point-min) (point-max)))
+ (while headers
+ (setq headline (car headers))
+ (setq headers (cdr headers))
+ (goto-char (point-min))
+ (if (re-search-forward headline nil t)
+ (setq sorthead
+ (concat sorthead
+ (buffer-substring
+ (match-beginning 0)
+ (or (and (re-search-forward "^[^ \t]" nil t)
+ (1- (point)))
+ (progn (forward-line 1) (point)))))))))
+ (widen)))
+ (insert sorthead)(goto-char (point-max))
+ (insert body)(goto-char (point-max))
+ (insert (concat "\n" (make-string 30 ?-) "\n\n"))
+ (goto-char beg)
+ (if (re-search-forward "^Subject: \\(.*\\)$" nil t)
+ (progn
+ (setq subj (buffer-substring (match-beginning 1) (match-end 1)))
+ (save-excursion
+ (set-buffer (get-buffer "*gnus-uu-pre*"))
+ (insert (format " %s\n" subj))))))
+ (if (or (eq in-state 'last)
+ (eq in-state 'first-and-last))
+ (progn
+ (save-excursion
+ (set-buffer (get-buffer "*gnus-uu-pre*"))
+ (insert (format "\n\n%s\n\n" (make-string 70 ?-)))
+ (write-region 1 (point-max) gnus-uu-saved-article-name))
+ (save-excursion
+ (set-buffer (get-buffer "*gnus-uu-body*"))
+ (goto-char (point-max))
+ (insert
+ (concat (setq end-string (format "End of %s Digest" name))
+ "\n"))
+ (insert (concat (make-string (length end-string) ?*) "\n"))
+ (write-region 1 (point-max) gnus-uu-saved-article-name t))
+ (kill-buffer (get-buffer "*gnus-uu-pre*"))
+ (kill-buffer (get-buffer "*gnus-uu-body*"))
+ (setq state (cons 'end state))))
+ (if (memq 'begin state)
+ (cons gnus-uu-saved-article-name state)
+ state)))))
+
+;; Binhex treatment - not very advanced.
+
+(defconst gnus-uu-binhex-body-line
+ "^[^:]...............................................................$")
+(defconst gnus-uu-binhex-begin-line
+ "^:...............................................................$")
+(defconst gnus-uu-binhex-end-line
+ ":$")
+
+(defun gnus-uu-binhex-article (buffer in-state)
+ (let (state start-char)
+ (save-excursion
+ (set-buffer buffer)
+ (widen)
+ (goto-char (point-min))
+ (if (not (re-search-forward gnus-uu-binhex-begin-line nil t))
+ (if (not (re-search-forward gnus-uu-binhex-body-line nil t))
+ (setq state (list 'wrong-type))))
+
+ (if (memq 'wrong-type state)
+ ()
+ (beginning-of-line)
+ (setq start-char (point))
+ (if (looking-at gnus-uu-binhex-begin-line)
+ (progn
+ (setq state (list 'begin))
+ (write-region 1 1 gnus-uu-binhex-article-name))
+ (setq state (list 'middle)))
+ (goto-char (point-max))
+ (re-search-backward (concat gnus-uu-binhex-body-line "\\|"
+ gnus-uu-binhex-end-line) nil t)
+ (if (looking-at gnus-uu-binhex-end-line)
+ (setq state (if (memq 'begin state)
+ (cons 'end state)
+ (list 'end))))
+ (beginning-of-line)
+ (forward-line 1)
+ (if (file-exists-p gnus-uu-binhex-article-name)
+ (append-to-file start-char (point) gnus-uu-binhex-article-name))))
+ (if (memq 'begin state)
+ (cons gnus-uu-binhex-article-name state)
+ state)))
+
+;; PostScript
+
+(defun gnus-uu-decode-postscript-article (process-buffer in-state)
+ (let ((state (list 'ok))
+ start-char end-char file-name)
+ (save-excursion
+ (set-buffer process-buffer)
+ (goto-char (point-min))
+ (if (not (re-search-forward gnus-uu-postscript-begin-string nil t))
+ (setq state (list 'wrong-type))
+ (beginning-of-line)
+ (setq start-char (point))
+ (if (not (re-search-forward gnus-uu-postscript-end-string nil t))
+ (setq state (list 'wrong-type))
+ (setq end-char (point))
+ (set-buffer (get-buffer-create gnus-uu-output-buffer-name))
+ (insert-buffer-substring process-buffer start-char end-char)
+ (setq file-name (concat gnus-uu-work-dir (cdr gnus-article-current) ".ps"))
+ (write-region (point-min) (point-max) file-name)
+ (setq state (list file-name'begin 'end))
+
+ ))
+ )
+ state))
+
+
+;; Find actions.
+
+(defun gnus-uu-get-actions (files)
+ (let ((ofiles files)
+ action name)
+ (while files
+ (setq name (cdr (assq 'name (car files))))
+ (and
+ (setq action (gnus-uu-get-action name))
+ (setcar files (nconc (list (if (string= action "gnus-uu-archive")
+ (cons 'action "file")
+ (cons 'action action))
+ (cons 'execute (if (string-match "%" action)
+ (format action name)
+ (concat action " " name))))
+ (car files))))
+ (setq files (cdr files)))
+ ofiles))
+
+(defun gnus-uu-get-action (file-name)
+ (let (action)
+ (setq action
+ (gnus-uu-choose-action
+ file-name
+ (append
+ gnus-uu-user-view-rules
+ (if gnus-uu-ignore-default-view-rules
+ nil
+ gnus-uu-default-view-rules)
+ gnus-uu-user-view-rules-end)))
+ (if (and (not (string= (or action "") "gnus-uu-archive"))
+ gnus-uu-view-with-metamail)
+ (if (setq action
+ (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list))
+ (setq action (format "metamail -d -b -c \"%s\"" action))))
+ action))
+
+
+;; Functions for treating subjects and collecting series.
+
+(defun gnus-uu-reginize-string (string)
+ ;; Takes a string and puts a \ in front of every special character;
+ ;; ignores any leading "version numbers" thingies that they use in
+ ;; the comp.binaries groups, and either replaces anything that looks
+ ;; like "2/3" with "[0-9]+/[0-9]+" or, if it can't find something
+ ;; like that, replaces the last two numbers with "[0-9]+". This, in
+ ;; my experience, should get most postings of a series.
+ (let ((count 2)
+ (vernum "v[0-9]+[a-z][0-9]+:")
+ beg)
+ (save-excursion
+ (set-buffer (get-buffer-create gnus-uu-output-buffer-name))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert (regexp-quote string))
+ (setq beg 1)
+
+ (setq case-fold-search nil)
+ (goto-char (point-min))
+ (if (looking-at vernum)
+ (progn
+ (replace-match vernum t t)
+ (setq beg (length vernum))))
+
+ (goto-char beg)
+ (if (re-search-forward "[ \t]*[0-9]+/[0-9]+" nil t)
+ (replace-match " [0-9]+/[0-9]+")
+
+ (goto-char beg)
+ (if (re-search-forward "[0-9]+[ \t]*of[ \t]*[0-9]+" nil t)
+ (replace-match "[0-9]+ of [0-9]+")
+
+ (end-of-line)
+ (while (and (re-search-backward "[0-9]" nil t) (> count 0))
+ (while (and
+ (looking-at "[0-9]")
+ (< 1 (goto-char (1- (point))))))
+ (re-search-forward "[0-9]+" nil t)
+ (replace-match "[0-9]+")
+ (backward-char 5)
+ (setq count (1- count)))))
+
+ (goto-char beg)
+ (while (re-search-forward "[ \t]+" nil t)
+ (replace-match "[ \t]*" t t))
+
+ (buffer-substring 1 (point-max)))))
+
+(defun gnus-uu-get-list-of-articles (n)
+ ;; If N is non-nil, the article numbers of the N next articles
+ ;; will be returned.
+ ;; If any articles have been marked as processable, they will be
+ ;; returned.
+ ;; Failing that, articles that have subjects that are part of the
+ ;; same "series" as the current will be returned.
+ (let (articles)
+ (cond
+ (n
+ (let ((backward (< n 0))
+ (n (abs n)))
+ (save-excursion
+ (while (and (> n 0)
+ (setq articles (cons (gnus-summary-article-number)
+ articles))
+ (gnus-summary-search-forward nil nil backward))
+ (setq n (1- n))))
+ (nreverse articles)))
+ (gnus-newsgroup-processable
+ (reverse gnus-newsgroup-processable))
+ (t
+ (gnus-uu-find-articles-matching)))))
+
+(defun gnus-uu-string< (l1 l2)
+ (string< (car l1) (car l2)))
+
+(defun gnus-uu-find-articles-matching
+ (&optional subject only-unread do-not-translate)
+ ;; Finds all articles that matches the regexp SUBJECT. If it is
+ ;; nil, the current article name will be used. If ONLY-UNREAD is
+ ;; non-nil, only unread articles are chosen. If DO-NOT-TRANSLATE is
+ ;; non-nil, article names are not equalized before sorting.
+ (let ((subject (or subject
+ (gnus-uu-reginize-string (gnus-summary-subject-string))))
+ list-of-subjects)
+ (save-excursion
+ (if (not subject)
+ ()
+ ;; Collect all subjects matching subject.
+ (let ((case-fold-search t)
+ subj mark)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (and (setq subj (gnus-summary-subject-string))
+ (string-match subject subj)
+ (or (not only-unread)
+ (= (setq mark (gnus-summary-article-mark))
+ gnus-unread-mark)
+ (= mark gnus-ticked-mark)
+ (= mark gnus-dormant-mark))
+ (setq list-of-subjects
+ (cons (cons subj (gnus-summary-article-number))
+ list-of-subjects)))
+ (forward-line 1)))
+
+ ;; Expand numbers, sort, and return the list of article
+ ;; numbers.
+ (mapcar (lambda (sub) (cdr sub))
+ (sort (gnus-uu-expand-numbers
+ list-of-subjects
+ (not do-not-translate))
+ 'gnus-uu-string<))))))
+
+(defun gnus-uu-expand-numbers (string-list &optional translate)
+ ;; Takes a list of strings and "expands" all numbers in all the
+ ;; strings. That is, this function makes all numbers equal length by
+ ;; prepending lots of zeroes before each number. This is to ease later
+ ;; sorting to find out what sequence the articles are supposed to be
+ ;; decoded in. Returns the list of expanded strings.
+ (let ((out-list string-list)
+ string)
+ (save-excursion
+ (set-buffer (get-buffer-create gnus-uu-output-buffer-name))
+ (buffer-disable-undo (current-buffer))
+ (while string-list
+ (erase-buffer)
+ (insert (car (car string-list)))
+ ;; Translate multiple spaces to one space.
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+" nil t)
+ (replace-match " "))
+ ;; Translate all characters to "a".
+ (goto-char (point-min))
+ (if translate
+ (while (re-search-forward "[A-Za-z]" nil t)
+ (replace-match "a" t t)))
+ ;; Expand numbers.
+ (goto-char (point-min))
+ (while (re-search-forward "[0-9]+" nil t)
+ (replace-match
+ (format "%06d"
+ (string-to-int (buffer-substring
+ (match-beginning 0) (match-end 0))))))
+ (setq string (buffer-substring 1 (point-max)))
+ (setcar (car string-list) string)
+ (setq string-list (cdr string-list))))
+ out-list))
+
+
+;; `gnus-uu-grab-articles' is the general multi-article treatment
+;; function. It takes a list of articles to be grabbed and a function
+;; to apply to each article.
+;;
+;; The function to be called should take two parameters. The first
+;; parameter is the article buffer. The function should leave the
+;; result, if any, in this buffer. Most treatment functions will just
+;; generate files...
+;;
+;; The second parameter is the state of the list of articles, and can
+;; have four values: `first', `middle', `last' and `first-and-last'.
+;;
+;; The function should return a list. The list may contain the
+;; following symbols:
+;; `error' if an error occurred
+;; `begin' if the beginning of an encoded file has been received
+;; If the list returned contains a `begin', the first element of
+;; the list *must* be a string with the file name of the decoded
+;; file.
+;; `end' if the the end of an encoded file has been received
+;; `middle' if the article was a body part of an encoded file
+;; `wrong-type' if the article was not a part of an encoded file
+;; `ok', which can be used everything is ok
+
+(defvar gnus-uu-has-been-grabbed nil)
+
+(defun gnus-uu-unmark-list-of-grabbed (&optional dont-unmark-last-article)
+ (let (art)
+ (if (not (and gnus-uu-has-been-grabbed
+ gnus-uu-unmark-articles-not-decoded))
+ ()
+ (if dont-unmark-last-article
+ (progn
+ (setq art (car gnus-uu-has-been-grabbed))
+ (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed))))
+ (while gnus-uu-has-been-grabbed
+ (gnus-summary-tick-article (car gnus-uu-has-been-grabbed) t)
+ (setq gnus-uu-has-been-grabbed (cdr gnus-uu-has-been-grabbed)))
+ (if dont-unmark-last-article
+ (setq gnus-uu-has-been-grabbed (list art))))))
+
+;; This function takes a list of articles and a function to apply to
+;; each article grabbed.
+;;
+;; This function returns a list of files decoded if the grabbing and
+;; the process-function has been successful and nil otherwise.
+(defun gnus-uu-grab-articles
+ (articles process-function &optional sloppy limit no-errors)
+ (let ((state 'first)
+ has-been-begin article result-file result-files process-state
+ article-buffer)
+
+ (if (not (gnus-server-opened gnus-current-select-method))
+ (progn
+ (gnus-start-news-server)
+ (gnus-request-group gnus-newsgroup-name)))
+
+ (setq gnus-uu-has-been-grabbed nil)
+
+ (while (and articles
+ (not (memq 'error process-state))
+ (or sloppy
+ (not (memq 'end process-state))))
+
+ (setq article (car articles))
+ (setq articles (cdr articles))
+ (setq gnus-uu-has-been-grabbed (cons article gnus-uu-has-been-grabbed))
+
+ (if (eq articles ())
+ (if (eq state 'first)
+ (setq state 'first-and-last)
+ (setq state 'last)))
+
+ (message "Getting article %d, %s" article (gnus-uu-part-number article))
+
+ (if (not (= (or gnus-current-article 0) article))
+ (let ((nntp-async-number nil))
+ (gnus-request-article article gnus-newsgroup-name
+ nntp-server-buffer)
+ (setq gnus-last-article gnus-current-article)
+ (setq gnus-current-article article)
+ (setq gnus-article-current (cons gnus-newsgroup-name article))
+ (if (stringp nntp-server-buffer)
+ (setq article-buffer nntp-server-buffer)
+ (setq article-buffer (buffer-name nntp-server-buffer))))
+ (gnus-summary-stop-page-breaking)
+ (setq article-buffer gnus-article-buffer))
+
+ (buffer-disable-undo article-buffer)
+ ;; Mark article as read.
+ (and (memq article gnus-newsgroup-processable)
+ (gnus-summary-remove-process-mark article))
+ (run-hooks 'gnus-mark-article-hook)
+
+ (setq process-state (funcall process-function article-buffer state))
+
+ (if (or (memq 'begin process-state)
+ (and (or (eq state 'first) (eq state 'first-and-last))
+ (memq 'ok process-state)))
+ (progn
+ (if has-been-begin
+ (if (and result-file (file-exists-p result-file))
+ (delete-file result-file)))
+ (if (memq 'begin process-state)
+ (setq result-file (car process-state)))
+ (setq has-been-begin t)))
+
+ (if (memq 'end process-state)
+ (progn
+ (setq gnus-uu-has-been-grabbed nil)
+ (setq result-files (cons (list (cons 'name result-file)
+ (cons 'article article))
+ result-files))
+ (setq has-been-begin nil)
+ (and limit (= (length result-files) limit)
+ (setq articles nil))))
+
+ (if (and (or (eq state 'last) (eq state 'first-and-last))
+ (not (memq 'end process-state)))
+ (if (and result-file (file-exists-p result-file))
+ (delete-file result-file)))
+
+ (if (not (memq 'wrong-type process-state))
+ ()
+ (if gnus-uu-unmark-articles-not-decoded
+ (gnus-summary-tick-article article t)))
+
+ (if (and (not has-been-begin)
+ (not sloppy)
+ (or (memq 'end process-state)
+ (memq 'middle process-state)))
+ (progn
+ (setq process-state (list 'error))
+ (message "No begin part at the beginning")
+ (sleep-for 2))
+ (setq state 'middle)))
+
+ ;; Make sure the last article is put in the article buffer & fix
+ ;; windows etc.
+
+ (if (not (string= article-buffer gnus-article-buffer))
+ (save-excursion
+ (set-buffer (get-buffer-create gnus-article-buffer))
+ (let ((buffer-read-only nil))
+ (widen)
+ (erase-buffer)
+ (insert-buffer-substring article-buffer)
+ (gnus-set-mode-line 'article)
+ (goto-char (point-min)))))
+
+ (gnus-set-mode-line 'summary)
+
+ (if result-files
+ ()
+ (if (not has-been-begin)
+ (if (not no-errors) (message "Wrong type file"))
+ (if (memq 'error process-state)
+ (setq result-files nil)
+ (if (not (or (memq 'ok process-state)
+ (memq 'end process-state)))
+ (progn
+ (if (not no-errors)
+ (message "End of articles reached before end of file"))
+ (setq result-files nil))
+ (gnus-uu-unmark-list-of-grabbed)))))
+ result-files))
+
+(defun gnus-uu-part-number (article)
+ (let ((subject (mail-header-subject (gnus-get-header-by-number article))))
+ (if (string-match "[0-9]+ */[0-9]+\\|[0-9]+ * of *[0-9]+"
+ subject)
+ (substring subject (match-beginning 0) (match-end 0))
+ "")))
+
+(defun gnus-uu-uudecode-sentinel (process event)
+ (delete-process (get-process process)))
+
+(defun gnus-uu-uustrip-article (process-buffer in-state)
+ ;; Uudecodes a file asynchronously.
+ (let ((state (list 'ok))
+ (process-connection-type nil)
+ start-char pst name-beg name-end)
+ (save-excursion
+ (set-buffer process-buffer)
+ (let ((case-fold-search nil)
+ (buffer-read-only nil))
+
+ (goto-char (point-min))
+
+ (if gnus-uu-kill-carriage-return
+ (progn
+ (while (search-forward "\r" nil t)
+ (delete-backward-char 1))
+ (goto-char (point-min))))
+
+ (if (not (re-search-forward gnus-uu-begin-string nil t))
+ (if (not (re-search-forward gnus-uu-body-line nil t))
+ (setq state (list 'wrong-type))))
+
+ (if (memq 'wrong-type state)
+ ()
+ (beginning-of-line)
+ (setq start-char (point))
+
+ (if (looking-at gnus-uu-begin-string)
+ (progn
+ (setq name-end (match-end 1)
+ name-beg (match-beginning 1))
+ ;; Remove any non gnus-uu-body-line right after start.
+ (forward-line 1)
+ (or (looking-at gnus-uu-body-line)
+ (gnus-delete-line))
+
+ ; Replace any slashes and spaces in file names before decoding
+ (goto-char name-beg)
+ (while (re-search-forward "/" name-end t)
+ (replace-match ","))
+ (goto-char name-beg)
+ (while (re-search-forward " " name-end t)
+ (replace-match "_"))
+ (goto-char name-beg)
+ (if (re-search-forward "_*$" name-end t)
+ (replace-match ""))
+
+ (setq gnus-uu-file-name (buffer-substring name-beg name-end))
+ (and gnus-uu-uudecode-process
+ (setq pst (process-status
+ (or gnus-uu-uudecode-process "nevair")))
+ (if (or (eq pst 'stop) (eq pst 'run))
+ (progn
+ (delete-process gnus-uu-uudecode-process)
+ (gnus-uu-unmark-list-of-grabbed t))))
+ (if (get-process "*uudecode*")
+ (delete-process "*uudecode*"))
+ (setq gnus-uu-uudecode-process
+ (start-process
+ "*uudecode*"
+ (get-buffer-create gnus-uu-output-buffer-name)
+ "sh" "-c"
+ (format "cd %s ; uudecode" gnus-uu-work-dir)))
+ (set-process-sentinel
+ gnus-uu-uudecode-process 'gnus-uu-uudecode-sentinel)
+ (setq state (list 'begin))
+ (gnus-uu-add-file (concat gnus-uu-work-dir gnus-uu-file-name)))
+ (setq state (list 'middle)))
+
+ (goto-char (point-max))
+
+ (re-search-backward
+ (concat gnus-uu-body-line "\\|" gnus-uu-end-string) nil t)
+ (beginning-of-line)
+
+ (if (looking-at gnus-uu-end-string)
+ (setq state (cons 'end state)))
+ (forward-line 1)
+
+ (and gnus-uu-uudecode-process
+ (setq pst (process-status
+ (or gnus-uu-uudecode-process "nevair")))
+ (if (or (eq pst 'run) (eq pst 'stop))
+ (progn
+ (if gnus-uu-correct-stripped-uucode
+ (progn
+ (gnus-uu-check-correct-stripped-uucode
+ start-char (point))
+ (goto-char (point-max))
+ (re-search-backward
+ (concat gnus-uu-body-line "\\|"
+ gnus-uu-end-string)
+ nil t)
+ (forward-line 1)))
+
+ (condition-case nil
+ (process-send-region gnus-uu-uudecode-process
+ start-char (point))
+ (error
+ (progn
+ (delete-process gnus-uu-uudecode-process)
+ (message "gnus-uu: Couldn't uudecode")
+ ; (sleep-for 2)
+ (setq state (list 'wrong-type)))))
+
+ (if (memq 'end state)
+ (accept-process-output gnus-uu-uudecode-process)))
+ (setq state (list 'wrong-type))))
+ (if (not gnus-uu-uudecode-process)
+ (setq state (list 'wrong-type)))))
+
+ (if (memq 'begin state)
+ (cons (concat gnus-uu-work-dir gnus-uu-file-name) state)
+ state))))
+
+;; This function is used by `gnus-uu-grab-articles' to treat
+;; a shared article.
+(defun gnus-uu-unshar-article (process-buffer in-state)
+ (let ((state (list 'ok))
+ start-char)
+ (save-excursion
+ (set-buffer process-buffer)
+ (goto-char (point-min))
+ (if (not (re-search-forward gnus-uu-shar-begin-string nil t))
+ (setq state (list 'wrong-type))
+ (beginning-of-line)
+ (setq start-char (point))
+ (call-process-region
+ start-char (point-max) "sh" nil
+ (get-buffer-create gnus-uu-output-buffer-name) nil
+ "-c" (concat "cd " gnus-uu-work-dir " ; sh"))))
+ state))
+
+;; Returns the name of what the shar file is going to unpack.
+(defun gnus-uu-find-name-in-shar ()
+ (let ((oldpoint (point))
+ res)
+ (goto-char (point-min))
+ (if (re-search-forward gnus-uu-shar-name-marker nil t)
+ (setq res (buffer-substring (match-beginning 1) (match-end 1))))
+ (goto-char oldpoint)
+ res))
+
+;; `gnus-uu-choose-action' chooses what action to perform given the name
+;; and `gnus-uu-file-action-list'. Returns either nil if no action is
+;; found, or the name of the command to run if such a rule is found.
+(defun gnus-uu-choose-action (file-name file-action-list &optional no-ignore)
+ (let ((action-list (copy-sequence file-action-list))
+ (case-fold-search t)
+ rule action)
+ (and
+ (or no-ignore
+ (and (not
+ (and gnus-uu-ignore-files-by-name
+ (string-match gnus-uu-ignore-files-by-name file-name)))
+ (not
+ (and gnus-uu-ignore-files-by-type
+ (string-match gnus-uu-ignore-files-by-type
+ (or (gnus-uu-choose-action
+ file-name gnus-uu-ext-to-mime-list t)
+ ""))))))
+ (while (not (or (eq action-list ()) action))
+ (setq rule (car action-list))
+ (setq action-list (cdr action-list))
+ (if (string-match (car rule) file-name)
+ (setq action (car (cdr rule))))))
+ action))
+
+(defun gnus-uu-treat-archive (file-path)
+ ;; Unpacks an archive. Returns t if unpacking is successful.
+ (let ((did-unpack t)
+ action command dir)
+ (setq action (gnus-uu-choose-action
+ file-path (append gnus-uu-user-archive-rules
+ (if gnus-uu-ignore-default-archive-rules
+ nil
+ gnus-uu-default-archive-rules))))
+
+ (if (not action) (error "No unpackers for the file %s" file-path))
+
+ (string-match "/[^/]*$" file-path)
+ (setq dir (substring file-path 0 (match-beginning 0)))
+
+ (if (member action gnus-uu-destructive-archivers)
+ (copy-file file-path (concat file-path "~") t))
+
+ (setq command (format "cd %s ; %s" dir (gnus-uu-command action file-path)))
+
+ (save-excursion
+ (set-buffer (get-buffer-create gnus-uu-output-buffer-name))
+ (erase-buffer))
+
+ (message "Unpacking: %s..." (gnus-uu-command action file-path))
+
+ (if (= 0 (call-process "sh" nil
+ (get-buffer-create gnus-uu-output-buffer-name)
+ nil "-c" command))
+ (message "")
+ (message "Error during unpacking of archive")
+ (setq did-unpack nil))
+
+ (if (member action gnus-uu-destructive-archivers)
+ (rename-file (concat file-path "~") file-path t))
+
+ did-unpack))
+
+(defun gnus-uu-dir-files (dir)
+ (let ((dirs (directory-files dir t "[^/][^\\.][^\\.]?$"))
+ files file)
+ (while dirs
+ (if (file-directory-p (setq file (car dirs)))
+ (setq files (append files (gnus-uu-dir-files file)))
+ (setq files (cons file files)))
+ (setq dirs (cdr dirs)))
+ files))
+
+(defun gnus-uu-unpack-files (files &optional ignore)
+ ;; Go through FILES and look for files to unpack.
+ (let* ((totfiles (gnus-uu-ls-r gnus-uu-work-dir))
+ (ofiles files)
+ file did-unpack file-entry)
+ (gnus-uu-add-file totfiles)
+ (while files
+ (setq file (cdr (setq file-entry (assq 'name (car files)))))
+ (if (and (not (member file ignore))
+ (equal (gnus-uu-get-action (file-name-nondirectory file))
+ "gnus-uu-archive"))
+ (progn
+ (setq did-unpack (cons file did-unpack))
+ (or (gnus-uu-treat-archive file)
+ (message "Error during unpacking of %s" file))
+ (let* ((newfiles (gnus-uu-ls-r gnus-uu-work-dir))
+ (nfiles newfiles))
+ (gnus-uu-add-file newfiles)
+ (while nfiles
+ (or (member (car nfiles) totfiles)
+ (setq ofiles (cons (list (cons 'name (car nfiles))
+ (cons 'original file))
+ ofiles)))
+ (setq nfiles (cdr nfiles)))
+ (setq totfiles newfiles))))
+ (setq files (cdr files)))
+ (if did-unpack
+ (gnus-uu-unpack-files ofiles (append did-unpack ignore))
+ ofiles)))
+
+(defun gnus-uu-ls-r (dir)
+ (let* ((files (gnus-uu-directory-files dir t))
+ (ofiles files))
+ (while files
+ (if (file-directory-p (car files))
+ (progn
+ (setq ofiles (delete (car files) ofiles))
+ (setq ofiles (append ofiles (gnus-uu-ls-r (car files))))))
+ (setq files (cdr files)))
+ ofiles))
+
+;; Various stuff
+
+(defun gnus-uu-directory-files (dir &optional full)
+ (let (files out file)
+ (setq files (directory-files dir full))
+ (while files
+ (setq file (car files))
+ (setq files (cdr files))
+ (or (string-match "/\\.\\.?$" file)
+ (setq out (cons file out))))
+ (setq out (nreverse out))
+ out))
+
+(defun gnus-uu-check-correct-stripped-uucode (start end)
+ (let (found beg length)
+ (if (not gnus-uu-correct-stripped-uucode)
+ ()
+ (goto-char start)
+
+ (if (re-search-forward " \\|`" end t)
+ (progn
+ (goto-char start)
+ (while (not (eobp))
+ (progn
+ (if (looking-at "\n") (replace-match ""))
+ (forward-line 1))))
+
+ (while (not (eobp))
+ (if (looking-at (concat gnus-uu-begin-string "\\|"
+ gnus-uu-end-string))
+ ()
+ (if (not found)
+ (progn
+ (beginning-of-line)
+ (setq beg (point))
+ (end-of-line)
+ (setq length (- (point) beg))))
+ (setq found t)
+ (beginning-of-line)
+ (setq beg (point))
+ (end-of-line)
+ (if (not (= length (- (point) beg)))
+ (insert (make-string (- length (- (point) beg)) ? ))))
+ (forward-line 1))))))
+
+(defvar gnus-uu-tmp-alist nil)
+
+(defun gnus-uu-initialize (&optional scan)
+ (let (entry)
+ (if (and (not scan)
+ (if (setq entry (assoc gnus-newsgroup-name gnus-uu-tmp-alist))
+ (if (file-exists-p (cdr entry))
+ (setq gnus-uu-work-dir (cdr entry))
+ (setq gnus-uu-tmp-alist (delq entry gnus-uu-tmp-alist))
+ nil)))
+ t
+ (setq gnus-uu-tmp-dir (file-name-as-directory
+ (expand-file-name gnus-uu-tmp-dir)))
+ (if (not (file-directory-p gnus-uu-tmp-dir))
+ (error "Temp directory %s doesn't exist" gnus-uu-tmp-dir)
+ (if (not (file-writable-p gnus-uu-tmp-dir))
+ (error "Temp directory %s can't be written to"
+ gnus-uu-tmp-dir)))
+
+ (setq gnus-uu-work-dir
+ (make-temp-name (concat gnus-uu-tmp-dir "gnus")))
+ (gnus-uu-add-file gnus-uu-work-dir)
+ (if (not (file-directory-p gnus-uu-work-dir))
+ (gnus-make-directory gnus-uu-work-dir))
+ (set-file-modes gnus-uu-work-dir 448)
+ (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir))
+ (setq gnus-uu-tmp-alist (cons (cons gnus-newsgroup-name gnus-uu-work-dir)
+ gnus-uu-tmp-alist)))))
+
+
+;; Kills the temporary uu buffers, kills any processes, etc.
+(defun gnus-uu-clean-up ()
+ (let (buf pst)
+ (and gnus-uu-uudecode-process
+ (setq pst (process-status (or gnus-uu-uudecode-process "nevair")))
+ (if (or (eq pst 'stop) (eq pst 'run))
+ (delete-process gnus-uu-uudecode-process)))
+ (and (setq buf (get-buffer gnus-uu-output-buffer-name))
+ (kill-buffer buf))))
+
+;; `gnus-uu-check-for-generated-files' deletes any generated files that
+;; hasn't been deleted, if, for instance, the user terminated decoding
+;; with `C-g'.
+(defun gnus-uu-check-for-generated-files ()
+ (let (file dirs)
+ (while gnus-uu-generated-file-list
+ (setq file (car gnus-uu-generated-file-list))
+ (setq gnus-uu-generated-file-list (cdr gnus-uu-generated-file-list))
+ (if (not (string-match "/\\.[\\.]?$" file))
+ (progn
+ (if (file-directory-p file)
+ (setq dirs (cons file dirs))
+ (if (file-exists-p file)
+ (delete-file file))))))
+ (setq dirs (nreverse dirs))
+ (while dirs
+ (setq file (car dirs))
+ (setq dirs (cdr dirs))
+ (if (file-directory-p file)
+ (if (string-match "/$" file)
+ (delete-directory (substring file 0 (match-beginning 0)))
+ (delete-directory file))))))
+
+;; Add a file (or a list of files) to be checked (and deleted if it/they
+;; still exists upon exiting the newsgroup).
+(defun gnus-uu-add-file (file)
+ (if (stringp file)
+ (setq gnus-uu-generated-file-list
+ (cons file gnus-uu-generated-file-list))
+ (setq gnus-uu-generated-file-list
+ (append file gnus-uu-generated-file-list))))
+
+;; Inputs an action and a file and returns a full command, putting
+;; quotes round the file name and escaping any quotes in the file name.
+(defun gnus-uu-command (action file)
+ (let ((ofile ""))
+ (while (string-match "!\\|`\\|\"\\|\\$\\|\\\\\\|&" file)
+ (progn
+ (setq ofile
+ (concat ofile (substring file 0 (match-beginning 0)) "\\"
+ (substring file (match-beginning 0) (match-end 0))))
+ (setq file (substring file (1+ (match-beginning 0))))))
+ (setq ofile (concat "\"" ofile file "\""))
+ (if (string-match "%s" action)
+ (format action ofile)
+ (concat action " " ofile))))
+
+
+;; Initializing
+
+(add-hook 'gnus-exit-group-hook 'gnus-uu-clean-up)
+(add-hook 'gnus-exit-group-hook 'gnus-uu-check-for-generated-files)
+
+
+
+;;;
+;;; uuencoded posting
+;;;
+
+(require 'sendmail)
+(require 'rnews)
+
+;; Any function that is to be used as and encoding method will take two
+;; parameters: PATH-NAME and FILE-NAME. (E.g. "/home/gaga/spiral.jpg"
+;; and "spiral.jpg", respectively.) The function should return nil if
+;; the encoding wasn't successful.
+(defvar gnus-uu-post-encode-method 'gnus-uu-post-encode-uuencode
+ "Function used for encoding binary files.
+There are three functions supplied with gnus-uu for encoding files:
+`gnus-uu-post-encode-uuencode', which does straight uuencoding;
+`gnus-uu-post-encode-mime', which encodes with base64 and adds MIME
+headers; and `gnus-uu-post-encode-mime-uuencode', which encodes with
+uuencode and adds MIME headers.")
+
+(defvar gnus-uu-post-include-before-composing nil
+ "Non-nil means that gnus-uu will ask for a file to encode before you compose the article.
+If this variable is t, you can either include an encoded file with
+\\[gnus-uu-post-insert-binary-in-article] or have one included for you when you post the article.")
+
+(defvar gnus-uu-post-length 990
+ "Maximum length of an article.
+The encoded file will be split into how many articles it takes to
+post the entire file.")
+
+(defvar gnus-uu-post-threaded nil
+ "Non-nil means that gnus-uu will post the encoded file in a thread.
+This may not be smart, as no other decoder I have seen are able to
+follow threads when collecting uuencoded articles. (Well, I have seen
+one package that does that - gnus-uu, but somehow, I don't think that
+counts...) Default is nil.")
+
+(defvar gnus-uu-post-separate-description t
+ "Non-nil means that the description will be posted in a separate article.
+The first article will typically be numbered (0/x). If this variable
+is nil, the description the user enters will be included at the
+beginning of the first article, which will be numbered (1/x). Default
+is t.")
+
+(defvar gnus-uu-post-binary-separator "--binary follows this line--")
+(defvar gnus-uu-post-message-id nil)
+(defvar gnus-uu-post-inserted-file-name nil)
+(defvar gnus-uu-winconf-post-news nil)
+
+(defun gnus-uu-post-news ()
+ "Compose an article and post an encoded file."
+ (interactive)
+ (setq gnus-uu-post-inserted-file-name nil)
+ (setq gnus-uu-winconf-post-news (current-window-configuration))
+
+ (gnus-summary-post-news)
+
+ (use-local-map (copy-keymap (current-local-map)))
+ (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done)
+ (local-set-key "\C-c\C-c" 'gnus-uu-post-news-inews)
+ (local-set-key "\C-c\C-s" 'gnus-uu-post-news-inews)
+ (local-set-key "\C-c\C-i" 'gnus-uu-post-insert-binary-in-article)
+
+ (if gnus-uu-post-include-before-composing
+ (save-excursion (setq gnus-uu-post-inserted-file-name
+ (gnus-uu-post-insert-binary)))))
+
+(defun gnus-uu-post-insert-binary-in-article ()
+ "Inserts an encoded file in the buffer.
+The user will be asked for a file name."
+ (interactive)
+ (if (not (eq (current-buffer) (get-buffer gnus-post-news-buffer)))
+ (error "Not in post-news buffer"))
+ (save-excursion
+ (setq gnus-uu-post-inserted-file-name (gnus-uu-post-insert-binary))))
+
+;; Encodes with uuencode and substitutes all spaces with backticks.
+(defun gnus-uu-post-encode-uuencode (path file-name)
+ (if (gnus-uu-post-encode-file "uuencode" path file-name)
+ (progn
+ (goto-char (point-min))
+ (forward-line 1)
+ (while (re-search-forward " " nil t)
+ (replace-match "`"))
+ t)))
+
+;; Encodes with uuencode and adds MIME headers.
+(defun gnus-uu-post-encode-mime-uuencode (path file-name)
+ (if (gnus-uu-post-encode-uuencode path file-name)
+ (progn
+ (gnus-uu-post-make-mime file-name "x-uue")
+ t)))
+
+;; Encodes with base64 and adds MIME headers
+(defun gnus-uu-post-encode-mime (path file-name)
+ (if (gnus-uu-post-encode-file "mmencode" path file-name)
+ (progn
+ (gnus-uu-post-make-mime file-name "base64")
+ t)))
+
+;; Adds MIME headers.
+(defun gnus-uu-post-make-mime (file-name encoding)
+ (goto-char (point-min))
+ (insert (format "Content-Type: %s; name=\"%s\"\n"
+ (gnus-uu-choose-action file-name gnus-uu-ext-to-mime-list)
+ file-name))
+ (insert (format "Content-Transfer-Encoding: %s\n\n" encoding))
+ (save-restriction
+ (set-buffer gnus-post-news-buffer)
+ (goto-char (point-min))
+ (re-search-forward (concat "^" (regexp-quote mail-header-separator) "$"))
+ (forward-line -1)
+ (narrow-to-region 1 (point))
+ (or (mail-fetch-field "mime-version")
+ (progn
+ (widen)
+ (insert "MIME-Version: 1.0\n")))
+ (widen)))
+
+;; Encodes a file PATH with COMMAND, leaving the result in the
+;; current buffer.
+(defun gnus-uu-post-encode-file (command path file-name)
+ (= 0 (call-process "sh" nil t nil "-c"
+ (format "%s %s %s" command path file-name))))
+
+(defun gnus-uu-post-news-inews ()
+ "Posts the composed news article and encoded file.
+If no file has been included, the user will be asked for a file."
+ (interactive)
+ (if (not (eq (current-buffer) (get-buffer gnus-post-news-buffer)))
+ (error "Not in post news buffer"))
+
+ (let (file-name)
+
+ (if gnus-uu-post-inserted-file-name
+ (setq file-name gnus-uu-post-inserted-file-name)
+ (setq file-name (gnus-uu-post-insert-binary)))
+
+ (if gnus-uu-post-threaded
+ (let ((gnus-required-headers
+ (if (memq 'Message-ID gnus-required-headers)
+ gnus-required-headers
+ (cons 'Message-ID gnus-required-headers)))
+ gnus-inews-article-hook)
+
+ (setq gnus-inews-article-hook (if (listp gnus-inews-article-hook)
+ gnus-inews-article-hook
+ (list gnus-inews-article-hook)))
+ (setq gnus-inews-article-hook
+ (cons
+ '(lambda ()
+ (save-excursion
+ (goto-char (point-min))
+ (if (re-search-forward "^Message-ID: \\(.*\\)$" nil t)
+ (setq gnus-uu-post-message-id
+ (buffer-substring
+ (match-beginning 1) (match-end 1)))
+ (setq gnus-uu-post-message-id nil))))
+ gnus-inews-article-hook))
+ (gnus-uu-post-encoded file-name t))
+ (gnus-uu-post-encoded file-name nil)))
+ (setq gnus-uu-post-inserted-file-name nil)
+ (and gnus-uu-winconf-post-news
+ (set-window-configuration gnus-uu-winconf-post-news)))
+
+;; Asks for a file to encode, encodes it and inserts the result in
+;; the current buffer. Returns the file name the user gave.
+(defun gnus-uu-post-insert-binary ()
+ (let ((uuencode-buffer-name "*uuencode buffer*")
+ file-path uubuf file-name)
+
+ (setq file-path (read-file-name
+ "What file do you want to encode? "))
+ (if (not (file-exists-p file-path))
+ (error "%s: No such file" file-path))
+
+ (goto-char (point-max))
+ (insert (format "\n%s\n" gnus-uu-post-binary-separator))
+
+ (if (string-match "^~/" file-path)
+ (setq file-path (concat "$HOME" (substring file-path 1))))
+ (if (string-match "/[^/]*$" file-path)
+ (setq file-name (substring file-path (1+ (match-beginning 0))))
+ (setq file-name file-path))
+
+ (unwind-protect
+ (if (save-excursion
+ (set-buffer (setq uubuf
+ (get-buffer-create uuencode-buffer-name)))
+ (erase-buffer)
+ (funcall gnus-uu-post-encode-method file-path file-name))
+ (insert-buffer uubuf)
+ (error "Encoding unsuccessful"))
+ (kill-buffer uubuf))
+ file-name))
+
+;; Posts the article and all of the encoded file.
+(defun gnus-uu-post-encoded (file-name &optional threaded)
+ (let ((send-buffer-name "*uuencode send buffer*")
+ (encoded-buffer-name "*encoded buffer*")
+ (top-string "[ cut here %s (%s %d/%d) %s gnus-uu ]")
+ (separator (concat mail-header-separator "\n\n"))
+ uubuf length parts header i end beg
+ beg-line minlen buf post-buf whole-len beg-binary end-binary)
+
+ (setq post-buf (current-buffer))
+
+ (goto-char (point-min))
+ (if (not (re-search-forward
+ (if gnus-uu-post-separate-description
+ (concat "^" (regexp-quote gnus-uu-post-binary-separator)
+ "$")
+ (concat "^" (regexp-quote mail-header-separator) "$")) nil t))
+ (error "Internal error: No binary/header separator"))
+ (beginning-of-line)
+ (forward-line 1)
+ (setq beg-binary (point))
+ (setq end-binary (point-max))
+
+ (save-excursion
+ (set-buffer (setq uubuf (get-buffer-create encoded-buffer-name)))
+ (erase-buffer)
+ (insert-buffer-substring post-buf beg-binary end-binary)
+ (goto-char (point-min))
+ (setq length (count-lines 1 (point-max)))
+ (setq parts (/ length gnus-uu-post-length))
+ (if (not (< (% length gnus-uu-post-length) 4))
+ (setq parts (1+ parts))))
+
+ (if gnus-uu-post-separate-description
+ (forward-line -1))
+ (kill-region (point) (point-max))
+
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$") nil t)
+ (beginning-of-line)
+ (setq header (buffer-substring 1 (point)))
+
+ (goto-char (point-min))
+ (if (not gnus-uu-post-separate-description)
+ ()
+ (if (and (not threaded) (re-search-forward "^Subject: " nil t))
+ (progn
+ (end-of-line)
+ (insert (format " (0/%d)" parts))))
+ (gnus-inews-news))
+
+ (save-excursion
+ (setq i 1)
+ (setq beg 1)
+ (while (not (> i parts))
+ (set-buffer (get-buffer-create send-buffer-name))
+ (erase-buffer)
+ (insert header)
+ (if (and threaded gnus-uu-post-message-id)
+ (insert (format "References: %s\n" gnus-uu-post-message-id)))
+ (insert separator)
+ (setq whole-len
+ (- 62 (length (format top-string "" file-name i parts ""))))
+ (if (> 1 (setq minlen (/ whole-len 2)))
+ (setq minlen 1))
+ (setq
+ beg-line
+ (format top-string
+ (make-string minlen ?-)
+ file-name i parts
+ (make-string
+ (if (= 0 (% whole-len 2)) (1- minlen) minlen) ?-)))
+
+ (goto-char (point-min))
+ (if (not (re-search-forward "^Subject: " nil t))
+ ()
+ (if (not threaded)
+ (progn
+ (end-of-line)
+ (insert (format " (%d/%d)" i parts)))
+ (if (or (and (= i 2) gnus-uu-post-separate-description)
+ (and (= i 1) (not gnus-uu-post-separate-description)))
+ (replace-match "Subject: Re: "))))
+
+ (goto-char (point-max))
+ (save-excursion
+ (set-buffer uubuf)
+ (goto-char beg)
+ (if (= i parts)
+ (goto-char (point-max))
+ (forward-line gnus-uu-post-length))
+ (if (and (= (1+ i) parts) (< (count-lines (point) (point-max)) 4))
+ (forward-line -4))
+ (setq end (point)))
+ (insert-buffer-substring uubuf beg end)
+ (insert beg-line)
+ (insert "\n")
+ (setq beg end)
+ (setq i (1+ i))
+ (goto-char (point-min))
+ (re-search-forward
+ (concat "^" (regexp-quote mail-header-separator) "$") nil t)
+ (beginning-of-line)
+ (forward-line 2)
+ (if (re-search-forward
+ (concat "^" (regexp-quote gnus-uu-post-binary-separator) "$")
+ nil t)
+ (progn
+ (replace-match "")
+ (forward-line 1)))
+ (insert beg-line)
+ (insert "\n")
+ (gnus-inews-news)))
+
+ (and (setq buf (get-buffer send-buffer-name))
+ (kill-buffer buf))
+ (and (setq buf (get-buffer encoded-buffer-name))
+ (kill-buffer buf))
+
+ (if (not gnus-uu-post-separate-description)
+ (progn
+ (set-buffer-modified-p nil)
+ (and (fboundp 'bury-buffer) (bury-buffer))))))
+
+(provide 'gnus-uu)
+
+;; gnus-uu.el ends here
diff --git a/lisp/gnus-vis.el b/lisp/gnus-vis.el
new file mode 100644
index 00000000000..7577dd22e9b
--- /dev/null
+++ b/lisp/gnus-vis.el
@@ -0,0 +1,1428 @@
+;;; gnus-vis.el --- display-oriented parts of Gnus
+;; Copyright (C) 1995 Free Software Foundation, Inc.
+
+;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+;; Per Abrahamsen <abraham@iesd.auc.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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'gnus)
+(require 'gnus-ems)
+(require 'easymenu)
+(require 'custom)
+
+(defvar gnus-group-menu-hook nil
+ "*Hook run after the creation of the group mode menu.")
+
+(defvar gnus-summary-menu-hook nil
+ "*Hook run after the creation of the summary mode menu.")
+
+(defvar gnus-article-menu-hook nil
+ "*Hook run after the creation of the article mode menu.")
+
+(defvar gnus-server-menu-hook nil
+ "*Hook run after the creation of the server mode menu.")
+
+(defvar gnus-browse-menu-hook nil
+ "*Hook run after the creation of the browse mode menu.")
+
+;;; Summary highlights.
+
+;(defvar gnus-summary-highlight-properties
+; '((unread "ForestGreen" "green")
+; (ticked "Firebrick" "pink")
+; (read "black" "white")
+; (low italic italic)
+; (high bold bold)
+; (canceled "yellow/black" "black/yellow")))
+
+;(defvar gnus-summary-highlight-translation
+; '(((unread (= mark gnus-unread-mark))
+; (ticked (or (= mark gnus-ticked-mark) (= mark gnus-dormant-mark)))
+; (read (not (or (= mark gnus-unread-mark) (= mark gnus-dormant-mark)
+; (= mark gnus-ticked-mark) (= mark gnus-canceled-mark))))
+; (canceled (= mark gnus-canceled-mark)))
+; ((low (< score gnus-summary-default-score))
+; (high (> score gnus-summary-default-score)))))
+
+;(defun gnus-visual-map-face-translation ()
+; (let ((props gnus-summary-highlight-properties)
+; (trans gnus-summary-highlight-translation)
+; map)
+; (while props)))
+
+;see gnus-cus.el
+;(defvar gnus-summary-selected-face 'underline
+; "*Face used for highlighting the current article in the summary buffer.")
+
+;see gnus-cus.el
+;(defvar gnus-summary-highlight
+; (cond ((not (eq gnus-display-type 'color))
+; '(((> score default) . bold)
+; ((< score default) . italic)))
+; ((eq gnus-background-mode 'dark)
+; (list (cons '(= mark gnus-canceled-mark)
+; (custom-face-lookup "yellow" "black" nil nil nil nil))
+; (cons '(and (> score default)
+; (or (= mark gnus-dormant-mark)
+; (= mark gnus-ticked-mark)))
+; (custom-face-lookup "pink" nil nil t nil nil))
+; (cons '(and (< score default)
+; (or (= mark gnus-dormant-mark)
+; (= mark gnus-ticked-mark)))
+; (custom-face-lookup "pink" nil nil nil t nil))
+; (cons '(or (= mark gnus-dormant-mark)
+; (= mark gnus-ticked-mark))
+; (custom-face-lookup "pink" nil nil nil nil nil))
+
+; (cons '(and (> score default) (= mark gnus-ancient-mark))
+; (custom-face-lookup "SkyBlue" nil nil t nil nil))
+; (cons '(and (< score default) (= mark gnus-ancient-mark))
+; (custom-face-lookup "SkyBlue" nil nil nil t nil))
+; (cons '(= mark gnus-ancient-mark)
+; (custom-face-lookup "SkyBlue" nil nil nil nil nil))
+
+; (cons '(and (> score default) (= mark gnus-unread-mark))
+; (custom-face-lookup "white" nil nil t nil nil))
+; (cons '(and (< score default) (= mark gnus-unread-mark))
+; (custom-face-lookup "white" nil nil nil t nil))
+; (cons '(= mark gnus-unread-mark)
+; (custom-face-lookup "white" nil nil nil nil nil))
+
+; (cons '(> score default) 'bold)
+; (cons '(< score default) 'italic)))
+; (t
+; (list (cons '(= mark gnus-canceled-mark)
+; (custom-face-lookup "yellow" "black" nil nil nil nil))
+; (cons '(and (> score default)
+; (or (= mark gnus-dormant-mark)
+; (= mark gnus-ticked-mark)))
+; (custom-face-lookup "firebrick" nil nil t nil nil))
+; (cons '(and (< score default)
+; (or (= mark gnus-dormant-mark)
+; (= mark gnus-ticked-mark)))
+; (custom-face-lookup "firebrick" nil nil nil t nil))
+; (cons '(or (= mark gnus-dormant-mark)
+; (= mark gnus-ticked-mark))
+; (custom-face-lookup "firebrick" nil nil nil nil nil))
+
+; (cons '(and (> score default) (= mark gnus-ancient-mark))
+; (custom-face-lookup "RoyalBlue" nil nil t nil nil))
+; (cons '(and (< score default) (= mark gnus-ancient-mark))
+; (custom-face-lookup "RoyalBlue" nil nil nil t nil))
+; (cons '(= mark gnus-ancient-mark)
+; (custom-face-lookup "RoyalBlue" nil nil nil nil nil))
+
+; (cons '(and (> score default) (/= mark gnus-unread-mark))
+; (custom-face-lookup "DarkGreen" nil nil t nil nil))
+; (cons '(and (< score default) (/= mark gnus-unread-mark))
+; (custom-face-lookup "DarkGreen" nil nil nil t nil))
+; (cons '(/= mark gnus-unread-mark)
+; (custom-face-lookup "DarkGreen" nil nil nil nil nil))
+
+; (cons '(> score default) 'bold)
+; (cons '(< score default) 'italic))))
+; "*Alist of `(FORM . FACE)'.
+;Summary lines are highlighted with the FACE for the first FORM which
+;evaluate to a non-nil value.
+
+;Point will be at the beginning of the line when FORM is evaluated.
+;The following can be used for convenience:
+
+;score: (gnus-summary-article-score)
+;default: gnus-summary-default-score
+;below: gnus-summary-mark-below
+;mark: (gnus-summary-article-mark)
+
+;The latter can be used like this:
+; ((= mark gnus-replied-mark) . underline)")
+
+;;; article highlights
+
+;see gnus-cus.el
+;(defvar gnus-header-face-alist
+; (cond ((not (eq gnus-display-type 'color))
+; '(("" bold italic)))
+; ((eq gnus-background-mode 'dark)
+; (list (list "From" nil
+; (custom-face-lookup "SkyBlue" nil nil t t nil))
+; (list "Subject" nil
+; (custom-face-lookup "pink" nil nil t t nil))
+; (list "Newsgroups:.*," nil
+; (custom-face-lookup "yellow" nil nil t t nil))
+; (list ""
+; (custom-face-lookup "cyan" nil nil t nil nil)
+; (custom-face-lookup "green" nil nil nil t nil))))
+; (t
+; (list (list "From" nil
+; (custom-face-lookup "RoyalBlue" nil nil t t nil))
+; (list "Subject" nil
+; (custom-face-lookup "firebrick" nil nil t t nil))
+; (list "Newsgroups:.*," nil
+; (custom-face-lookup "red" nil nil t t nil))
+; (list ""
+; (custom-face-lookup "DarkGreen" nil nil t nil nil)
+; (custom-face-lookup "DarkGreen" nil nil nil t nil)))))
+; "Alist of headers and faces used for highlighting them.
+;The entries in the list has the form `(REGEXP NAME CONTENT)', where
+;REGEXP is a regular expression matching the beginning of the header,
+;NAME is the face used for highlighting the header name and CONTENT is
+;the face used for highlighting the header content.
+
+;The first non-nil NAME or CONTENT with a matching REGEXP in the list
+;will be used.")
+
+
+;see gnus-cus.el
+;(defvar gnus-make-foreground t
+; "Non nil means foreground color to highlight citations.")
+
+;see gnus-cus.el
+;(defvar gnus-article-button-face 'bold
+; "Face used for text buttons.")
+
+;see gnus-cus.el
+;(defvar gnus-article-mouse-face (if (boundp 'gnus-mouse-face)
+; gnus-mouse-face
+; 'highlight)
+; "Face used when the mouse is over the button.")
+
+;see gnus-cus.el
+;(defvar gnus-signature-face 'italic
+; "Face used for signature.")
+
+(defvar gnus-button-alist
+ '(("in\\( +article\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
+ (assq (count-lines (point-min) (match-end 0))
+ gnus-cite-attribution-alist)
+ gnus-button-message-id 3)
+ ;; This is how URLs _should_ be embedded in text...
+ ("<URL:\\([^\n\r>]*\\)>" 0 t gnus-button-url 1)
+ ;; Next regexp stolen from highlight-headers.el.
+ ;; Modified by Vladimir Alexiev.
+ ("\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]" 0 t gnus-button-url 0))
+ "Alist of regexps matching buttons in an article.
+
+Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
+REGEXP: is the string matching text around the button,
+BUTTON: is the number of the regexp grouping actually matching the button,
+FORM: is a lisp expression which must eval to true for the button to
+be added,
+CALLBACK: is the function to call when the user push this button, and each
+PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
+
+CALLBACK can also be a variable, in that case the value of that
+variable it the real callback function.")
+
+;see gnus-cus.el
+;(eval-when-compile
+; (defvar browse-url-browser-function))
+
+;see gnus-cus.el
+;(defvar gnus-button-url
+; (cond ((boundp 'browse-url-browser-function) browse-url-browser-function)
+; ((fboundp 'w3-fetch) 'w3-fetch)
+; ((eq window-system 'x) 'gnus-netscape-open-url))
+; "*Function to fetch URL.
+;The function will be called with one argument, the URL to fetch.
+;Useful values of this function are:
+
+;w3-fetch:
+; defined in the w3 emacs package by William M. Perry.
+;gnus-netscape-open-url:
+; open url in existing netscape, start netscape if none found.
+;gnus-netscape-start-url:
+; start new netscape with url.")
+
+
+
+(eval-and-compile
+ (autoload 'nnkiboze-generate-groups "nnkiboze")
+ (autoload 'gnus-cite-parse-maybe "gnus-cite" nil t))
+
+;;;
+;;; gnus-menu
+;;;
+
+(defun gnus-visual-turn-off-edit-menu (type)
+ (define-key (symbol-value (intern (format "gnus-%s-mode-map" type)))
+ [menu-bar edit] 'undefined))
+
+;; Newsgroup buffer
+
+(defun gnus-group-make-menu-bar ()
+ (gnus-visual-turn-off-edit-menu 'group)
+ (or
+ (boundp 'gnus-group-reading-menu)
+ (progn
+ (easy-menu-define
+ gnus-group-reading-menu
+ gnus-group-mode-map
+ ""
+ '("Group"
+ ["Read" gnus-group-read-group t]
+ ["Select" gnus-group-select-group t]
+ ["See old articles" gnus-group-select-group-all t]
+ ["Catch up" gnus-group-catchup-current t]
+ ["Catch up all articles" gnus-group-catchup-current-all t]
+ ["Check for new articles" gnus-group-get-new-news-this-group t]
+ ["Toggle subscription" gnus-group-unsubscribe-current-group t]
+ ["Kill" gnus-group-kill-group t]
+ ["Yank" gnus-group-yank-group t]
+ ["Describe" gnus-group-describe-group t]
+ ["Fetch FAQ" gnus-group-fetch-faq t]
+ ["Edit kill file" gnus-group-edit-local-kill t]
+ ["Expire articles" gnus-group-expire-articles t]
+ ["Set group level" gnus-group-set-current-level t]
+ ))
+
+ (easy-menu-define
+ gnus-group-group-menu
+ gnus-group-mode-map
+ ""
+ '("Groups"
+ ("Listing"
+ ["List subscribed groups" gnus-group-list-groups t]
+ ["List all groups" gnus-group-list-all-groups t]
+ ["List groups matching..." gnus-group-list-matching t]
+ ["List killed groups" gnus-group-list-killed t]
+ ["List zombie groups" gnus-group-list-zombies t]
+ ["Describe all groups" gnus-group-describe-all-groups t]
+ ["Group apropos" gnus-group-apropos t]
+ ["Group and description apropos" gnus-group-description-apropos t]
+ ["List groups matching..." gnus-group-list-matching t])
+ ("Mark"
+ ["Mark group" gnus-group-mark-group t]
+ ["Unmark group" gnus-group-unmark-group t]
+ ["Mark region" gnus-group-mark-region t])
+ ("Subscribe"
+ ["Subscribe to random group" gnus-group-unsubscribe-group t]
+ ["Kill all newsgroups in region" gnus-group-kill-region t]
+ ["Kill all zombie groups" gnus-group-kill-all-zombies t])
+ ("Foreign groups"
+ ["Make a foreign group" gnus-group-make-group t]
+ ["Add a directory group" gnus-group-make-directory-group t]
+ ["Add the help group" gnus-group-make-help-group t]
+ ["Add the archive group" gnus-group-make-archive-group t]
+ ["Make a doc group" gnus-group-make-doc-group t]
+ ["Make a kiboze group" gnus-group-make-kiboze-group t]
+ ["Make a virtual group" gnus-group-make-empty-virtual t]
+ ["Add a group to a virtual" gnus-group-add-to-virtual t])
+ ("Editing groups"
+ ["Parameters" gnus-group-edit-group-parameters t]
+ ["Select method" gnus-group-edit-group-method t]
+ ["Info" gnus-group-edit-group t])
+ ["Read a directory as a group" gnus-group-enter-directory t]
+ ["Jump to group" gnus-group-jump-to-group t]
+ ["Best unread group" gnus-group-best-unread-group t]
+ ))
+
+ (easy-menu-define
+ gnus-group-misc-menu
+ gnus-group-mode-map
+ ""
+ '("Misc"
+ ["Send a bug report" gnus-bug t]
+ ["Send a mail" gnus-group-mail t]
+ ["Post an article" gnus-group-post-news t]
+ ["Customize score file" gnus-score-customize
+ (not (string-match "XEmacs" emacs-version)) ]
+ ["Check for new news" gnus-group-get-new-news t]
+ ["Delete bogus groups" gnus-group-check-bogus-groups t]
+ ["Find new newsgroups" gnus-find-new-newsgroups t]
+ ["Restart Gnus" gnus-group-restart t]
+ ["Read init file" gnus-group-read-init-file t]
+ ["Browse foreign server" gnus-group-browse-foreign-server t]
+ ["Enter server buffer" gnus-group-enter-server-mode t]
+ ["Expire expirable articles" gnus-group-expire-all-groups t]
+ ["Generate any kiboze groups" nnkiboze-generate-groups t]
+ ["Gnus version" gnus-version t]
+ ["Save .newsrc files" gnus-group-save-newsrc t]
+ ["Suspend Gnus" gnus-group-suspend t]
+ ["Clear dribble buffer" gnus-group-clear-dribble t]
+ ["Exit from Gnus" gnus-group-exit t]
+ ["Exit without saving" gnus-group-quit t]
+ ["Edit global kill file" gnus-group-edit-global-kill t]
+ ["Sort group buffer" gnus-group-sort-groups t]
+ ))
+ (run-hooks 'gnus-group-menu-hook)
+ )))
+
+;; Server mode
+(defun gnus-server-make-menu-bar ()
+ (gnus-visual-turn-off-edit-menu 'server)
+ (or
+ (boundp 'gnus-server-menu)
+ (progn
+ (easy-menu-define
+ gnus-server-menu
+ gnus-server-mode-map
+ ""
+ '("Server"
+ ["Add" gnus-server-add-server t]
+ ["Browse" gnus-server-read-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]
+ ["Exit" gnus-server-exit t]
+ ))
+ (run-hooks 'gnus-server-menu-hook)
+ )))
+
+;; Browse mode
+(defun gnus-browse-make-menu-bar ()
+ (gnus-visual-turn-off-edit-menu 'browse)
+ (or
+ (boundp 'gnus-browse-menu)
+ (progn
+ (easy-menu-define
+ gnus-browse-menu
+ gnus-browse-mode-map
+ ""
+ '("Browse"
+ ["Subscribe" gnus-browse-unsubscribe-current-group t]
+ ["Read" gnus-group-read-group t]
+ ["Exit" gnus-browse-exit t]
+ ))
+ (run-hooks 'gnus-browse-menu-hook)
+ )))
+
+
+;; Summary buffer
+(defun gnus-summary-make-menu-bar ()
+ (gnus-visual-turn-off-edit-menu 'summary)
+
+ (or
+ (boundp 'gnus-summary-misc-menu)
+ (progn
+
+ (easy-menu-define
+ gnus-summary-misc-menu
+ gnus-summary-mode-map
+ ""
+ '("Misc"
+ ("Mark"
+ ("Read"
+ ["Mark as read" gnus-summary-mark-as-read-forward t]
+ ["Mark same subject and select" gnus-summary-kill-same-subject-and-select t]
+ ["Mark same subject" gnus-summary-kill-same-subject t]
+ ["Catchup" gnus-summary-catchup t]
+ ["Catchup all" gnus-summary-catchup-all t]
+ ["Catchup to here" gnus-summary-catchup-to-here t]
+ ["Catchup region" gnus-summary-mark-region-as-read t])
+ ("Various"
+ ["Tick" gnus-summary-tick-article-forward t]
+ ["Mark as dormant" gnus-summary-mark-as-dormant t]
+ ["Remove marks" gnus-summary-clear-mark-forward t]
+ ["Set expirable mark" gnus-summary-mark-as-expirable t]
+ ["Set bookmark" gnus-summary-set-bookmark t]
+ ["Remove bookmark" gnus-summary-remove-bookmark t])
+ ("Display"
+ ["Remove lines marked as read" gnus-summary-remove-lines-marked-as-read t]
+ ["Remove lines marked with..." gnus-summary-remove-lines-marked-with t]
+ ["Show dormant articles" gnus-summary-show-all-dormant t]
+ ["Hide dormant articles" gnus-summary-hide-all-dormant t]
+ ["Show expunged articles" gnus-summary-show-all-expunged t])
+ ("Process mark"
+ ["Set mark" gnus-summary-mark-as-processable t]
+ ["Remove mark" gnus-summary-unmark-as-processable t]
+ ["Remove all marks" gnus-summary-unmark-all-processable t]
+ ["Mark series" gnus-uu-mark-series t]
+ ["Mark region" gnus-uu-mark-region t]
+ ["Mark by regexp" gnus-uu-mark-by-regexp t]
+ ["Mark all" gnus-uu-mark-all t]
+ ["Mark sparse" gnus-uu-mark-sparse t]
+ ["Mark thread" gnus-uu-mark-thread t]))
+ ("Move"
+ ["Scroll article forwards" gnus-summary-next-page t]
+ ["Next unread article" gnus-summary-next-unread-article t]
+ ["Previous unread article" gnus-summary-prev-unread-article t]
+ ["Next article" gnus-summary-next-article t]
+ ["Previous article" gnus-summary-prev-article t]
+ ["Next article same subject" gnus-summary-next-same-subject t]
+ ["Previous article same subject" gnus-summary-prev-same-subject t]
+ ["First unread article" gnus-summary-first-unread-article t]
+ ["Go to subject number..." gnus-summary-goto-subject t]
+ ["Go to the last article" gnus-summary-goto-last-article t]
+ ["Pop article off history" gnus-summary-pop-article t])
+ ("Sort"
+ ["Sort by number" gnus-summary-sort-by-number t]
+ ["Sort by author" gnus-summary-sort-by-author t]
+ ["Sort by subject" gnus-summary-sort-by-subject t]
+ ["Sort by date" gnus-summary-sort-by-date t]
+ ["Sort by score" gnus-summary-sort-by-score t])
+ ("Exit"
+ ["Catchup and exit" gnus-summary-catchup-and-exit t]
+ ["Catchup and goto next" gnus-summary-catchup-and-goto-next-group t]
+ ["Exit group" gnus-summary-exit t]
+ ["Exit group without updating" gnus-summary-exit-no-update t]
+ ["Reselect group" gnus-summary-reselect-current-group t]
+ ["Rescan group" gnus-summary-rescan-group t])
+ ["Fetch group FAQ" gnus-summary-fetch-faq t]
+ ["Filter articles" gnus-summary-execute-command t]
+ ["Toggle line truncation" gnus-summary-toggle-truncation t]
+ ["Expire expirable articles" gnus-summary-expire-articles t]
+ ["Describe group" gnus-summary-describe-group t]
+ ["Edit local kill file" gnus-summary-edit-local-kill t]
+ ))
+
+ (easy-menu-define
+ gnus-summary-kill-menu
+ gnus-summary-mode-map
+ ""
+ (cons
+ "Score"
+ (nconc
+ (list
+ ["Enter score" gnus-summary-score-entry t])
+ (gnus-visual-score-map 'increase)
+ (gnus-visual-score-map 'lower)
+ '(["Current score" gnus-summary-current-score t]
+ ["Set score" gnus-summary-set-score t]
+ ["Customize score file" gnus-score-customize t]
+ ["Switch current score file" gnus-score-change-score-file t]
+ ["Set mark below" gnus-score-set-mark-below t]
+ ["Set expunge below" gnus-score-set-expunge-below t]
+ ["Edit current score file" gnus-score-edit-alist t]
+ ["Edit score file" gnus-score-edit-file t]
+ ["Trace score" gnus-score-find-trace t]
+ ["Increase score" gnus-summary-increase-score t]
+ ["Lower score" gnus-summary-lower-score t]))))
+
+ (and nil
+ '(("Default header"
+ ["Ask" (gnus-score-set-default 'gnus-score-default-header nil)
+ :style radio
+ :selected (null gnus-score-default-header)]
+ ["From" (gnus-score-set-default 'gnus-score-default-header 'a)
+ :style radio
+ :selected (eq gnus-score-default-header 'a )]
+ ["Subject" (gnus-score-set-default 'gnus-score-default-header 's)
+ :style radio
+ :selected (eq gnus-score-default-header 's )]
+ ["Article body"
+ (gnus-score-set-default 'gnus-score-default-header 'b)
+ :style radio
+ :selected (eq gnus-score-default-header 'b )]
+ ["All headers"
+ (gnus-score-set-default 'gnus-score-default-header 'h)
+ :style radio
+ :selected (eq gnus-score-default-header 'h )]
+ ["Message-Id" (gnus-score-set-default 'gnus-score-default-header 'i)
+ :style radio
+ :selected (eq gnus-score-default-header 'i )]
+ ["Thread" (gnus-score-set-default 'gnus-score-default-header 't)
+ :style radio
+ :selected (eq gnus-score-default-header 't )]
+ ["Crossposting"
+ (gnus-score-set-default 'gnus-score-default-header 'x)
+ :style radio
+ :selected (eq gnus-score-default-header 'x )]
+ ["Lines" (gnus-score-set-default 'gnus-score-default-header 'l)
+ :style radio
+ :selected (eq gnus-score-default-header 'l )]
+ ["Date" (gnus-score-set-default 'gnus-score-default-header 'd)
+ :style radio
+ :selected (eq gnus-score-default-header 'd )]
+ ["Followups to author"
+ (gnus-score-set-default 'gnus-score-default-header 'f)
+ :style radio
+ :selected (eq gnus-score-default-header 'f )])
+ ("Default type"
+ ["Ask" (gnus-score-set-default 'gnus-score-default-type nil)
+ :style radio
+ :selected (null gnus-score-default-type)]
+ ;; The `:active' key is commented out in the following,
+ ;; because the GNU Emacs hack to support radio buttons use
+ ;; active to indicate which button is selected.
+ ["Substring" (gnus-score-set-default 'gnus-score-default-type 's)
+ :style radio
+ ;; :active (not (memq gnus-score-default-header '(l d)))
+ :selected (eq gnus-score-default-type 's)]
+ ["Regexp" (gnus-score-set-default 'gnus-score-default-type 'r)
+ :style radio
+ ;; :active (not (memq gnus-score-default-header '(l d)))
+ :selected (eq gnus-score-default-type 'r)]
+ ["Exact" (gnus-score-set-default 'gnus-score-default-type 'e)
+ :style radio
+ ;; :active (not (memq gnus-score-default-header '(l d)))
+ :selected (eq gnus-score-default-type 'e)]
+ ["Fuzzy" (gnus-score-set-default 'gnus-score-default-type 'f)
+ :style radio
+ ;; :active (not (memq gnus-score-default-header '(l d)))
+ :selected (eq gnus-score-default-type 'f)]
+ ["Before date" (gnus-score-set-default 'gnus-score-default-type 'b)
+ :style radio
+ ;; :active (eq (gnus-score-default-header 'd))
+ :selected (eq gnus-score-default-type 'b)]
+ ["At date" (gnus-score-set-default 'gnus-score-default-type 'n)
+ :style radio
+ ;; :active (eq (gnus-score-default-header 'd))
+ :selected (eq gnus-score-default-type 'n)]
+ ["After date" (gnus-score-set-default 'gnus-score-default-type 'a)
+ :style radio
+ ;; :active (eq (gnus-score-default-header 'd))
+ :selected (eq gnus-score-default-type 'a)]
+ ["Less than number"
+ (gnus-score-set-default 'gnus-score-default-type '<)
+ :style radio
+ ;; :active (eq (gnus-score-default-header 'l))
+ :selected (eq gnus-score-default-type '<)]
+ ["Equal to number"
+ (gnus-score-set-default 'gnus-score-default-type '=)
+ :style radio
+ ;; :active (eq (gnus-score-default-header 'l))
+ :selected (eq gnus-score-default-type '=)]
+ ["Greater than number"
+ (gnus-score-set-default 'gnus-score-default-type '>)
+ :style radio
+ ;; :active (eq (gnus-score-default-header 'l))
+ :selected (eq gnus-score-default-type '>)])
+ ["Default fold" gnus-score-default-fold-toggle
+ :style toggle
+ :selected gnus-score-default-fold]
+ ("Default duration"
+ ["Ask" (gnus-score-set-default 'gnus-score-default-duration nil)
+ :style radio
+ :selected (null gnus-score-default-duration)]
+ ["Permanent"
+ (gnus-score-set-default 'gnus-score-default-duration 'p)
+ :style radio
+ :selected (eq gnus-score-default-duration 'p)]
+ ["Temporary"
+ (gnus-score-set-default 'gnus-score-default-duration 't)
+ :style radio
+ :selected (eq gnus-score-default-duration 't)]
+ ["Immediate"
+ (gnus-score-set-default 'gnus-score-default-duration 'i)
+ :style radio
+ :selected (eq gnus-score-default-duration 'i)])
+ ))
+
+ (easy-menu-define
+ gnus-summary-article-menu
+ gnus-summary-mode-map
+ ""
+ '("Article"
+ ("Hide"
+ ["All" gnus-article-hide t]
+ ["Headers" gnus-article-hide-headers t]
+ ["Signature" gnus-article-hide-signature t]
+ ["Citation" gnus-article-hide-citation t])
+ ("Highlight"
+ ["All" gnus-article-highlight t]
+ ["Headers" gnus-article-highlight-headers t]
+ ["Signature" gnus-article-highlight-signature t]
+ ["Citation" gnus-article-highlight-citation t])
+ ("Date"
+ ["Local" gnus-article-date-local t]
+ ["UT" gnus-article-date-ut t]
+ ["Lapsed" gnus-article-date-lapsed t])
+ ("Filter"
+ ["Overstrike" gnus-article-treat-overstrike t]
+ ["Word wrap" gnus-article-word-wrap t]
+ ["CR" gnus-article-remove-cr t]
+ ["Show X-Face" gnus-article-display-x-face t]
+ ["Quoted-Printable" gnus-article-de-quoted-unreadable t]
+ ["Rot 13" gnus-summary-caesar-message t]
+ ["Add buttons" gnus-article-add-buttons t]
+ ["Stop page breaking" gnus-summary-stop-page-breaking t]
+ ["Toggle MIME" gnus-summary-toggle-mime t]
+ ["Toggle header" gnus-summary-toggle-header t])
+ ("Output"
+ ["Save in default format" gnus-summary-save-article t]
+ ["Save in file" gnus-summary-save-article-file t]
+ ["Save in Unix mail format" gnus-summary-save-article-mail t]
+ ["Save in MH folder" gnus-summary-save-article-folder t]
+ ["Save in VM folder" gnus-summary-save-article-vm t]
+ ["Save in RMAIL mbox" gnus-summary-save-article-rmail t]
+ ["Pipe through a filter" gnus-summary-pipe-output t])
+ ("Backend"
+ ["Respool article" gnus-summary-respool-article t]
+ ["Move article" gnus-summary-move-article t]
+ ["Copy article" gnus-summary-copy-article t]
+ ["Import file" gnus-summary-import-article t]
+ ["Edit article" gnus-summary-edit-article t]
+ ["Delete article" gnus-summary-delete-article t])
+ ("Extract"
+ ["Uudecode" gnus-uu-decode-uu t]
+ ["Uudecode and save" gnus-uu-decode-uu-and-save t]
+ ["Unshar" gnus-uu-decode-unshar t]
+ ["Unshar and save" gnus-uu-decode-unshar-and-save t]
+ ["Save" gnus-uu-decode-save t]
+ ["Binhex" gnus-uu-decode-binhex t])
+ ["Enter digest buffer" gnus-summary-enter-digest-group t]
+ ["Isearch article" gnus-summary-isearch-article t]
+ ["Search all articles" gnus-summary-search-article-forward t]
+ ["Beginning of the article" gnus-summary-beginning-of-article t]
+ ["End of the article" gnus-summary-end-of-article t]
+ ["Fetch parent of article" gnus-summary-refer-parent-article t]
+ ["Fetch article with id..." gnus-summary-refer-article t]
+ ["Redisplay" gnus-summary-show-article t]))
+
+
+
+ (easy-menu-define
+ gnus-summary-thread-menu
+ gnus-summary-mode-map
+ ""
+ '("Threads"
+ ["Toggle threading" gnus-summary-toggle-threads t]
+ ["Display hidden thread" gnus-summary-show-thread t]
+ ["Hide thread" gnus-summary-hide-thread t]
+ ["Go to next thread" gnus-summary-next-thread t]
+ ["Go to previous thread" gnus-summary-prev-thread t]
+ ["Go down thread" gnus-summary-down-thread t]
+ ["Go up thread" gnus-summary-up-thread t]
+ ["Mark thread as read" gnus-summary-kill-thread t]
+ ["Lower thread score" gnus-summary-lower-thread t]
+ ["Raise thread score" gnus-summary-raise-thread t]
+ ))
+ (easy-menu-define
+ gnus-summary-post-menu
+ gnus-summary-mode-map
+ ""
+ '("Post"
+ ["Post an article" gnus-summary-post-news t]
+ ["Followup" gnus-summary-followup t]
+ ["Followup and yank" gnus-summary-followup-with-original t]
+ ["Supersede article" gnus-summary-supersede-article t]
+ ["Cancel article" gnus-summary-cancel-article t]
+ ["Reply" gnus-summary-reply t]
+ ["Reply and yank" gnus-summary-reply-with-original t]
+ ["Mail forward" gnus-summary-mail-forward t]
+ ["Post forward" gnus-summary-post-forward t]
+ ["Digest and mail" gnus-uu-digest-mail-forward t]
+ ["Digest and post" gnus-uu-digest-post-forward t]
+ ["Send a mail" gnus-summary-mail-other-window t]
+ ["Reply & followup" gnus-summary-followup-and-reply t]
+ ["Reply & followup and yank" gnus-summary-followup-and-reply-with-original t]
+ ["Uuencode and post" gnus-uu-post-news t]
+ ))
+ (run-hooks 'gnus-summary-menu-hook)
+ )))
+
+(defun gnus-score-set-default (var value)
+ ;; A version of set that updates the GNU Emacs menu-bar.
+ (set var value)
+ ;; It is the message that forces the active status to be updated.
+ (message ""))
+
+(defvar gnus-score-default-header nil
+ "Default header when entering new scores.
+
+Should be one of the following symbols.
+
+ a: from
+ s: subject
+ b: body
+ h: head
+ i: message-id
+ t: references
+ x: xref
+ l: lines
+ d: date
+ f: followup
+
+If nil, the user will be asked for a header.")
+
+(defvar gnus-score-default-type nil
+ "Default match type when entering new scores.
+
+Should be one of the following symbols.
+
+ s: substring
+ e: exact string
+ f: fuzzy string
+ r: regexp string
+ b: before date
+ a: at date
+ n: this date
+ <: less than number
+ >: greater than number
+ =: equal to number
+
+If nil, the user will be asked for a match type.")
+
+(defvar gnus-score-default-fold nil
+ "Use case folding for new score file entries iff not nil.")
+
+
+(defun gnus-score-default-fold-toggle ()
+ "Toggle folding for new score file entries."
+ (interactive)
+ (setq gnus-score-default-fold (not gnus-score-default-fold))
+ (if gnus-score-default-fold
+ (message "New score file entries will be case insensitive.")
+ (message "New score file entries will be case sensitive.")))
+
+(defvar gnus-score-default-duration nil
+ "Default duration of effect when entering new scores.
+
+Should be one of the following symbols.
+
+ t: temporary
+ p: permanent
+ i: immediate
+
+If nil, the user will be asked for a duration.")
+
+(defun gnus-visual-score-map (type)
+ (if t
+ nil
+ (let ((headers '(("author" "from" string)
+ ("subject" "subject" string)
+ ("article body" "body" string)
+ ("article head" "head" string)
+ ("xref" "xref" string)
+ ("lines" "lines" number)
+ ("followups to author" "followup" string)))
+ (types '((number ("less than" <)
+ ("greater than" >)
+ ("equal" =))
+ (string ("substring" s)
+ ("exact string" e)
+ ("fuzzy string" f)
+ ("regexp" r))))
+ (perms '(("temporary" (current-time-string))
+ ("permanent" nil)
+ ("immediate" now)))
+ header)
+ (list
+ (apply
+ 'nconc
+ (list
+ (if (eq type 'lower)
+ "Lower score"
+ "Increase score"))
+ (let (outh)
+ (while headers
+ (setq header (car headers))
+ (setq outh
+ (cons
+ (apply
+ 'nconc
+ (list (car header))
+ (let ((ts (cdr (assoc (nth 2 header) types)))
+ outt)
+ (while ts
+ (setq outt
+ (cons
+ (apply
+ 'nconc
+ (list (car (car ts)))
+ (let ((ps perms)
+ outp)
+ (while ps
+ (setq outp
+ (cons
+ (vector
+ (car (car ps))
+ (list
+ 'gnus-summary-score-entry
+ (nth 1 header)
+ (if (or (string= (nth 1 header)
+ "head")
+ (string= (nth 1 header)
+ "body"))
+ ""
+ (list 'gnus-summary-header
+ (nth 1 header)))
+ (list 'quote (nth 1 (car ts)))
+ (list 'gnus-score-default nil)
+ (nth 1 (car ps))
+ t)
+ t)
+ outp))
+ (setq ps (cdr ps)))
+ (list (nreverse outp))))
+ outt))
+ (setq ts (cdr ts)))
+ (list (nreverse outt))))
+ outh))
+ (setq headers (cdr headers)))
+ (list (nreverse outh))))))))
+
+;; Article buffer
+(defun gnus-article-make-menu-bar ()
+ (gnus-visual-turn-off-edit-menu 'summary)
+ (or
+ (boundp 'gnus-article-article-menu)
+ (progn
+ (easy-menu-define
+ gnus-article-article-menu
+ gnus-article-mode-map
+ ""
+ '("Article"
+ ["Scroll forwards" gnus-article-next-page t]
+ ["Scroll backwards" gnus-article-prev-page t]
+ ["Show summary" gnus-article-show-summary t]
+ ["Fetch Message-ID at point" gnus-article-refer-article t]
+ ["Mail to address at point" gnus-article-mail t]
+ ))
+
+ (easy-menu-define
+ gnus-article-treatment-menu
+ gnus-article-mode-map
+ ""
+ '("Treatment"
+ ["Hide headers" gnus-article-hide-headers t]
+ ["Hide signature" gnus-article-hide-signature t]
+ ["Hide citation" gnus-article-hide-citation t]
+ ["Treat overstrike" gnus-article-treat-overstrike t]
+ ["Remove carriage return" gnus-article-remove-cr t]
+ ["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
+ ))
+ (run-hooks 'gnus-article-menu-hook)
+ )))
+
+;;;
+;;; summary highlights
+;;;
+
+(defun gnus-highlight-selected-summary ()
+ ;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
+ ;; Highlight selected article in summary buffer
+ (if gnus-summary-selected-face
+ (save-excursion
+ (let* ((beg (progn (beginning-of-line) (point)))
+ (end (progn (end-of-line) (point)))
+ ;; Fix by Mike Dugan <dugan@bucrf16.bu.edu>.
+ (from (if (get-text-property beg 'mouse-face)
+ beg
+ (1+ (or (next-single-property-change
+ beg 'mouse-face nil end)
+ beg))))
+ (to (1- (or (next-single-property-change
+ from 'mouse-face nil end)
+ end))))
+ ;; If no mouse-face prop on line (e.g. xemacs) we
+ ;; will have to = from = end, so we highlight the
+ ;; entire line instead.
+ (if (= (+ to 2) from)
+ (progn
+ (setq from beg)
+ (setq to end)))
+ (if gnus-newsgroup-selected-overlay
+ (gnus-move-overlay gnus-newsgroup-selected-overlay
+ from to (current-buffer))
+ (setq gnus-newsgroup-selected-overlay (gnus-make-overlay from to))
+ (gnus-overlay-put gnus-newsgroup-selected-overlay 'face
+ gnus-summary-selected-face))))))
+
+;; New implementation by Christian Limpach <Christian.Limpach@nice.ch>.
+(defun gnus-summary-highlight-line ()
+ "Highlight current line according to `gnus-summary-highlight'."
+ (let* ((list gnus-summary-highlight)
+ (p (point))
+ (end (progn (end-of-line) (point)))
+ ;; now find out where the line starts and leave point there.
+ (beg (progn (beginning-of-line) (point)))
+ (score (or (cdr (assq (or (get-text-property beg 'gnus-number)
+ gnus-current-article)
+ gnus-newsgroup-scored))
+ gnus-summary-default-score 0))
+ (default gnus-summary-default-score)
+ (mark (get-text-property beg 'gnus-mark))
+ (inhibit-read-only t))
+ (while (and list (not (eval (car (car list)))))
+ (setq list (cdr list)))
+ (let ((face (and list (cdr (car list)))))
+ (or (eobp)
+ (eq face (get-text-property beg 'face))
+ (put-text-property beg end 'face
+ (if (boundp face) (symbol-value face) face))))
+ (goto-char p)))
+
+;;;
+;;; 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)
+ (set-text-properties
+ (point)
+ (prog2 (insert button) (point) (insert " "))
+ (list 'face gnus-carpal-header-face))
+ (set-text-properties
+ (point)
+ (prog2 (insert (car button)) (point) (insert " "))
+ (list 'gnus-callback (cdr button)
+ 'face gnus-carpal-button-face
+ 'mouse-face '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))
+
+;;;
+;;; article highlights
+;;;
+
+;; Written by Per Abrahamsen <abraham@iesd.auc.dk>.
+
+;;; Internal Variables:
+
+(defvar gnus-button-regexp nil)
+;; Regexp matching any of the regexps from `gnus-button-alist'.
+
+(defvar gnus-button-last nil)
+;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
+
+;;; Commands:
+
+(defun gnus-article-push-button (event)
+ "Check text under the mouse pointer for a callback function.
+If the text under the mouse pointer has a `gnus-callback' property,
+call it with the value of the `gnus-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 'gnus-data))
+ (fun (get-text-property pos 'gnus-callback)))
+ (if fun (funcall fun data))))
+
+(defun gnus-article-press-button ()
+ "Check text at point for a callback function.
+If the text at point has a `gnus-callback' property,
+call it with the value of the `gnus-data' text property."
+ (interactive)
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (fun (get-text-property (point) 'gnus-callback)))
+ (if fun (funcall fun data))))
+
+;; Suggested by Arne Elofsson <arne@hodgkin.mbi.ucla.edu>
+(defun gnus-article-next-button ()
+ "Move point to next button."
+ (interactive)
+ (if (get-text-property (point) 'gnus-callback)
+ (goto-char (next-single-property-change (point) 'gnus-callback
+ nil (point-max))))
+ (let ((pos (next-single-property-change (point) 'gnus-callback)))
+ (if pos
+ (goto-char pos)
+ (setq pos (next-single-property-change (point-min) 'gnus-callback))
+ (if pos
+ (goto-char pos)
+ (error "No buttons found")))))
+
+(defun gnus-article-highlight (&optional force)
+ "Highlight current article.
+This function calls `gnus-article-highlight-headers',
+`gnus-article-highlight-citation',
+`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
+do the highlighting. See the documentation for those functions."
+ (interactive (list 'force))
+ (gnus-article-highlight-headers)
+ (gnus-article-highlight-citation force)
+ (gnus-article-highlight-signature)
+ (gnus-article-add-buttons force))
+
+(defun gnus-article-highlight-some (&optional force)
+ "Highlight current article.
+This function calls `gnus-article-highlight-headers',
+`gnus-article-highlight-signature', and `gnus-article-add-buttons' to
+do the highlighting. See the documentation for those functions."
+ (interactive (list 'force))
+ (gnus-article-highlight-headers)
+ (gnus-article-highlight-signature)
+ (gnus-article-add-buttons))
+
+(defun gnus-article-hide (&optional force)
+ "Hide current article.
+This function calls `gnus-article-hide-headers',
+`gnus-article-hide-citation-maybe', and `gnus-article-hide-signature'
+to do the hiding. See the documentation for those functions."
+ (interactive (list 'force))
+ (gnus-article-hide-headers)
+ (gnus-article-hide-citation-maybe force)
+ (gnus-article-hide-signature))
+
+(defun gnus-article-highlight-headers ()
+ "Highlight article headers as specified by `gnus-header-face-alist'."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (goto-char (point-min))
+ (if (not (search-forward "\n\n" nil t))
+ ()
+ (beginning-of-line 0)
+ (while (not (bobp))
+ (let ((alist gnus-header-face-alist)
+ (buffer-read-only nil)
+ (case-fold-search t)
+ (end (point))
+ (inhibit-point-motion-hooks t)
+ begin entry regexp header-face field-face
+ header-found field-found)
+ (re-search-backward "^[^ \t]" nil t)
+ (setq begin (point))
+ (while alist
+ (setq entry (car alist)
+ regexp (nth 0 entry)
+ header-face (nth 1 entry)
+ field-face (nth 2 entry)
+ alist (cdr alist))
+ (if (looking-at regexp)
+ (let ((from (point)))
+ (skip-chars-forward "^:\n")
+ (and (not header-found)
+ header-face
+ (progn
+ (put-text-property from (point) 'face header-face)
+ (setq header-found t)))
+ (and (not field-found)
+ field-face
+ (progn
+ (skip-chars-forward ": \t")
+ (let ((from (point)))
+ (goto-char end)
+ (skip-chars-backward " \t")
+ (put-text-property from (point) 'face field-face)
+ (setq field-found t))))))
+ (goto-char begin)))))))
+
+(defun gnus-article-highlight-signature ()
+ "Highlight the signature in an article.
+It does this by highlighting everything after
+`gnus-signature-separator' using `gnus-signature-face'."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t))
+ (goto-char (point-max))
+ (and (re-search-backward gnus-signature-separator nil t)
+ gnus-signature-face
+ (let ((start (match-beginning 0))
+ (end (match-end 0)))
+ (gnus-article-add-button start end 'gnus-signature-toggle end)
+ (gnus-overlay-put (gnus-make-overlay end (point-max))
+ 'face gnus-signature-face))))))
+
+(defun gnus-article-hide-signature ()
+ "Hide the signature in an article.
+It does this by making everything after `gnus-signature-separator' invisible."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (goto-char (point-max))
+ (and (re-search-backward gnus-signature-separator nil t)
+ gnus-signature-face
+ (add-text-properties (match-end 0) (point-max)
+ gnus-hidden-properties)))))
+
+(defun gnus-article-add-buttons (&optional force)
+ "Find external references in article and make them to buttons.
+
+External references are things like message-ids and URLs, as specified by
+`gnus-button-alist'."
+ (interactive (list 'force))
+ (if (eq gnus-button-last gnus-button-alist)
+ ()
+ (setq gnus-button-regexp (mapconcat 'car gnus-button-alist "\\|")
+ gnus-button-last gnus-button-alist))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (gnus-cite-parse-maybe force)
+ (let ((buffer-read-only nil)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t))
+ (goto-char (point-min))
+ (or (search-forward "\n\n" nil t)
+ (goto-char (point-max)))
+ (while (re-search-forward gnus-button-regexp nil t)
+ (goto-char (match-beginning 0))
+ (let* ((from (point))
+ (entry (gnus-button-entry))
+ (start (and entry (match-beginning (nth 1 entry))))
+ (end (and entry (match-end (nth 1 entry))))
+ (form (nth 2 entry)))
+ (if (not entry)
+ ()
+ (goto-char (match-end 0))
+ (if (eval form)
+ (gnus-article-add-button start end 'gnus-button-push
+ (set-marker (make-marker)
+ from)))))))))
+(defun gnus-netscape-open-url (url)
+ "Open URL in netscape, or start new scape with URL."
+ (let ((process (start-process (concat "netscape " url)
+ nil
+ "netscape"
+ "-remote"
+ (concat "openUrl(" url ")'"))))
+ (set-process-sentinel process
+ (` (lambda (process change)
+ (or (eq (process-exit-status process) 0)
+ (gnus-netscape-start-url (, url))))))))
+
+(defun gnus-netscape-start-url (url)
+ "Start netscape with URL."
+ (start-process (concat "netscape" url) nil "netscape" url))
+
+;;; External functions:
+
+(defun gnus-article-add-button (from to fun &optional data)
+ "Create a button between FROM and TO with callback FUN and data DATA."
+ (and gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay from to)
+ 'face gnus-article-button-face))
+ (add-text-properties from to
+ (append (and gnus-article-mouse-face
+ (list 'mouse-face gnus-article-mouse-face))
+ (list 'gnus-callback fun)
+ (and data (list 'gnus-data data)))))
+
+;;; Internal functions:
+
+(defun gnus-signature-toggle (end)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (if (get-text-property end 'invisible)
+ (remove-text-properties end (point-max) gnus-hidden-properties)
+ (add-text-properties end (point-max) gnus-hidden-properties)))))
+
+;see gnus-cus.el
+;(defun gnus-make-face (color)
+; ;; Create entry for face with COLOR.
+; (if gnus-make-foreground
+; (custom-face-lookup color nil nil nil nil nil)
+; (custom-face-lookup nil color nil nil nil nil)))
+
+(defun gnus-button-entry ()
+ ;; Return the first entry in `gnus-button-alist' matching this place.
+ (let ((alist gnus-button-alist)
+ (entry nil))
+ (while alist
+ (setq entry (car alist)
+ alist (cdr alist))
+ (if (looking-at (car entry))
+ (setq alist nil)
+ (setq entry nil)))
+ entry))
+
+(defun gnus-button-push (marker)
+ ;; Push button starting at MARKER.
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (goto-char marker)
+ (let* ((entry (gnus-button-entry))
+ (inhibit-point-motion-hooks t)
+ (fun (nth 3 entry))
+ (args (mapcar (lambda (group)
+ (let ((string (buffer-substring
+ (match-beginning group)
+ (match-end group))))
+ (set-text-properties 0 (length string) nil string)
+ string))
+ (nthcdr 4 entry))))
+ (cond ((fboundp fun)
+ (apply fun args))
+ ((and (boundp fun)
+ (fboundp (symbol-value fun)))
+ (apply (symbol-value fun) args))
+ (t
+ (message "You must define `%S' to use this button"
+ (cons fun args)))))))
+
+(defun gnus-button-message-id (message-id)
+ ;; Push on MESSAGE-ID.
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-refer-article message-id)))
+
+;;; Compatibility Functions:
+
+(or (fboundp 'rassoc)
+ ;; Introduced in Emacs 19.29.
+ (defun rassoc (elt list)
+ "Return non-nil if ELT is `equal' to the cdr of an element of LIST.
+The value is actually the element of LIST whose cdr is ELT."
+ (let (result)
+ (while list
+ (setq result (car list))
+ (if (equal (cdr result) elt)
+ (setq list nil)
+ (setq result nil
+ list (cdr list))))
+ result)))
+
+; (require 'gnus-cus)
+(gnus-ems-redefine)
+(provide 'gnus-vis)
+
+;;; gnus-vis.el ends here
diff --git a/lisp/gnus-vm.el b/lisp/gnus-vm.el
new file mode 100644
index 00000000000..aab5a6ec0ec
--- /dev/null
+++ b/lisp/gnus-vm.el
@@ -0,0 +1,261 @@
+;;; gnus-vm.el --- vm interface for Gnus
+;; Copyright (C) 1994,95 Free Software Foundation, Inc.
+
+;; Author: Per Persson <pp@solace.mh.se>
+;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; Major contributors:
+;; Christian Limpach <Christian.Limpach@nice.ch>
+;; Some code stolen from:
+;; Rick Sladkey <jrs@world.std.com>
+
+;;; Code:
+
+(require 'sendmail)
+(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
+ (if window-system
+ (require 'win-vm))
+ (error nil)))
+
+(if (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)
+ (let ((default-name
+ (funcall gnus-mail-save-name gnus-newsgroup-name
+ gnus-current-headers gnus-newsgroup-last-mail)))
+ (or folder
+ (setq folder
+ (read-file-name
+ (concat "Save article in VM folder: (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name)))
+ (setq folder
+ (expand-file-name folder
+ (and default-name
+ (file-name-directory default-name))))
+ (gnus-make-directory (file-name-directory folder))
+ (set-buffer gnus-article-buffer)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let ((vm-folder (gnus-vm-make-folder)))
+ (vm-save-message folder)
+ (kill-buffer vm-folder))))
+ ;; Remember the directory name to save articles.
+ (setq gnus-newsgroup-last-mail folder)))
+
+(defun gnus-mail-forward-using-vm (&optional buffer)
+ "Forward the current message to another user using vm."
+ (let* ((gnus-buffer (or buffer (current-buffer)))
+ (subject (gnus-forward-make-subject gnus-buffer)))
+ (or (featurep 'win-vm)
+ (if gnus-use-full-window
+ (pop-to-buffer gnus-article-buffer)
+ (switch-to-buffer gnus-article-buffer)))
+ (gnus-copy-article-buffer)
+ (set-buffer gnus-article-copy)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let ((vm-folder (gnus-vm-make-folder))
+ (vm-forward-message-hook
+ (append (symbol-value 'vm-forward-message-hook)
+ '((lambda ()
+ (save-excursion
+ (mail-position-on-field "Subject")
+ (beginning-of-line)
+ (looking-at "^\\(Subject: \\).*$")
+ (replace-match (concat "\\1" subject))))))))
+ (vm-forward-message)
+ (gnus-vm-init-reply-buffer gnus-buffer)
+ (run-hooks 'gnus-mail-hook)
+ (kill-buffer vm-folder))))))
+
+(defun gnus-vm-init-reply-buffer (buffer)
+ (make-local-variable 'gnus-summary-buffer)
+ (setq gnus-summary-buffer buffer)
+ (set 'vm-mail-buffer nil)
+ (use-local-map (copy-keymap (current-local-map)))
+ (local-set-key "\C-c\C-y" 'gnus-yank-article))
+
+(defun gnus-mail-reply-using-vm (&optional yank)
+ "Compose reply mail using vm.
+Optional argument YANK means yank original article.
+The command \\[vm-yank-message] yank the original message into current buffer."
+ (let ((gnus-buffer (current-buffer)))
+ (gnus-copy-article-buffer)
+ (set-buffer gnus-article-copy)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (let ((vm-folder (gnus-vm-make-folder gnus-article-copy)))
+ (vm-reply 1)
+ (gnus-vm-init-reply-buffer gnus-buffer)
+ (setq gnus-buffer (current-buffer))
+ (and yank
+ ;; nil will (magically :-)) yank the current article
+ (gnus-yank-article nil))
+ (kill-buffer vm-folder))))
+ (if (featurep 'win-vm) nil
+ (pop-to-buffer gnus-buffer))
+ (run-hooks 'gnus-mail-hook)))
+
+(defun gnus-mail-other-window-using-vm ()
+ "Compose mail in the other window using VM."
+ (interactive)
+ (let ((gnus-buffer (current-buffer)))
+ (vm-mail)
+ (gnus-vm-init-reply-buffer gnus-buffer))
+ (run-hooks 'gnus-mail-hook))
+
+(defun gnus-yank-article (article &optional prefix)
+ ;; Based on vm-yank-message by Kyle Jones.
+ "Yank article number N into the current buffer at point.
+When called interactively N is read from the minibuffer.
+
+This command is meant to be used in GNUS created Mail mode buffers;
+the yanked article comes from the newsgroup containing the article
+you are replying to or forwarding.
+
+All article headers are yanked along with the text. Point is left
+before the inserted text, the mark after. Any hook functions bound to
+`mail-citation-hook' are run, after inserting the text and setting
+point and mark.
+
+Prefix arg means to ignore `mail-citation-hook', don't set the mark,
+prepend the value of `vm-included-text-prefix' to every yanked line.
+For backwards compatibility, if `mail-citation-hook' is set to nil,
+`mail-yank-hooks' is run instead. If that is also nil, a default
+action is taken."
+ (interactive
+ (list
+ (let ((result 0)
+ default prompt)
+ (setq default (and gnus-summary-buffer
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (and gnus-current-article
+ (int-to-string gnus-current-article))))
+ prompt (if default
+ (format "Yank article number: (default %s) " default)
+ "Yank article number: "))
+ (while (and (not (stringp result)) (zerop result))
+ (setq result (read-string prompt))
+ (and (string= result "") default (setq result default))
+ (or (string-match "^<.*>$" result)
+ (setq result (string-to-int result))))
+ result)
+ current-prefix-arg))
+ (if gnus-summary-buffer
+ (save-excursion
+ (let ((message (current-buffer))
+ (start (point)) end
+ (tmp (generate-new-buffer " *tmp-yank*")))
+ (set-buffer gnus-summary-buffer)
+ ;; Make sure the connection to the server is alive.
+ (or (gnus-server-opened (gnus-find-method-for-group
+ gnus-newsgroup-name))
+ (progn
+ (gnus-check-server
+ (gnus-find-method-for-group gnus-newsgroup-name))
+ (gnus-request-group gnus-newsgroup-name t)))
+ (and (stringp article)
+ (let ((gnus-override-method gnus-refer-article-method))
+ (gnus-read-header article)))
+ (gnus-request-article (or article
+ gnus-current-article)
+ gnus-newsgroup-name tmp)
+ (set-buffer tmp)
+ (run-hooks 'gnus-article-prepare-hook)
+ ;; Decode MIME message.
+ (if (and gnus-show-mime
+ (gnus-fetch-field "Mime-Version"))
+ (funcall gnus-show-mime-method))
+ ;; Perform the article display hooks.
+ (let ((buffer-read-only nil))
+ (run-hooks 'gnus-article-display-hook))
+ (append-to-buffer message (point-min) (point-max))
+ (kill-buffer tmp)
+ (set-buffer message)
+ (setq end (point))
+ (goto-char start)
+ (if (or prefix
+ (not (or mail-citation-hook mail-yank-hooks)))
+ (save-excursion
+ (while (< (point) end)
+ (insert (symbol-value 'vm-included-text-prefix))
+ (forward-line 1)))
+ (push-mark end)
+ (cond
+ (mail-citation-hook (run-hooks 'mail-citation-hook))
+ (mail-yank-hooks (run-hooks 'mail-yank-hooks))))))))
+
+(provide 'gnus-vm)
+
+;;; gnus-vm.el ends here.
diff --git a/lisp/gnus.el b/lisp/gnus.el
new file mode 100644
index 00000000000..377c7ed8d69
--- /dev/null
+++ b/lisp/gnus.el
@@ -0,0 +1,14136 @@
+;;; gnus.el --- a newsreader for GNU Emacs
+;; Copyright (C) 1987,88,89,90,93,94,95 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; Although Gnus looks suspiciously like GNUS, it isn't quite the same
+;; beast. Most internal structures have been changed. If you have
+;; written packages that depend on any of the hash tables,
+;; `gnus-newsrc-alist', `gnus-killed-assoc', marked lists, the .newsrc
+;; buffer, or internal knowledge of the `nntp-header-' macros, or
+;; dependence on the buffers having a certain format, your code will
+;; fail.
+
+;;; Code:
+
+(eval '(run-hooks 'gnus-load-hook))
+
+(require 'mail-utils)
+(require 'timezone)
+(require 'nnheader)
+
+;; Site dependent variables. These variables should be defined in
+;; paths.el.
+
+(defvar gnus-default-nntp-server nil
+ "Specify a default NNTP server.
+This variable should be defined in paths.el, and should never be set
+by the user.
+If you want to change servers, you should use `gnus-select-method'.
+See the documentation to that variable.")
+
+(defconst gnus-backup-default-subscribed-newsgroups
+ '("news.announce.newusers" "news.groups.questions" "gnu.emacs.gnus")
+ "Default default new newsgroups the first time Gnus is run.
+Should be set in paths.el, and shouldn't be touched by the user.")
+
+(defvar gnus-local-domain nil
+ "Local domain name without a host name.
+The DOMAINNAME environment variable is used instead if it is defined.
+If the `system-name' function returns the full Internet name, there is
+no need to set this variable.")
+
+(defvar gnus-local-organization nil
+ "String with a description of what organization (if any) the user belongs to.
+The ORGANIZATION environment variable is used instead if it is defined.
+If this variable contains a function, this function will be called
+with the current newsgroup name as the argument. The function should
+return a string.
+
+In any case, if the string (either in the variable, in the environment
+variable, or returned by the function) is a file name, the contents of
+this file will be used as the organization.")
+
+(defvar gnus-use-generic-from nil
+ "If nil, the full host name will be the system name prepended to the domain name.
+If this is a string, the full host name will be this string.
+If this is non-nil, non-string, the domain name will be used as the
+full host name.")
+
+(defvar gnus-use-generic-path nil
+ "If nil, use the NNTP server name in the Path header.
+If stringp, use this; if non-nil, use no host name (user name only).")
+
+
+;; Customization variables
+
+;; Don't touch this variable.
+(defvar gnus-nntp-service "nntp"
+ "*NNTP service name (\"nntp\" or 119).
+This is an obsolete variable, which is scarcely used. If you use an
+nntp server for your newsgroup and want to change the port number
+used to 899, you would say something along these lines:
+
+ (setq gnus-select-method '(nntp \"my.nntp.server\" (nntp-port-number 899)))")
+
+(defvar gnus-select-method
+ (nconc
+ (list 'nntp (or (getenv "NNTPSERVER")
+ (if (and gnus-default-nntp-server
+ (not (string= gnus-default-nntp-server "")))
+ gnus-default-nntp-server)
+ (system-name)))
+ (if (or (null gnus-nntp-service)
+ (equal gnus-nntp-service "nntp"))
+ nil
+ (list gnus-nntp-service)))
+ "*Default method for selecting a newsgroup.
+This variable should be a list, where the first element is how the
+news is to be fetched, the second is the address.
+
+For instance, if you want to get your news via NNTP from
+\"flab.flab.edu\", you could say:
+
+(setq gnus-select-method '(nntp \"flab.flab.edu\"))
+
+If you want to use your local spool, say:
+
+(setq gnus-select-method (list 'nnspool (system-name)))
+
+If you use this variable, you must set `gnus-nntp-server' to nil.
+
+There is a lot more to know about select methods and virtual servers -
+see the manual for details.")
+
+;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
+(defvar gnus-post-method nil
+ "*Preferred method for posting USENET news.
+If this variable is nil, Gnus will use the current method to decide
+which method to use when posting. If it is non-nil, it will override
+the current method. This method will not be used in mail groups and
+the like, only in \"real\" newsgroups.
+
+The value must be a valid method as discussed in the documentation of
+`gnus-select-method'.")
+
+(defvar gnus-refer-article-method nil
+ "*Preferred method for fetching an article by Message-ID.
+If you are reading news from the local spool (with nnspool), fetching
+articles by Message-ID is painfully slow. By setting this method to an
+nntp method, you might get acceptable results.
+
+The value of this variable must be a valid select method as discussed
+in the documentation of `gnus-select-method'")
+
+(defvar gnus-secondary-select-methods nil
+ "*A list of secondary methods that will be used for reading news.
+This is a list where each element is a complete select method (see
+`gnus-select-method').
+
+If, for instance, you want to read your mail with the nnml backend,
+you could set this variable:
+
+(setq gnus-secondary-select-methods '((nnml \"\")))")
+
+(defvar gnus-secondary-servers nil
+ "*List of NNTP servers that the user can choose between interactively.
+To make Gnus query you for a server, you have to give `gnus' a
+non-numeric prefix - `C-u M-x gnus', in short.")
+
+(defvar gnus-nntp-server nil
+ "*The name of the host running the NNTP server.
+This variable is semi-obsolete. Use the `gnus-select-method'
+variable instead.")
+
+(defvar gnus-startup-file "~/.newsrc"
+ "*Your `.newsrc' file.
+`.newsrc-SERVER' will be used instead if that exists.")
+
+(defvar gnus-init-file "~/.gnus"
+ "*Your Gnus elisp startup file.
+If a file with the .el or .elc suffixes exist, it will be read
+instead.")
+
+(defvar gnus-group-faq-directory
+ "/ftp@mirrors.aol.com:/pub/rtfm/usenet/"
+ "*Directory where the group FAQs are stored.
+This will most commonly be on a remote machine, and the file will be
+fetched by ange-ftp.
+
+Note that Gnus uses an aol machine as the default directory. If this
+feels fundamentally unclean, just think of it as a way to finally get
+something of value back from them.
+
+If the default site is too slow, try one of these:
+
+ North America: ftp.uu.net /usenet/news.answers
+ mirrors.aol.com /pub/rtfm/usenet
+ ftp.seas.gwu.edu /pub/rtfm
+ rtfm.mit.edu /pub/usenet/news.answers
+ Europe: ftp.uni-paderborn.de /pub/FAQ
+ ftp.Germany.EU.net /pub/newsarchive/news.answers
+ ftp.sunet.se /pub/usenet
+ Asia: nctuccca.edu.tw /USENET/FAQ
+ hwarang.postech.ac.kr /pub/usenet/news.answers
+ ftp.hk.super.net /mirror/faqs")
+
+(defvar gnus-group-archive-directory
+ "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list/"
+ "*The address of the (ding) archives.")
+
+(defvar gnus-group-recent-archive-directory
+ "/ftp@ftp.hpc.uh.edu:/pub/emacs/ding-list-recent/"
+ "*The address of the most recent (ding) articles.")
+
+(defvar gnus-default-subscribed-newsgroups nil
+ "*This variable lists what newsgroups should be subscribed the first time Gnus is used.
+It should be a list of strings.
+If it is `t', Gnus will not do anything special the first time it is
+started; it'll just use the normal newsgroups subscription methods.")
+
+(defvar gnus-use-cross-reference t
+ "*Non-nil means that cross referenced articles will be marked as read.
+If nil, ignore cross references. If t, mark articles as read in
+subscribed newsgroups. If neither t nor nil, mark as read in all
+newsgroups.")
+
+(defvar gnus-use-dribble-file t
+ "*Non-nil means that Gnus will use a dribble file to store user updates.
+If Emacs should crash without saving the .newsrc files, complete
+information can be restored from the dribble file.")
+
+(defvar gnus-asynchronous nil
+ "*If non-nil, Gnus will supply backends with data needed for async article fetching.")
+
+(defvar gnus-asynchronous-article-function nil
+ "*Function for picking articles to pre-fetch, possibly.")
+
+(defvar gnus-score-file-single-match-alist nil
+ "*Alist mapping regexps to lists of score files.
+Each element of this alist should be of the form
+ (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
+
+If the name of a group is matched by REGEXP, the corresponding scorefiles
+will be used for that group.
+The first match found is used, subsequent matching entries are ignored (to
+use multiple matches, see gnus-score-file-multiple-match-alist).
+
+These score files are loaded in addition to any files returned by
+gnus-score-find-score-files-function (which see).")
+
+(defvar gnus-score-file-multiple-match-alist nil
+ "*Alist mapping regexps to lists of score files.
+Each element of this alist should be of the form
+ (\"REGEXP\" [ \"SCORE-FILE-1\" ] [ \"SCORE-FILE-2\" ] ... )
+
+If the name of a group is matched by REGEXP, the corresponding scorefiles
+will be used for that group.
+If multiple REGEXPs match a group, the score files corresponding to each
+match will be used (for only one match to be used, see
+gnus-score-file-single-match-alist).
+
+These score files are loaded in addition to any files returned by
+gnus-score-find-score-files-function (which see).")
+
+
+(defvar gnus-score-file-suffix "SCORE"
+ "*Suffix of the score files.")
+
+(defvar gnus-adaptive-file-suffix "ADAPT"
+ "*Suffix of the adaptive score files.")
+
+(defvar gnus-score-find-score-files-function 'gnus-score-find-bnews
+ "*Function used to find score files.
+The function will be called with the group name as the argument, and
+should return a list of score files to apply to that group. The score
+files do not actually have to exist.
+
+Predefined values are:
+
+gnus-score-find-single: Only apply the group's own score file.
+gnus-score-find-hierarchical: Also apply score files from parent groups.
+gnus-score-find-bnews: Apply score files whose names matches.
+
+See the documentation to these functions for more information.
+
+This variable can also be a list of functions to be called. Each
+function should either return a list of score files, or a list of
+score alists.")
+
+(defvar gnus-score-interactive-default-score 1000
+ "*Scoring commands will raise/lower the score with this number as the default.")
+
+(defvar gnus-large-newsgroup 200
+ "*The number of articles which indicates a large newsgroup.
+If the number of articles in a newsgroup is greater than this value,
+confirmation is required for selecting the newsgroup.")
+
+;; Suggested by Andrew Eskilsson <pi92ae@lelle.pt.hk-r.se>.
+(defvar gnus-no-groups-message "No news is horrible news"
+ "*Message displayed by Gnus when no groups are available.")
+
+(defvar gnus-use-long-file-name (not (memq system-type '(usg-unix-v xenix)))
+ "*Non-nil means that the default name of a file to save articles in is the group name.
+If it's nil, the directory form of the group name is used instead.
+
+If this variable is a list, and the list contains the element
+`not-score', long file names will not be used for score files; if it
+contains the element `not-save', long file names will not be used for
+saving; and if it contains the element `not-kill', long file names
+will not be used for kill files.")
+
+(defvar gnus-article-save-directory (or (getenv "SAVEDIR") "~/News/")
+ "*Name of the directory articles will be saved in (default \"~/News\").
+Initialized from the SAVEDIR environment variable.")
+
+(defvar gnus-kill-files-directory (or (getenv "SAVEDIR") "~/News/")
+ "*Name of the directory where kill files will be stored (default \"~/News\").
+Initialized from the SAVEDIR environment variable.")
+
+(defvar gnus-default-article-saver 'gnus-summary-save-in-rmail
+ "*A function to save articles in your favorite format.
+The function must be interactively callable (in other words, it must
+be an Emacs command).
+
+Gnus provides the following functions:
+
+* gnus-summary-save-in-rmail (Rmail format)
+* gnus-summary-save-in-mail (Unix mail format)
+* gnus-summary-save-in-folder (MH folder)
+* gnus-summary-save-in-file (article format).
+* gnus-summary-save-in-vm (use VM's folder format).")
+
+(defvar gnus-rmail-save-name (function gnus-plain-save-name)
+ "*A function generating a file name to save articles in Rmail format.
+The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.")
+
+(defvar gnus-mail-save-name (function gnus-plain-save-name)
+ "*A function generating a file name to save articles in Unix mail format.
+The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE.")
+
+(defvar gnus-folder-save-name (function gnus-folder-save-name)
+ "*A function generating a file name to save articles in MH folder.
+The function is called with NEWSGROUP, HEADERS, and optional LAST-FOLDER.")
+
+(defvar gnus-file-save-name (function gnus-numeric-save-name)
+ "*A function generating a file name to save articles in article format.
+The function is called with NEWSGROUP, HEADERS, and optional
+LAST-FILE.")
+
+(defvar gnus-split-methods nil
+ "*Variable used to suggest where articles are to be saved.
+The syntax of this variable is the same as `nnmail-split-methods'.
+
+For instance, if you would like to save articles related to Gnus in
+the file \"gnus-stuff\", and articles related to VM in \"vm-stuff\",
+you could set this variable to something like:
+
+ '((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
+ (\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))")
+
+(defvar gnus-save-score nil
+ "*If non-nil, save group scoring info.")
+
+(defvar gnus-use-adaptive-scoring nil
+ "*If non-nil, use some adaptive scoring scheme.")
+
+(defvar gnus-use-cache nil
+ "*If non-nil, Gnus will cache (some) articles locally.")
+
+(defvar gnus-use-scoring t
+ "*If non-nil, enable scoring.")
+
+(defvar gnus-fetch-old-headers nil
+ "*Non-nil means that Gnus will try to build threads by grabbing old headers.
+If an unread article in the group refers to an older, already read (or
+just marked as read) article, the old article will not normally be
+displayed in the Summary buffer. If this variable is non-nil, Gnus
+will attempt to grab the headers to the old articles, and thereby
+build complete threads. If it has the value `some', only enough
+headers to connect otherwise loose threads will be displayed.
+
+The server has to support XOVER for any of this to work.")
+
+;see gnus-cus.el
+;(defvar gnus-visual t
+; "*If non-nil, will do various highlighting.
+;If nil, no mouse highlights (or any other highlights) will be
+;performed. This might speed up Gnus some when generating large group
+;and summary buffers.")
+
+(defvar gnus-novice-user t
+ "*Non-nil means that you are a usenet novice.
+If non-nil, verbose messages may be displayed and confirmations may be
+required.")
+
+(defvar gnus-expert-user nil
+ "*Non-nil means that you will never be asked for confirmation about anything.
+And that means *anything*.")
+
+(defvar 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.")
+
+(defvar gnus-keep-same-level nil
+ "*Non-nil means that the next newsgroup after the current will be on the same level.
+When you type, for instance, `n' after reading the last article in the
+current newsgroup, you will go to the next newsgroup. If this variable
+is nil, the next newsgroup will be the next from the group
+buffer.
+If this variable is non-nil, Gnus will either put you in the
+next newsgroup with the same level, or, if no such newsgroup is
+available, the next newsgroup with the lowest possible level higher
+than the current level.
+If this variable is `best', Gnus will make the next newsgroup the one
+with the best level.")
+
+(defvar gnus-summary-make-false-root 'adopt
+ "*nil means that Gnus won't gather loose threads.
+If the root of a thread has expired or been read in a previous
+session, the information necessary to build a complete thread has been
+lost. Instead of having many small sub-threads from this original thread
+scattered all over the summary buffer, Gnus can gather them.
+
+If non-nil, Gnus will try to gather all loose sub-threads from an
+original thread into one large thread.
+
+If this variable is non-nil, it should be one of `none', `adopt',
+`dummy' or `empty'.
+
+If this variable is `none', Gnus will not make a false root, but just
+present the sub-threads after another.
+If this variable is `dummy', Gnus will create a dummy root that will
+have all the sub-threads as children.
+If this variable is `adopt', Gnus will make one of the \"children\"
+the parent and mark all the step-children as such.
+If this variable is `empty', the \"children\" are printed with empty
+subject fields. (Or rather, they will be printed with a string
+given by the `gnus-summary-same-subject' variable.)")
+
+(defvar gnus-summary-gather-subject-limit nil
+ "*Maximum length of subject comparisons when gathering loose threads.
+Use nil to compare full subjects. Setting this variable to a low
+number will help gather threads that have been corrupted by
+newsreaders chopping off subject lines, but it might also mean that
+unrelated articles that have subject that happen to begin with the
+same few characters will be incorrectly gathered.
+
+If this variable is `fuzzy', Gnus will use a fuzzy algorithm when
+comparing subjects.")
+
+;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defvar gnus-summary-same-subject ""
+ "*String indicating that the current article has the same subject as the previous.
+This variable will only be used if the value of
+`gnus-summary-make-false-root' is `empty'.")
+
+(defvar gnus-summary-goto-unread t
+ "*If non-nil, marking commands will go to the next unread article.")
+
+(defvar gnus-group-goto-unread t
+ "*If non-nil, movement commands will go to the next unread and subscribed group.")
+
+(defvar gnus-check-new-newsgroups t
+ "*Non-nil means that Gnus will add new newsgroups at startup.
+If this variable is `ask-server', Gnus will ask the server for new
+groups since the last time it checked. This means that the killed list
+is no longer necessary, so you could set `gnus-save-killed-list' to
+nil.
+
+A variant is to have this variable be a list of select methods. Gnus
+will then use the `ask-server' method on all these select methods to
+query for new groups from all those servers.
+
+Eg.
+ (setq gnus-check-new-newsgroups
+ '((nntp \"some.server\") (nntp \"other.server\")))
+
+If this variable is nil, then you have to tell Gnus explicitly to
+check for new newsgroups with \\<gnus-group-mode-map>\\[gnus-find-new-newsgroups].")
+
+(defvar gnus-check-bogus-newsgroups nil
+ "*Non-nil means that Gnus will check and remove bogus newsgroup at startup.
+If this variable is nil, then you have to tell Gnus explicitly to
+check for bogus newsgroups with \\<gnus-group-mode-map>\\[gnus-group-check-bogus-groups].")
+
+(defvar gnus-read-active-file t
+ "*Non-nil means that Gnus will read the entire active file at startup.
+If this variable is nil, Gnus will only know about the groups in your
+`.newsrc' file.
+
+If this variable is `some', Gnus will try to only read the relevant
+parts of the active file from the server. Not all servers support
+this, and it might be quite slow with other servers, but this should
+generally be faster than both the t and nil value.
+
+If you set this variable to nil or `some', you probably still want to
+be told about new newsgroups that arrive. To do that, set
+`gnus-check-new-newsgroups' to `ask-server'. This may not work
+properly with all servers.")
+
+(defvar gnus-level-subscribed 5
+ "*Groups with levels less than or equal to this variable are subscribed.")
+
+(defvar gnus-level-unsubscribed 7
+ "*Groups with levels less than or equal to this variable are unsubscribed.
+Groups with levels less than `gnus-level-subscribed', which should be
+less than this variable, are subscribed.")
+
+(defvar gnus-level-zombie 8
+ "*Groups with this level are zombie groups.")
+
+(defvar gnus-level-killed 9
+ "*Groups with this level are killed.")
+
+(defvar gnus-level-default-subscribed 3
+ "*New subscribed groups will be subscribed at this level.")
+
+(defvar gnus-level-default-unsubscribed 6
+ "*New unsubscribed groups will be unsubscribed at this level.")
+
+(defvar gnus-activate-foreign-newsgroups 4
+ "*If nil, Gnus will not check foreign newsgroups at startup.
+If it is non-nil, it should be a number between one and nine. Foreign
+newsgroups that have a level lower or equal to this number will be
+activated on startup. For instance, if you want to active all
+subscribed newsgroups, but not the rest, you'd set this variable to
+`gnus-level-subscribed'.
+
+If you subscribe to lots of newsgroups from different servers, startup
+might take a while. By setting this variable to nil, you'll save time,
+but you won't be told how many unread articles there are in the
+groups.")
+
+(defvar gnus-save-newsrc-file t
+ "*Non-nil means that Gnus will save the `.newsrc' file.
+Gnus always saves its own startup file, which is called
+\".newsrc.eld\". The file called \".newsrc\" is in a format that can
+be readily understood by other newsreaders. If you don't plan on
+using other newsreaders, set this variable to nil to save some time on
+exit.")
+
+(defvar gnus-save-killed-list t
+ "*If non-nil, save the list of killed groups to the startup file.
+This will save both time (when starting and quitting) and space (both
+memory and disk), but it will also mean that Gnus has no record of
+which groups are new and which are old, so the automatic new
+newsgroups subscription methods become meaningless. You should always
+set `gnus-check-new-newsgroups' to `ask-server' or nil if you set this
+variable to nil.")
+
+(defvar gnus-interactive-catchup t
+ "*If non-nil, require your confirmation when catching up a group.")
+
+(defvar gnus-interactive-post t
+ "*If non-nil, group name will be asked for when posting.")
+
+(defvar gnus-interactive-exit t
+ "*If non-nil, require your confirmation when exiting Gnus.")
+
+(defvar 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.")
+
+(defvar gnus-extract-address-components 'gnus-extract-address-components
+ "*Function for extracting address components from a From header.
+Two pre-defined function exist: `gnus-extract-address-components',
+which is the default, quite fast, and too simplistic solution, and
+`mail-extract-address-components', which works much better, but is
+slower.")
+
+(defvar gnus-summary-default-score 0
+ "*Default article score level.
+If this variable is nil, scoring will be disabled.")
+
+(defvar gnus-summary-zcore-fuzz 0
+ "*Fuzziness factor for the zcore in the summary buffer.
+Articles with scores closer than this to `gnus-summary-default-score'
+will not be marked.")
+
+(defvar gnus-simplify-subject-fuzzy-regexp nil
+ "*Regular expression that will be removed from subject strings if
+fuzzy subject simplification is selected.")
+
+(defvar gnus-group-default-list-level gnus-level-subscribed
+ "*Default listing level.
+Ignored if `gnus-group-use-permanent-levels' is non-nil.")
+
+(defvar gnus-group-use-permanent-levels nil
+ "*If non-nil, once you set a level, Gnus will use this level.")
+
+(defvar gnus-show-mime nil
+ "*If non-nil, do mime processing of articles.
+The articles will simply be fed to the function given by
+`gnus-show-mime-method'.")
+
+(defvar gnus-strict-mime t
+ "*If nil, decode MIME header even if there is not Mime-Version field.")
+
+(defvar gnus-show-mime-method (function metamail-buffer)
+ "*Function to process a MIME message.
+The function is called from the article buffer.")
+
+(defvar gnus-show-threads t
+ "*If non-nil, display threads in summary mode.")
+
+(defvar gnus-thread-hide-subtree nil
+ "*If non-nil, hide all threads initially.
+If threads are hidden, you have to run the command
+`gnus-summary-show-thread' by hand or use `gnus-select-article-hook'
+to expose hidden threads.")
+
+(defvar gnus-thread-hide-killed t
+ "*If non-nil, hide killed threads automatically.")
+
+(defvar gnus-thread-ignore-subject nil
+ "*If non-nil, ignore subjects and do all threading based on the Reference header.
+If nil, which is the default, articles that have different subjects
+from their parents will start separate threads.")
+
+(defvar gnus-thread-indent-level 4
+ "*Number that says how much each sub-thread should be indented.")
+
+(defvar gnus-ignored-newsgroups
+ (purecopy (mapconcat 'identity
+ '("^to\\." ; not "real" groups
+ "^[0-9. \t]+ " ; all digits in name
+ "[][\"#'()]" ; bogus characters
+ )
+ "\\|"))
+ "*A regexp to match uninteresting newsgroups in the active file.
+Any lines in the active file matching this regular expression are
+removed from the newsgroup list before anything else is done to it,
+thus making them effectively non-existent.")
+
+(defvar gnus-ignored-headers
+ "^Path:\\|^Posting-Version:\\|^Article-I.D.:\\|^Expires:\\|^Date-Received:\\|^References:\\|^Control:\\|^Xref:\\|^Lines:\\|^Posted:\\|^Relay-Version:\\|^Message-ID:\\|^Nf-ID:\\|^Nf-From:\\|^Approved:\\|^Sender:\\|^Received:\\|^Mail-from:"
+ "*All headers that match this regexp will be hidden.
+If `gnus-visible-headers' is non-nil, this variable will be ignored.")
+
+(defvar gnus-visible-headers "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^Cc:"
+ "*All headers that do not match this regexp will be hidden.
+If this variable is non-nil, `gnus-ignored-headers' will be ignored.")
+
+(defvar gnus-sorted-header-list
+ '("^From:" "^Subject:" "^Summary:" "^Keywords:" "^Newsgroups:" "^To:"
+ "^Cc:" "^Date:" "^Organization:")
+ "*This variable is a list of regular expressions.
+If it is non-nil, headers that match the regular expressions will
+be placed first in the article buffer in the sequence specified by
+this list.")
+
+(defvar gnus-show-all-headers nil
+ "*If non-nil, don't hide any headers.")
+
+(defvar gnus-save-all-headers t
+ "*If non-nil, don't remove any headers before saving.")
+
+(defvar gnus-inhibit-startup-message nil
+ "*If non-nil, the startup message will not be displayed.")
+
+(defvar gnus-signature-separator "^-- *$"
+ "Regexp matching signature separator.")
+
+(defvar gnus-auto-extend-newsgroup t
+ "*If non-nil, extend newsgroup forward and backward when requested.")
+
+(defvar gnus-auto-select-first t
+ "*If non-nil, select the first unread article when entering a group.
+If you want to prevent automatic selection of the first unread article
+in some newsgroups, set the variable to nil in
+`gnus-select-group-hook'.")
+
+(defvar gnus-auto-select-next t
+ "*If non-nil, offer to go to the next group from the end of the previous.
+If the value is t and the next newsgroup is empty, Gnus will exit
+summary mode and go back to group mode. If the value is neither nil
+nor t, Gnus will select the following unread newsgroup. In
+particular, if the value is the symbol `quietly', the next unread
+newsgroup will be selected without any confirmations.")
+
+(defvar gnus-auto-select-same nil
+ "*If non-nil, select the next article with the same subject.")
+
+(defvar gnus-summary-check-current nil
+ "*If non-nil, consider the current article when moving.
+The \"unread\" movement commands will stay on the same line if the
+current article is unread.")
+
+(defvar gnus-auto-center-summary t
+ "*If non-nil, always center the current summary buffer.")
+
+(defvar gnus-break-pages t
+ "*If non-nil, do page breaking on articles.
+The page delimiter is specified by the `gnus-page-delimiter'
+variable.")
+
+(defvar gnus-page-delimiter "^\^L"
+ "*Regexp describing what to use as article page delimiters.
+The default value is \"^\^L\", which is a form linefeed at the
+beginning of a line.")
+
+(defvar gnus-use-full-window t
+ "*If non-nil, use the entire Emacs screen.")
+
+(defvar gnus-window-configuration nil
+ "Obsolete variable. See `gnus-buffer-configuration'.")
+
+(defvar gnus-buffer-configuration
+ '((group ([group 1.0 point]
+ (if gnus-carpal [group-carpal 4])))
+ (summary ([summary 1.0 point]
+ (if gnus-carpal [summary-carpal 4])))
+ (article ([summary 0.25 point]
+ (if gnus-carpal [summary-carpal 4])
+ [article 1.0]))
+ (server ([server 1.0 point]
+ (if gnus-carpal [server-carpal 2])))
+ (browse ([browse 1.0 point]
+ (if gnus-carpal [browse-carpal 2])))
+ (group-mail ([mail 1.0 point]))
+ (summary-mail ([mail 1.0 point]))
+ (summary-reply ([article 0.5]
+ [mail 1.0 point]))
+ (info ([nil 1.0 point]))
+ (summary-faq ([summary 0.25]
+ [faq 1.0 point]))
+ (edit-group ([group 0.5]
+ [edit-group 1.0 point]))
+ (edit-server ([server 0.5]
+ [edit-server 1.0 point]))
+ (edit-score ([summary 0.25]
+ [edit-score 1.0 point]))
+ (post ([post 1.0 point]))
+ (reply ([article 0.5]
+ [mail 1.0 point]))
+ (mail-forward ([mail 1.0 point]))
+ (post-forward ([post 1.0 point]))
+ (reply-yank ([mail 1.0 point]))
+ (followup ([article 0.5]
+ [post 1.0 point]))
+ (followup-yank ([post 1.0 point])))
+ "Window configuration for all possible Gnus buffers.
+This variable is a list of lists. Each of these lists has a NAME and
+a RULE. The NAMEs are commonsense names like `group', which names a
+rule used when displaying the group buffer; `summary', which names a
+rule for what happens when you enter a group and do not display an
+article buffer; and so on. See the value of this variable for a
+complete list of NAMEs.
+
+Each RULE is a list of vectors. The first element in this vector is
+the name of the buffer to be displayed; the second element is the
+percentage of the screen this buffer is to occupy (a number in the
+0.0-0.99 range); the optional third element is `point', which should
+be present to denote which buffer point is to go to after making this
+buffer configuration.")
+
+(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-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)
+ (mail . gnus-mail-buffer)
+ (post . gnus-post-news-buffer)
+ (faq . gnus-faq-buffer))
+ "Mapping from short symbols to buffer names or buffer variables.")
+
+(defvar gnus-carpal nil
+ "*If non-nil, display clickable icons.")
+
+(defvar gnus-subscribe-newsgroup-method 'gnus-subscribe-zombies
+ "*Function called with a group name when new group is detected.
+A few pre-made functions are supplied: `gnus-subscribe-randomly'
+inserts new groups at the beginning of the list of groups;
+`gnus-subscribe-alphabetically' inserts new groups in strict
+alphabetic order; `gnus-subscribe-hierarchically' inserts new groups
+in hierarchical newsgroup order; `gnus-subscribe-interactively' asks
+for your decision.")
+
+;; Suggested by a bug report by Hallvard B Furuseth.
+;; <h.b.furuseth@usit.uio.no>.
+(defvar gnus-subscribe-options-newsgroup-method
+ (function gnus-subscribe-alphabetically)
+ "*This function is called to subscribe newsgroups mentioned on \"options -n\" lines.
+If, for instance, you want to subscribe to all newsgroups in the
+\"no\" and \"alt\" hierarchies, you'd put the following in your
+.newsrc file:
+
+options -n no.all alt.all
+
+Gnus will the subscribe all new newsgroups in these hierarchies with
+the subscription method in this variable.")
+
+(defvar gnus-subscribe-hierarchical-interactive nil
+ "*If non-nil, Gnus will offer to subscribe hierarchically.
+When a new hierarchy appears, Gnus will ask the user:
+
+'alt.binaries': Do you want to subscribe to this hierarchy? ([d]ys):
+
+If the user pressed `d', Gnus will descend the hierarchy, `y' will
+subscribe to all newsgroups in the hierarchy and `s' will skip this
+hierarchy in its entirety.")
+
+(defvar gnus-group-sort-function 'gnus-group-sort-by-alphabet
+ "*Function used for sorting the group buffer.
+This function will be called with group info entries as the arguments
+for the groups to be sorted. Pre-made functions include
+`gnus-group-sort-by-alphabet', `gnus-group-sort-by-unread' and
+`gnus-group-sort-by-level'")
+
+;; Mark variables suggested by Thomas Michanek
+;; <Thomas.Michanek@telelogic.se>.
+(defvar gnus-unread-mark ?
+ "*Mark used for unread articles.")
+(defvar gnus-ticked-mark ?!
+ "*Mark used for ticked articles.")
+(defvar gnus-dormant-mark ??
+ "*Mark used for dormant articles.")
+(defvar gnus-del-mark ?r
+ "*Mark used for del'd articles.")
+(defvar gnus-read-mark ?R
+ "*Mark used for read articles.")
+(defvar gnus-expirable-mark ?E
+ "*Mark used for expirable articles.")
+(defvar gnus-killed-mark ?K
+ "*Mark used for killed articles.")
+(defvar gnus-kill-file-mark ?X
+ "*Mark used for articles killed by kill files.")
+(defvar gnus-low-score-mark ?Y
+ "*Mark used for articles with a low score.")
+(defvar gnus-catchup-mark ?C
+ "*Mark used for articles that are caught up.")
+(defvar gnus-replied-mark ?A
+ "*Mark used for articles that have been replied to.")
+(defvar gnus-process-mark ?#
+ "*Process mark.")
+(defvar gnus-ancient-mark ?O
+ "*Mark used for ancient articles.")
+(defvar gnus-canceled-mark ?G
+ "*Mark used for canceled articles.")
+(defvar gnus-score-over-mark ?+
+ "*Score mark used for articles with high scores.")
+(defvar gnus-score-below-mark ?-
+ "*Score mark used for articles with low scores.")
+(defvar gnus-empty-thread-mark ?
+ "*There is no thread under the article.")
+(defvar gnus-not-empty-thread-mark ?=
+ "*There is a thread under the article.")
+(defvar gnus-dummy-mark ?Z
+ "*This is a dummy article.")
+
+(defvar gnus-view-pseudo-asynchronously nil
+ "*If non-nil, Gnus will view pseudo-articles asynchronously.")
+
+(defvar gnus-view-pseudos nil
+ "*If `automatic', pseudo-articles will be viewed automatically.
+If `not-confirm', pseudos will be viewed automatically, and the user
+will not be asked to confirm the command.")
+
+(defvar gnus-view-pseudos-separately t
+ "*If non-nil, one pseudo-article will be created for each file to be viewed.
+If nil, all files that use the same viewing command will be given as a
+list of parameters to that command.")
+
+(defvar gnus-group-line-format "%M%S%p%5y: %(%g%)\n"
+ "*Format of group lines.
+It works along the same lines as a normal formatting string,
+with some simple extensions.
+
+%M Only marked articles (character, \"*\" or \" \")
+%S Whether the group is subscribed (character, \"U\", \"K\", \"Z\" or \" \")
+%L Level of subscribedness (integer)
+%N Number of unread articles (integer)
+%I Number of dormant articles (integer)
+%i Number of ticked and dormant (integer)
+%T Number of ticked articles (integer)
+%R Number of read articles (integer)
+%t Total number of articles (integer)
+%y Number of unread, unticked articles (integer)
+%G Group name (string)
+%g Qualified group name (string)
+%D Group description (string)
+%s Select method (string)
+%o Moderated group (char, \"m\")
+%p Process mark (char)
+%O Moderated group (string, \"(m)\" or \"\")
+%n Select from where (string)
+%z A string that look like `<%s:%n>' if a foreign select method is used
+%u User defined specifier. The next character in the format string should
+ be a letter. Gnus will call the function gnus-user-format-function-X,
+ where X is the letter following %u. The function will be passed the
+ current header as argument. The function should return a string, which
+ will be inserted into the buffer just like information from any other
+ group specifier.
+
+Text between %( and %) will be highlighted with `gnus-mouse-face' when
+the mouse point move inside the area. There can only be one such area.
+
+Note that this format specification is not always respected. For
+reasons of efficiency, when listing killed groups, this specification
+is ignored altogether. If the spec is changed considerably, your
+output may end up looking strange when listing both alive and killed
+groups.
+
+If you use %o or %O, reading the active file will be slower and quite
+a bit of extra memory will be used. %D will also worsen performance.
+Also note that if you change the format specification to include any
+of these specs, you must probably re-start Gnus to see them go into
+effect.")
+
+(defvar gnus-summary-line-format "%U%R%z%I%(%[%4L: %-20,20n%]%) %s\n"
+ "*The format specification of the lines in the summary buffer.
+
+It works along the same lines as a normal formatting string,
+with some simple extensions.
+
+%N Article number, left padded with spaces (string)
+%S Subject (string)
+%s Subject if it is at the root of a thread, and \"\" otherwise (string)
+%n Name of the poster (string)
+%a Extracted name of the poster (string)
+%A Extracted address of the poster (string)
+%F Contents of the From: header (string)
+%x Contents of the Xref: header (string)
+%D Date of the article (string)
+%d Date of the article (string) in DD-MMM format
+%M Message-id of the article (string)
+%r References of the article (string)
+%c Number of characters in the article (integer)
+%L Number of lines in the article (integer)
+%I Indentation based on thread level (a string of spaces)
+%T A string with two possible values: 80 spaces if the article
+ is on thread level two or larger and 0 spaces on level one
+%R \"A\" if this article has been replied to, \" \" otherwise (character)
+%U Status of this article (character, \"R\", \"K\", \"-\" or \" \")
+%[ Opening bracket (character, \"[\" or \"<\")
+%] Closing bracket (character, \"]\" or \">\")
+%> Spaces of length thread-level (string)
+%< Spaces of length (- 20 thread-level) (string)
+%i Article score (number)
+%z Article zcore (character)
+%t Number of articles under the current thread (number).
+%e Whether the thread is empty or not (character).
+%u User defined specifier. The next character in the format string should
+ be a letter. Gnus will call the function gnus-user-format-function-X,
+ where X is the letter following %u. The function will be passed the
+ current header as argument. The function should return a string, which
+ will be inserted into the summary just like information from any other
+ summary specifier.
+
+Text between %( and %) will be highlighted with `gnus-mouse-face'
+when the mouse point is placed inside the area. There can only be one
+such area.
+
+The %U (status), %R (replied) and %z (zcore) specs have to be handled
+with care. For reasons of efficiency, Gnus will compute what column
+these characters will end up in, and \"hard-code\" that. This means that
+it is illegal to have these specs after a variable-length spec. Well,
+you might not be arrested, but your summary buffer will look strange,
+which is bad enough.
+
+The smart choice is to have these specs as for to the left as
+possible.
+
+This restriction may disappear in later versions of Gnus.")
+
+(defvar gnus-summary-dummy-line-format "* : : %S\n"
+ "*The format specification for the dummy roots in the summary buffer.
+It works along the same lines as a normal formatting string,
+with some simple extensions.
+
+%S The subject")
+
+(defvar gnus-summary-mode-line-format "Gnus %G/%A %Z"
+ "*The format specification for the summary mode line.")
+
+(defvar gnus-article-mode-line-format "Gnus %G/%A %S"
+ "*The format specification for the article mode line.")
+
+(defvar gnus-group-mode-line-format "Gnus List of groups {%M:%S} "
+ "*The format specification for the group mode line.")
+
+(defvar gnus-valid-select-methods
+ '(("nntp" post address prompt-address)
+ ("nnspool" post)
+ ("nnvirtual" none virtual prompt-address)
+ ("nnmbox" mail respool)
+ ("nnml" mail respool)
+ ("nnmh" mail respool)
+ ("nndir" none prompt-address address)
+ ("nneething" none prompt-address)
+ ("nndigest" none)
+ ("nndoc" none prompt-address)
+ ("nnbabyl" mail respool)
+ ("nnkiboze" post virtual)
+ ;;("nnsoup" post)
+ ("nnfolder" mail respool))
+ "An alist of valid select methods.
+The first element of each list lists should be a string with the name
+of the select method. The other elements may be be the category of
+this method (ie. `post', `mail', `none' or whatever) or other
+properties that this method has (like being respoolable).
+If you implement a new select method, all you should have to change is
+this variable. I think.")
+
+(defvar gnus-updated-mode-lines '(group article summary)
+ "*List of buffers that should update their mode lines.
+The list may contain the symbols `group', `article' and `summary'. If
+the corresponding symbol is present, Gnus will keep that mode line
+updated with information that may be pertinent.
+If this variable is nil, screen refresh may be quicker.")
+
+;; Added by Keinonen Kari <kk85613@cs.tut.fi>.
+(defvar gnus-mode-non-string-length 21
+ "*Max length of mode-line non-string contents.
+If this is nil, Gnus will take space as is needed, leaving the rest
+of the modeline intact.")
+
+;see gnus-cus.el
+;(defvar gnus-mouse-face 'highlight
+; "*Face used for mouse highlighting in Gnus.
+;No mouse highlights will be done if `gnus-visual' is nil.")
+
+(defvar gnus-summary-mark-below nil
+ "*Mark all articles with a score below this variable as read.
+This variable is local to each summary buffer and usually set by the
+score file.")
+
+(defvar gnus-thread-sort-functions '(gnus-thread-sort-by-number)
+ "*List of functions used for sorting threads in the summary buffer.
+By default, threads are sorted by article number.
+
+Each function takes two threads and return non-nil if the first thread
+should be sorted before the other. If you use more than one function,
+the primary sort function should be the last.
+
+Ready-mady functions include `gnus-thread-sort-by-number',
+`gnus-thread-sort-by-author', `gnus-thread-sort-by-subject',
+`gnus-thread-sort-by-date', `gnus-thread-sort-by-score' and
+`gnus-thread-sort-by-total-score' (see `gnus-thread-score-function').")
+
+(defvar gnus-thread-score-function '+
+ "*Function used for calculating the total score of a thread.
+
+The function is called with the scores of the article and each
+subthread and should then return the score of the thread.
+
+Some functions you can use are `+', `max', or `min'.")
+
+(defvar gnus-options-subscribe nil
+ "*All new groups matching this regexp will be subscribed unconditionally.
+Note that this variable deals only with new newsgroups. This variable
+does not affect old newsgroups.")
+
+(defvar gnus-options-not-subscribe nil
+ "*All new groups matching this regexp will be ignored.
+Note that this variable deals only with new newsgroups. This variable
+does not affect old (already subscribed) newsgroups.")
+
+(defvar gnus-auto-expirable-newsgroups nil
+ "*Groups in which to automatically mark read articles as expirable.
+If non-nil, this should be a regexp that should match all groups in
+which to perform auto-expiry. This only makes sense for mail groups.")
+
+(defvar gnus-hidden-properties '(invisible t intangible t)
+ "Property list to use for hiding text.")
+
+(defvar gnus-modtime-botch nil
+ "*Non-nil means .newsrc should be deleted prior to save. Its use is
+due to the bogus appearance that .newsrc was modified on disc.")
+
+;; Hooks.
+
+(defvar gnus-group-mode-hook nil
+ "*A hook for Gnus group mode.")
+
+(defvar gnus-summary-mode-hook nil
+ "*A hook for Gnus summary mode.
+This hook is run before any variables are set in the summary buffer.")
+
+(defvar gnus-article-mode-hook nil
+ "*A hook for Gnus article mode.")
+
+(defun gnus-summary-prepare-exit-hook nil
+ "*A hook called when preparing to exit from the summary buffer.
+It calls `gnus-summary-expire-articles' by default.")
+(add-hook 'gnus-summary-prepare-exit-hook 'gnus-summary-expire-articles)
+
+(defun gnus-summary-exit-hook nil
+ "*A hook called on exit from the summary buffer.")
+
+(defvar gnus-open-server-hook nil
+ "*A hook called just before opening connection to the news server.")
+
+(defvar gnus-load-hook nil
+ "*A hook run while Gnus is loaded.")
+
+(defvar gnus-startup-hook nil
+ "*A hook called at startup.
+This hook is called after Gnus is connected to the NNTP server.")
+
+(defvar gnus-get-new-news-hook nil
+ "*A hook run just before Gnus checks for new news.")
+
+(defvar gnus-group-prepare-function 'gnus-group-prepare-flat
+ "*A function that is called to generate the group buffer.
+The function is called with three arguments: The first is a number;
+all group with a level less or equal to that number should be listed,
+if the second is non-nil, empty groups should also be displayed. If
+the third is non-nil, it is a number. No groups with a level lower
+than this number should be displayed.
+
+The only current function implemented is `gnus-group-prepare-flat'.")
+
+(defvar gnus-group-prepare-hook nil
+ "*A hook called after the group buffer has been generated.
+If you want to modify the group buffer, you can use this hook.")
+
+(defvar gnus-summary-prepare-hook nil
+ "*A hook called after the summary buffer has been generated.
+If you want to modify the summary buffer, you can use this hook.")
+
+(defvar gnus-article-prepare-hook nil
+ "*A hook called after an article has been prepared in the article buffer.
+If you want to run a special decoding program like nkf, use this hook.")
+
+;(defvar gnus-article-display-hook nil
+; "*A hook called after the article is displayed in the article buffer.
+;The hook is designed to change the contents of the article
+;buffer. Typical functions that this hook may contain are
+;`gnus-article-hide-headers' (hide selected headers),
+;`gnus-article-maybe-highlight' (perform fancy article highlighting),
+;`gnus-article-hide-signature' (hide signature) and
+;`gnus-article-treat-overstrike' (turn \"^H_\" into bold characters).")
+;(add-hook 'gnus-article-display-hook 'gnus-article-hide-headers-if-wanted)
+;(add-hook 'gnus-article-display-hook 'gnus-article-treat-overstrike)
+;(add-hook 'gnus-article-display-hook 'gnus-article-maybe-highlight)
+
+(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.")
+
+(defvar gnus-article-x-face-too-ugly nil
+ "Regexp matching posters whose face shouldn't be shown automatically.")
+
+(defvar gnus-select-group-hook nil
+ "*A hook called when a newsgroup is selected.
+
+If you'd like to simplify subjects like the
+`gnus-summary-next-same-subject' command does, you can use the
+following hook:
+
+ (setq gnus-select-group-hook
+ (list
+ (lambda ()
+ (mapcar (lambda (header)
+ (mail-header-set-subject
+ header
+ (gnus-simplify-subject
+ (mail-header-subject header) 're-only)))
+ gnus-newsgroup-headers))))")
+
+(defvar gnus-select-article-hook
+ '(gnus-summary-show-thread)
+ "*A hook called when an article is selected.
+The default hook shows conversation thread subtrees of the selected
+article automatically using `gnus-summary-show-thread'.")
+
+(defvar gnus-apply-kill-hook '(gnus-apply-kill-file)
+ "*A hook called to apply kill files to a group.
+This hook is intended to apply a kill file to the selected newsgroup.
+The function `gnus-apply-kill-file' is called by default.
+
+Since a general kill file is too heavy to use only for a few
+newsgroups, I recommend you to use a lighter hook function. For
+example, if you'd like to apply a kill file to articles which contains
+a string `rmgroup' in subject in newsgroup `control', you can use the
+following hook:
+
+ (setq gnus-apply-kill-hook
+ (list
+ (lambda ()
+ (cond ((string-match \"control\" gnus-newsgroup-name)
+ (gnus-kill \"Subject\" \"rmgroup\")
+ (gnus-expunge \"X\"))))))")
+
+(defvar gnus-visual-mark-article-hook
+ (list 'gnus-highlight-selected-summary)
+ "*Hook run after selecting an article in the summary buffer.
+It is meant to be used for highlighting the article in some way. It
+is not run if `gnus-visual' is nil.")
+
+(defvar gnus-exit-group-hook nil
+ "*A hook called when exiting (not quitting) summary mode.")
+
+(defvar gnus-suspend-gnus-hook nil
+ "*A hook called when suspending (not exiting) Gnus.")
+
+(defvar gnus-exit-gnus-hook nil
+ "*A hook called when exiting Gnus.")
+
+(defvar gnus-save-newsrc-hook nil
+ "*A hook called when saving the newsrc file.")
+
+(defvar gnus-summary-update-hook
+ (list 'gnus-summary-highlight-line)
+ "*A hook called when a summary line is changed.
+The hook will not be called if `gnus-visual' is nil.
+
+The default function `gnus-summary-highlight-line' will
+highlight the line according to the `gnus-summary-highlight'
+variable.")
+
+(defvar gnus-mark-article-hook (list 'gnus-summary-mark-unread-as-read)
+ "*A hook called when an article is selected for the first time.
+The hook is intended to mark an article as read (or unread)
+automatically when it is selected.")
+
+;; Remove any hilit infestation.
+(add-hook 'gnus-startup-hook
+ (lambda ()
+ (remove-hook 'gnus-summary-prepare-hook
+ 'hilit-rehighlight-buffer-quietly)
+ (remove-hook 'gnus-summary-prepare-hook 'hilit-install-line-hooks)
+ (setq gnus-mark-article-hook '(gnus-summary-mark-unread-as-read))
+ (remove-hook 'gnus-article-prepare-hook
+ 'hilit-rehighlight-buffer-quietly)))
+
+
+
+;; Internal variables
+
+;; Avoid highlighting in kill files.
+(defvar gnus-summary-inhibit-highlight nil)
+(defvar gnus-newsgroup-selected-overlay nil)
+
+(defvar gnus-article-mode-map nil)
+(defvar gnus-dribble-buffer nil)
+(defvar gnus-headers-retrieved-by nil)
+(defvar gnus-article-reply nil)
+(defvar gnus-override-method nil)
+(defvar gnus-article-check-size nil)
+
+(defvar gnus-current-score-file nil)
+(defvar gnus-internal-global-score-files nil)
+(defvar gnus-score-file-list nil)
+(defvar gnus-scores-exclude-files nil)
+
+(defvar gnus-current-move-group nil)
+
+(defvar gnus-newsgroup-dependencies nil)
+(defvar gnus-newsgroup-threads nil)
+(defvar gnus-newsgroup-async nil)
+(defconst gnus-group-edit-buffer "*Gnus edit newsgroup*")
+
+(defvar gnus-newsgroup-adaptive nil)
+
+(defvar gnus-summary-display-table nil)
+
+(defconst gnus-group-line-format-alist
+ (list (list ?M 'marked ?c)
+ (list ?S 'subscribed ?c)
+ (list ?L 'level ?d)
+ (list ?N 'number ?s)
+ (list ?I 'number-of-dormant ?d)
+ (list ?T 'number-of-ticked ?d)
+ (list ?R 'number-of-read ?s)
+ (list ?t 'number-total ?d)
+ (list ?y 'number-of-unread-unticked ?s)
+ (list ?i 'number-of-ticked-and-dormant ?d)
+ (list ?g 'group ?s)
+ (list ?G 'qualified-group ?s)
+ (list ?D 'newsgroup-description ?s)
+ (list ?o 'moderated ?c)
+ (list ?O 'moderated-string ?s)
+ (list ?p 'process-marked ?c)
+ (list ?s 'news-server ?s)
+ (list ?n 'news-method ?s)
+ (list ?z 'news-method-string ?s)
+ (list ?u 'user-defined ?s)))
+
+(defconst gnus-summary-line-format-alist
+ (list (list ?N 'number ?d)
+ (list ?S 'subject ?s)
+ (list ?s 'subject-or-nil ?s)
+ (list ?n 'name ?s)
+ (list ?A '(car (cdr (funcall gnus-extract-address-components from)))
+ ?s)
+ (list ?a '(or (car (funcall gnus-extract-address-components from))
+ from) ?s)
+ (list ?F 'from ?s)
+ (list ?x (macroexpand '(mail-header-xref header)) ?s)
+ (list ?D (macroexpand '(mail-header-date header)) ?s)
+ (list ?d '(gnus-dd-mmm (mail-header-date header)) ?s)
+ (list ?M (macroexpand '(mail-header-id header)) ?s)
+ (list ?r (macroexpand '(mail-header-references header)) ?s)
+ (list ?c '(or (mail-header-chars header) 0) ?d)
+ (list ?L 'lines ?d)
+ (list ?I 'indentation ?s)
+ (list ?T '(if (= level 0) "" (make-string (frame-width) ? )) ?s)
+ (list ?R 'replied ?c)
+ (list ?\[ 'opening-bracket ?c)
+ (list ?\] 'closing-bracket ?c)
+ (list ?\> '(make-string level ? ) ?s)
+ (list ?\< '(make-string (max 0 (- 20 level)) ? ) ?s)
+ (list ?i 'score ?d)
+ (list ?z 'score-char ?c)
+ (list ?U 'unread ?c)
+ (list ?t '(gnus-summary-number-of-articles-in-thread
+ (and (boundp 'thread) (car thread)))
+ ?d)
+ (list ?e '(gnus-summary-number-of-articles-in-thread
+ (and (boundp 'thread) (car thread)) t)
+ ?c)
+ (list ?u 'user-defined ?s))
+ "An alist of format specifications that can appear in summary lines,
+and what variables they correspond with, along with the type of the
+variable (string, integer, character, etc).")
+
+(defconst gnus-summary-dummy-line-format-alist
+ (list (list ?S 'subject ?s)
+ (list ?N 'number ?d)
+ (list ?u 'user-defined ?s)))
+
+(defconst gnus-summary-mode-line-format-alist
+ (list (list ?G 'group-name ?s)
+ (list ?g '(gnus-short-group-name group-name) ?s)
+ (list ?A 'article-number ?d)
+ (list ?Z 'unread-and-unselected ?s)
+ (list ?V 'gnus-version ?s)
+ (list ?U 'unread ?d)
+ (list ?S 'subject ?s)
+ (list ?e 'unselected ?d)
+ (list ?u 'user-defined ?s)
+ (list ?s '(gnus-current-score-file-nondirectory) ?s)))
+
+(defconst gnus-group-mode-line-format-alist
+ (list (list ?S 'news-server ?s)
+ (list ?M 'news-method ?s)
+ (list ?u 'user-defined ?s)))
+
+(defvar gnus-have-read-active-file nil)
+
+(defconst gnus-maintainer
+ "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls + Boys)"
+ "The mail address of the Gnus maintainers.")
+
+(defconst gnus-version "Gnus v5.1"
+ "Version number for this version of Gnus.")
+
+(defvar gnus-info-nodes
+ '((gnus-group-mode "(gnus)The Group Buffer")
+ (gnus-summary-mode "(gnus)The Summary Buffer")
+ (gnus-article-mode "(gnus)The Article Buffer"))
+ "Assoc list of major modes and related Info nodes.")
+
+(defvar gnus-group-buffer "*Group*")
+(defvar gnus-summary-buffer "*Summary*")
+(defvar gnus-article-buffer "*Article*")
+(defvar gnus-server-buffer "*Server*")
+
+(defvar gnus-work-buffer " *gnus work*")
+
+(defvar gnus-buffer-list nil
+ "Gnus buffers that should be killed on exit.")
+
+(defvar gnus-server-alist nil
+ "List of available servers.")
+
+(defvar gnus-variable-list
+ '(gnus-newsrc-options gnus-newsrc-options-n
+ gnus-newsrc-last-checked-date
+ gnus-newsrc-alist gnus-server-alist
+ gnus-killed-list gnus-zombie-list)
+ "Gnus variables saved in the quick startup file.")
+
+(defvar gnus-overload-functions
+ '((news-inews gnus-inews-news "rnewspost"))
+ "Functions overloaded by gnus.
+It is a list of `(original overload &optional file)'.")
+
+(defvar gnus-newsrc-options nil
+ "Options line in the .newsrc file.")
+
+(defvar gnus-newsrc-options-n nil
+ "List of regexps representing groups to be subscribed/ignored unconditionally.")
+
+(defvar gnus-newsrc-last-checked-date nil
+ "Date Gnus last asked server for new newsgroups.")
+
+(defvar gnus-newsrc-alist nil
+ "Assoc list of read articles.
+gnus-newsrc-hashtb should be kept so that both hold the same information.")
+
+(defvar gnus-newsrc-hashtb nil
+ "Hashtable of gnus-newsrc-alist.")
+
+(defvar gnus-killed-list nil
+ "List of killed newsgroups.")
+
+(defvar gnus-killed-hashtb nil
+ "Hash table equivalent of gnus-killed-list.")
+
+(defvar gnus-zombie-list nil
+ "List of almost dead newsgroups.")
+
+(defvar gnus-description-hashtb nil
+ "Descriptions of newsgroups.")
+
+(defvar gnus-list-of-killed-groups nil
+ "List of newsgroups that have recently been killed by the user.")
+
+(defvar gnus-active-hashtb nil
+ "Hashtable of active articles.")
+
+(defvar gnus-moderated-list nil
+ "List of moderated newsgroups.")
+
+(defvar gnus-group-marked nil)
+
+(defvar gnus-current-startup-file nil
+ "Startup file for the current host.")
+
+(defvar gnus-last-search-regexp nil
+ "Default regexp for article search command.")
+
+(defvar gnus-last-shell-command nil
+ "Default shell command on article.")
+
+(defvar gnus-current-select-method nil
+ "The current method for selecting a newsgroup.")
+
+(defvar gnus-group-list-mode nil)
+
+(defvar gnus-article-internal-prepare-hook nil)
+
+(defvar gnus-newsgroup-name nil)
+(defvar gnus-newsgroup-begin nil)
+(defvar gnus-newsgroup-end nil)
+(defvar gnus-newsgroup-last-rmail nil)
+(defvar gnus-newsgroup-last-mail nil)
+(defvar gnus-newsgroup-last-folder nil)
+(defvar gnus-newsgroup-last-file nil)
+(defvar gnus-newsgroup-auto-expire nil)
+(defvar gnus-newsgroup-active nil)
+
+(defvar gnus-newsgroup-unreads nil
+ "List of unread articles in the current newsgroup.")
+
+(defvar gnus-newsgroup-unselected nil
+ "List of unselected unread articles in the current newsgroup.")
+
+(defvar gnus-newsgroup-reads nil
+ "Alist of read articles and article marks in the current newsgroup.")
+
+(defvar gnus-newsgroup-marked nil
+ "List of ticked articles in the current newsgroup (a subset of unread art).")
+
+(defvar gnus-newsgroup-killed nil
+ "List of ranges of articles that have been through the scoring process.")
+
+(defvar gnus-newsgroup-kill-headers nil)
+
+(defvar gnus-newsgroup-replied nil
+ "List of articles that have been replied to in the current newsgroup.")
+
+(defvar gnus-newsgroup-expirable nil
+ "List of articles in the current newsgroup that can be expired.")
+
+(defvar gnus-newsgroup-processable nil
+ "List of articles in the current newsgroup that can be processed.")
+
+(defvar gnus-newsgroup-bookmarks nil
+ "List of articles in the current newsgroup that have bookmarks.")
+
+(defvar gnus-newsgroup-dormant nil
+ "List of dormant articles in the current newsgroup.")
+
+(defvar gnus-newsgroup-scored nil
+ "List of scored articles in the current newsgroup.")
+
+(defvar gnus-newsgroup-headers nil
+ "List of article headers in the current newsgroup.")
+(defvar gnus-newsgroup-headers-hashtb-by-number nil)
+
+(defvar gnus-newsgroup-ancient nil
+ "List of `gnus-fetch-old-headers' articles in the current newsgroup.")
+
+(defvar gnus-current-article nil)
+(defvar gnus-article-current nil)
+(defvar gnus-current-headers nil)
+(defvar gnus-have-all-headers nil)
+(defvar gnus-last-article nil)
+(defvar gnus-newsgroup-history nil)
+(defvar gnus-current-kill-article nil)
+
+;; Save window configuration.
+(defvar gnus-prev-winconf nil)
+
+;; Format specs
+(defvar gnus-summary-line-format-spec nil)
+(defvar gnus-summary-dummy-line-format-spec nil)
+(defvar gnus-group-line-format-spec nil)
+(defvar gnus-summary-mode-line-format-spec nil)
+(defvar gnus-article-mode-line-format-spec nil)
+(defvar gnus-group-mode-line-format-spec nil)
+(defvar gnus-summary-mark-positions nil)
+(defvar gnus-group-mark-positions nil)
+
+(defvar gnus-summary-expunge-below nil)
+(defvar gnus-reffed-article-number nil)
+
+; Let the byte-compiler know that we know about this variable.
+(defvar rmail-default-rmail-file)
+
+(defvar gnus-cache-removeable-articles nil)
+
+(defconst gnus-summary-local-variables
+ '(gnus-newsgroup-name
+ gnus-newsgroup-begin gnus-newsgroup-end
+ gnus-newsgroup-last-rmail gnus-newsgroup-last-mail
+ gnus-newsgroup-last-folder gnus-newsgroup-last-file
+ gnus-newsgroup-auto-expire gnus-newsgroup-unreads
+ gnus-newsgroup-unselected gnus-newsgroup-marked
+ gnus-newsgroup-reads
+ gnus-newsgroup-replied gnus-newsgroup-expirable
+ gnus-newsgroup-processable gnus-newsgroup-killed
+ gnus-newsgroup-bookmarks gnus-newsgroup-dormant
+ gnus-newsgroup-headers gnus-newsgroup-headers-hashtb-by-number
+ gnus-current-article gnus-current-headers gnus-have-all-headers
+ gnus-last-article gnus-article-internal-prepare-hook
+ gnus-newsgroup-dependencies gnus-newsgroup-selected-overlay
+ gnus-newsgroup-scored gnus-newsgroup-kill-headers
+ gnus-newsgroup-threads gnus-newsgroup-async
+ gnus-score-alist gnus-current-score-file gnus-summary-expunge-below
+ gnus-summary-mark-below gnus-newsgroup-active gnus-scores-exclude-files
+ gnus-newsgroup-history gnus-newsgroup-ancient
+ (gnus-newsgroup-adaptive . gnus-use-adaptive-scoring)
+ gnus-cache-removeable-articles)
+ "Variables that are buffer-local to the summary buffers.")
+
+(defconst gnus-bug-message
+ "Sending a bug report to the Gnus Towers.
+========================================
+
+The buffer below is a mail buffer. When you press `C-c C-c', it will
+be sent to the Gnus Bug Exterminators.
+
+At the bottom of the buffer you'll see lots of variable settings.
+Please do not delete those. They will tell the Bug People what your
+environment is, so that it will be easier to locate the bugs.
+
+If you have found a bug that makes Emacs go \"beep\", set
+debug-on-error to t (`M-x set-variable RET debug-on-error RET t RET')
+and include the backtrace in your bug report.
+
+Please describe the bug in annoying, painstaking detail.
+
+Thank you for your help in stamping out bugs.
+")
+
+;;; End of variables.
+
+;; Define some autoload functions Gnus might use.
+(eval-and-compile
+
+ ;; Various
+ (autoload 'metamail-buffer "metamail")
+ (autoload 'Info-goto-node "info")
+ (autoload 'hexl-hex-string-to-integer "hexl")
+ (autoload 'pp "pp")
+ (autoload 'pp-to-string "pp")
+ (autoload 'pp-eval-expression "pp")
+ (autoload 'mail-extract-address-components "mail-extr")
+
+ (autoload 'nnmail-split-fancy "nnmail")
+ (autoload 'nnvirtual-catchup-group "nnvirtual")
+
+ ;; timezone
+ (autoload 'timezone-make-date-arpa-standard "timezone")
+ (autoload 'timezone-fix-time "timezone")
+ (autoload 'timezone-make-sortable-date "timezone")
+ (autoload 'timezone-make-time-string "timezone")
+
+ ;; rmail & friends
+ (autoload 'mail-position-on-field "sendmail")
+ (autoload 'mail-setup "sendmail")
+ (autoload 'rmail-output "rmailout")
+ (autoload 'news-mail-other-window "rnewspost")
+ (autoload 'news-reply-yank-original "rnewspost")
+ (autoload 'news-caesar-buffer-body "rnewspost")
+ (autoload 'rmail-insert-rmail-file-header "rmail")
+ (autoload 'rmail-count-new-messages "rmail")
+ (autoload 'rmail-show-message "rmail")
+
+ ;; gnus-soup
+ ;;(autoload 'gnus-group-brew-soup "gnus-soup" nil t)
+ ;;(autoload 'gnus-brew-soup "gnus-soup" nil t)
+ ;;(autoload 'gnus-soup-add-article "gnus-soup" nil t)
+ ;;(autoload 'gnus-soup-send-replies "gnus-soup" nil t)
+ ;;(autoload 'gnus-soup-save-areas "gnus-soup" nil t)
+ ;;(autoload 'gnus-soup-pack-packet "gnus-soup" nil t)
+ ;;(autoload 'nnsoup-pack-replies "nnsoup" nil t)
+
+ ;; gnus-mh
+ (autoload 'gnus-mail-reply-using-mhe "gnus-mh")
+ (autoload 'gnus-mail-forward-using-mhe "gnus-mh")
+ (autoload 'gnus-mail-other-window-using-mhe "gnus-mh")
+ (autoload 'gnus-summary-save-in-folder "gnus-mh" nil t)
+ (autoload 'gnus-summary-save-article-folder "gnus-mh")
+ (autoload 'gnus-Folder-save-name "gnus-mh")
+ (autoload 'gnus-folder-save-name "gnus-mh")
+
+ ;; gnus-vis misc
+ (autoload 'gnus-group-make-menu-bar "gnus-vis")
+ (autoload 'gnus-summary-make-menu-bar "gnus-vis")
+ (autoload 'gnus-server-make-menu-bar "gnus-vis")
+ (autoload 'gnus-article-make-menu-bar "gnus-vis")
+ (autoload 'gnus-browse-make-menu-bar "gnus-vis")
+ (autoload 'gnus-highlight-selected-summary "gnus-vis")
+ (autoload 'gnus-summary-highlight-line "gnus-vis")
+ (autoload 'gnus-carpal-setup-buffer "gnus-vis")
+
+ ;; gnus-vis article
+ (autoload 'gnus-article-push-button "gnus-vis" nil t)
+ (autoload 'gnus-article-press-button "gnus-vis" nil t)
+ (autoload 'gnus-article-highlight "gnus-vis" nil t)
+ (autoload 'gnus-article-highlight-some "gnus-vis" nil t)
+ (autoload 'gnus-article-hide "gnus-vis" nil t)
+ (autoload 'gnus-article-hide-signature "gnus-vis" nil t)
+ (autoload 'gnus-article-highlight-headers "gnus-vis" nil t)
+ (autoload 'gnus-article-highlight-signature "gnus-vis" nil t)
+ (autoload 'gnus-article-add-buttons "gnus-vis" nil t)
+ (autoload 'gnus-article-next-button "gnus-vis" nil t)
+ (autoload 'gnus-article-add-button "gnus-vis")
+
+ ;; gnus-cite
+ (autoload 'gnus-article-highlight-citation "gnus-cite" nil t)
+ (autoload 'gnus-article-hide-citation-maybe "gnus-cite" nil t)
+ (autoload 'gnus-article-hide-citation "gnus-cite" nil t)
+
+ ;; gnus-kill
+ (autoload 'gnus-kill "gnus-kill")
+ (autoload 'gnus-apply-kill-file-internal "gnus-kill")
+ (autoload 'gnus-kill-file-edit-file "gnus-kill")
+ (autoload 'gnus-kill-file-raise-followups-to-author "gnus-kill")
+ (autoload 'gnus-execute "gnus-kill")
+ (autoload 'gnus-expunge "gnus-kill")
+
+ ;; gnus-cache
+ (autoload 'gnus-cache-possibly-enter-article "gnus-cache")
+ (autoload 'gnus-cache-save-buffers "gnus-cache")
+ (autoload 'gnus-cache-possibly-remove-articles "gnus-cache")
+ (autoload 'gnus-cache-request-article "gnus-cache")
+ (autoload 'gnus-cache-retrieve-headers "gnus-cache")
+ (autoload 'gnus-cache-possibly-alter-active "gnus-cache")
+ (autoload 'gnus-jog-cache "gnus-cache" nil t)
+ (autoload 'gnus-cache-enter-remove-article "gnus-cache")
+
+ ;; gnus-score
+ (autoload 'gnus-summary-increase-score "gnus-score" nil t)
+ (autoload 'gnus-summary-lower-score "gnus-score" nil t)
+ (autoload 'gnus-summary-score-map "gnus-score" nil nil 'keymap)
+ (autoload 'gnus-score-save "gnus-score")
+ (autoload 'gnus-score-headers "gnus-score")
+ (autoload 'gnus-current-score-file-nondirectory "gnus-score")
+ (autoload 'gnus-score-adaptive "gnus-score")
+ (autoload 'gnus-score-remove-lines-adaptive "gnus-score")
+ (autoload 'gnus-score-find-trace "gnus-score")
+
+ ;; gnus-edit
+ (autoload 'gnus-score-customize "gnus-edit" nil t)
+
+ ;; gnus-uu
+ (autoload 'gnus-uu-extract-map "gnus-uu" nil nil 'keymap)
+ (autoload 'gnus-uu-mark-map "gnus-uu" nil nil 'keymap)
+ (autoload 'gnus-uu-digest-mail-forward "gnus-uu" nil t)
+ (autoload 'gnus-uu-digest-post-forward "gnus-uu" nil t)
+ (autoload 'gnus-uu-mark-series "gnus-uu" nil t)
+ (autoload 'gnus-uu-mark-region "gnus-uu" nil t)
+ (autoload 'gnus-uu-mark-by-regexp "gnus-uu" nil t)
+ (autoload 'gnus-uu-mark-all "gnus-uu" nil t)
+ (autoload 'gnus-uu-mark-sparse "gnus-uu" nil t)
+ (autoload 'gnus-uu-mark-thread "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-uu "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-uu-and-save "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-unshar "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-unshar-and-save "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-save "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-binhex "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-uu-view "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-uu-and-save-view "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-unshar-view "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-unshar-and-save-view "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-save-view "gnus-uu" nil t)
+ (autoload 'gnus-uu-decode-binhex-view "gnus-uu" nil t)
+
+ ;; gnus-msg
+ (autoload 'gnus-summary-send-map "gnus-msg" nil nil 'keymap)
+ (autoload 'gnus-group-post-news "gnus-msg" nil t)
+ (autoload 'gnus-group-mail "gnus-msg" nil t)
+ (autoload 'gnus-summary-post-news "gnus-msg" nil t)
+ (autoload 'gnus-summary-followup "gnus-msg" nil t)
+ (autoload 'gnus-summary-followup-with-original "gnus-msg" nil t)
+ (autoload 'gnus-summary-followup-and-reply "gnus-msg" nil t)
+ (autoload 'gnus-summary-followup-and-reply-with-original "gnus-msg" nil t)
+ (autoload 'gnus-summary-cancel-article "gnus-msg" nil t)
+ (autoload 'gnus-summary-supersede-article "gnus-msg" nil t)
+ (autoload 'gnus-post-news "gnus-msg" nil t)
+ (autoload 'gnus-inews-news "gnus-msg" nil t)
+ (autoload 'gnus-cancel-news "gnus-msg" nil t)
+ (autoload 'gnus-summary-reply "gnus-msg" nil t)
+ (autoload 'gnus-summary-reply-with-original "gnus-msg" nil t)
+ (autoload 'gnus-summary-mail-forward "gnus-msg" nil t)
+ (autoload 'gnus-summary-mail-other-window "gnus-msg" nil t)
+ (autoload 'gnus-mail-reply-using-mail "gnus-msg")
+ (autoload 'gnus-mail-yank-original "gnus-msg")
+ (autoload 'gnus-mail-send-and-exit "gnus-msg")
+ (autoload 'gnus-mail-forward-using-mail "gnus-msg")
+ (autoload 'gnus-mail-other-window-using-mail "gnus-msg")
+ (autoload 'gnus-article-mail "gnus-msg")
+ (autoload 'gnus-bug "gnus-msg" nil t)
+
+ ;; gnus-vm
+ (autoload 'gnus-summary-save-in-vm "gnus-vm" nil t)
+ (autoload 'gnus-summary-save-article-vm "gnus-vm" nil t)
+ (autoload 'gnus-mail-forward-using-vm "gnus-vm")
+ (autoload 'gnus-mail-reply-using-vm "gnus-vm")
+ (autoload 'gnus-mail-other-window-using-vm "gnus-vm" nil t)
+ (autoload 'gnus-yank-article "gnus-vm" nil t)
+
+ )
+
+
+
+;; Fix by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
+;; If you want the cursor to go somewhere else, set these two
+;; functions in some startup hook to whatever you want.
+(defalias 'gnus-summary-position-cursor 'gnus-goto-colon)
+(defalias 'gnus-group-position-cursor 'gnus-goto-colon)
+
+;;; Various macros and substs.
+
+(defmacro gnus-eval-in-buffer-window (buffer &rest forms)
+ "Pop to BUFFER, evaluate FORMS, and then returns to original window."
+ (` (let ((GnusStartBufferWindow (selected-window)))
+ (unwind-protect
+ (progn
+ (pop-to-buffer (, buffer))
+ (,@ forms))
+ (select-window GnusStartBufferWindow)))))
+
+(defmacro gnus-gethash (string hashtable)
+ "Get hash value of STRING in HASHTABLE."
+ ;;(` (symbol-value (abbrev-symbol (, string) (, hashtable))))
+ ;;(` (abbrev-expansion (, string) (, hashtable)))
+ (` (symbol-value (intern-soft (, string) (, hashtable)))))
+
+(defmacro gnus-sethash (string value hashtable)
+ "Set hash value. Arguments are STRING, VALUE, and HASHTABLE."
+ ;; We cannot use define-abbrev since it only accepts string as value.
+ ;; (set (intern string hashtable) value))
+ (` (set (intern (, string) (, hashtable)) (, value))))
+
+(defsubst gnus-buffer-substring (beg end)
+ (buffer-substring (match-beginning beg) (match-end end)))
+
+;; 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-simplify-subject-re (subject)
+ "Remove \"Re:\" from subject lines."
+ (let ((case-fold-search t))
+ (if (string-match "^re: *" subject)
+ (substring subject (match-end 0))
+ subject)))
+
+(defsubst gnus-goto-char (point)
+ (and point (goto-char point)))
+
+(defmacro gnus-buffer-exists-p (buffer)
+ (` (and (, buffer)
+ (funcall (if (stringp (, buffer)) 'get-buffer 'buffer-name)
+ (, buffer)))))
+
+(defmacro gnus-kill-buffer (buffer)
+ (` (if (gnus-buffer-exists-p (, buffer))
+ (kill-buffer (, buffer)))))
+
+(defsubst gnus-point-at-bol ()
+ "Return point at the beginning of line."
+ (let ((p (point)))
+ (beginning-of-line)
+ (prog1
+ (point)
+ (goto-char p))))
+
+(defsubst gnus-point-at-eol ()
+ "Return point at the beginning of line."
+ (let ((p (point)))
+ (end-of-line)
+ (prog1
+ (point)
+ (goto-char p))))
+
+;; 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)))))
+
+;; Suggested by Brian Edmonds <edmonds@cs.ubc.ca>.
+(defvar gnus-init-inhibit nil)
+(defun gnus-read-init-file (&optional inhibit-next)
+ (if gnus-init-inhibit
+ (setq gnus-init-inhibit nil)
+ (setq gnus-init-inhibit inhibit-next)
+ (and gnus-init-file
+ (or (and (file-exists-p gnus-init-file)
+ ;; Don't try to load a directory.
+ (not (file-directory-p gnus-init-file)))
+ (file-exists-p (concat gnus-init-file ".el"))
+ (file-exists-p (concat gnus-init-file ".elc")))
+ (load gnus-init-file nil t))))
+
+;;; Load the user startup file.
+;; (eval '(gnus-read-init-file 'inhibit))
+
+;;; Load the compatability functions.
+
+(require 'gnus-cus)
+(require 'gnus-ems)
+
+
+;;;
+;;; Gnus Utility Functions
+;;;
+
+(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.
+ (if (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))
+ (gnus-narrow-to-headers)
+ (mail-fetch-field field)))))
+
+(defun gnus-goto-colon ()
+ (beginning-of-line)
+ (search-forward ":" (gnus-point-at-eol) t))
+
+(defun gnus-narrow-to-headers ()
+ (widen)
+ (save-excursion
+ (narrow-to-region
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (point-max)))))
+
+(defvar gnus-old-specs nil)
+
+(defun gnus-update-format-specifications ()
+ (gnus-make-thread-indent-array)
+
+ (let ((formats '(summary summary-dummy group
+ summary-mode group-mode article-mode))
+ old-format new-format)
+ (while formats
+ (setq new-format (symbol-value
+ (intern (format "gnus-%s-line-format" (car formats)))))
+ (or (and (setq old-format (cdr (assq (car formats) gnus-old-specs)))
+ (equal old-format new-format))
+ (set (intern (format "gnus-%s-line-format-spec" (car formats)))
+ (gnus-parse-format
+ new-format
+ (symbol-value
+ (intern (format "gnus-%s-line-format-alist"
+ (if (eq (car formats) 'article-mode)
+ 'summary-mode (car formats))))))))
+ (setq gnus-old-specs (cons (cons (car formats) new-format)
+ (delq (car formats) gnus-old-specs)))
+ (setq formats (cdr formats))))
+
+ (gnus-update-group-mark-positions)
+ (gnus-update-summary-mark-positions)
+
+ (if (and (string-match "%D" gnus-group-line-format)
+ (not gnus-description-hashtb)
+ gnus-read-active-file)
+ (gnus-read-all-descriptions-files)))
+
+(defun gnus-update-summary-mark-positions ()
+ (save-excursion
+ (let ((gnus-replied-mark 129)
+ (gnus-score-below-mark 130)
+ (gnus-score-over-mark 130)
+ (thread nil)
+ pos)
+ (gnus-set-work-buffer)
+ (gnus-summary-insert-line
+ nil [0 "" "" "" "" "" 0 0 ""] 0 nil 128 t nil "" nil 1)
+ (goto-char (point-min))
+ (setq pos (list (cons 'unread (and (search-forward "\200" nil t)
+ (- (point) 2)))))
+ (goto-char (point-min))
+ (setq pos (cons (cons 'replied (and (search-forward "\201" nil t)
+ (- (point) 2))) pos))
+ (goto-char (point-min))
+ (setq pos (cons (cons 'score (and (search-forward "\202" nil t)
+ (- (point) 2))) pos))
+ (setq gnus-summary-mark-positions pos))))
+
+(defun gnus-update-group-mark-positions ()
+ (save-excursion
+ (let ((gnus-process-mark 128)
+ (gnus-group-marked '("dummy.group")))
+ (gnus-sethash "dummy.group" '(0 . 0) gnus-active-hashtb)
+ (gnus-set-work-buffer)
+ (gnus-group-insert-group-line nil "dummy.group" 0 nil 0 nil)
+ (goto-char (point-min))
+ (setq gnus-group-mark-positions
+ (list (cons 'process (and (search-forward "\200" nil t)
+ (- (point) 2))))))))
+
+(defun gnus-mouse-face-function (form)
+ (` (let ((string (, form)))
+ (put-text-property 0 (length string) 'mouse-face gnus-mouse-face string)
+ string)))
+
+(defun gnus-max-width-function (el max-width)
+ (or (numberp max-width) (signal 'wrong-type-argument '(numberp max-width)))
+ (` (let* ((val (eval (, el)))
+ (valstr (if (numberp val)
+ (int-to-string val) val)))
+ (if (> (length valstr) (, max-width))
+ (substring valstr 0 (, max-width))
+ valstr))))
+
+(defun gnus-parse-format (format spec-alist)
+ ;; 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 "\\`\\(.*\\)%(\\(.*\\)%)\\(.*\n?\\)\\'" format)
+ (if (and gnus-visual gnus-mouse-face)
+ (let ((pre (substring format (match-beginning 1) (match-end 1)))
+ (button (substring format (match-beginning 2) (match-end 2)))
+ (post (substring format (match-beginning 3) (match-end 3))))
+ (list 'concat
+ (gnus-parse-simple-format pre spec-alist)
+ (gnus-mouse-face-function
+ (gnus-parse-simple-format button spec-alist))
+ (gnus-parse-simple-format post spec-alist)))
+ (gnus-parse-simple-format
+ (concat (substring format (match-beginning 1) (match-end 1))
+ (substring format (match-beginning 2) (match-end 2))
+ (substring format (match-beginning 3) (match-end 3)))
+ spec-alist))
+ (gnus-parse-simple-format format spec-alist)))
+
+(defun gnus-parse-simple-format (format spec-alist)
+ ;; 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. The list will consist of the symbol `format', a format
+ ;; specification string, and a list of forms depending on the
+ ;; SPEC-ALIST.
+ (let ((max-width 0)
+ spec flist fstring newspec elem beg)
+ (save-excursion
+ (gnus-set-work-buffer)
+ (insert format)
+ (goto-char (point-min))
+ (while (re-search-forward "%[-0-9]*\\(,[0-9]+\\)?\\([^0-9]\\)\\(.\\)?" nil t)
+ (setq spec (string-to-char (buffer-substring (match-beginning 2)
+ (match-end 2))))
+ ;; First check if there are any specs that look anything like
+ ;; "%12,12A", ie. with a "max width specification". These have
+ ;; to be treated specially.
+ (if (setq beg (match-beginning 1))
+ (setq max-width
+ (string-to-int
+ (buffer-substring (1+ (match-beginning 1)) (match-end 1))))
+ (setq max-width 0)
+ (setq beg (match-beginning 2)))
+ ;; Find the specification from `spec-alist'.
+ (if (not (setq elem (cdr (assq spec spec-alist))))
+ (setq elem '("*" ?s)))
+ ;; Treat user defined format specifiers specially
+ (and (eq (car elem) 'user-defined)
+ (setq elem
+ (list
+ (list (intern (concat "gnus-user-format-function-"
+ (buffer-substring
+ (match-beginning 3)
+ (match-end 3))))
+ 'header)
+ ?s))
+ (delete-region (match-beginning 3) (match-end 3)))
+ (if (not (zerop max-width))
+ (let ((el (car elem)))
+ (cond ((= (car (cdr elem)) ?c)
+ (setq el (list 'char-to-string el)))
+ ((= (car (cdr elem)) ?d)
+ (numberp el) (setq el (list 'int-to-string el))))
+ (setq flist (cons (gnus-max-width-function el max-width)
+ flist))
+ (setq newspec ?s))
+ (setq flist (cons (car elem) flist))
+ (setq newspec (car (cdr elem))))
+ ;; Remove the old specification (and possibly a ",12" string).
+ (delete-region beg (match-end 2))
+ ;; Insert the new specification.
+ (goto-char beg)
+ (insert newspec))
+ (setq fstring (buffer-substring 1 (point-max))))
+ (cons 'format (cons fstring (nreverse flist)))))
+
+(defun gnus-set-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))
+ (gnus-add-current-to-buffer-list)))
+
+;; Article file names when saving.
+
+(defun gnus-Numeric-save-name (newsgroup headers &optional last-file)
+ "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
+If variable `gnus-use-long-file-name' is nil, it is ~/News/News.group/num.
+Otherwise, it is like ~/News/news/group/num."
+ (let ((default
+ (expand-file-name
+ (concat (if (gnus-use-long-file-name 'not-save)
+ (gnus-capitalize-newsgroup newsgroup)
+ (gnus-newsgroup-directory-form newsgroup))
+ "/" (int-to-string (mail-header-number headers)))
+ (or gnus-article-save-directory "~/News"))))
+ (if (and last-file
+ (string-equal (file-name-directory default)
+ (file-name-directory last-file))
+ (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
+ default
+ (or last-file default))))
+
+(defun gnus-numeric-save-name (newsgroup headers &optional last-file)
+ "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
+If variable `gnus-use-long-file-name' is non-nil, it is
+~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
+ (let ((default
+ (expand-file-name
+ (concat (if (gnus-use-long-file-name 'not-save)
+ newsgroup
+ (gnus-newsgroup-directory-form newsgroup))
+ "/" (int-to-string (mail-header-number headers)))
+ (or gnus-article-save-directory "~/News"))))
+ (if (and last-file
+ (string-equal (file-name-directory default)
+ (file-name-directory last-file))
+ (string-match "^[0-9]+$" (file-name-nondirectory last-file)))
+ default
+ (or last-file default))))
+
+(defun gnus-Plain-save-name (newsgroup headers &optional last-file)
+ "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
+If variable `gnus-use-long-file-name' is non-nil, it is
+~/News/News.group. Otherwise, it is like ~/News/news/group/news."
+ (or last-file
+ (expand-file-name
+ (if (gnus-use-long-file-name 'not-save)
+ (gnus-capitalize-newsgroup newsgroup)
+ (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
+ (or gnus-article-save-directory "~/News"))))
+
+(defun gnus-plain-save-name (newsgroup headers &optional last-file)
+ "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
+If variable `gnus-use-long-file-name' is non-nil, it is
+~/News/news.group. Otherwise, it is like ~/News/news/group/news."
+ (or last-file
+ (expand-file-name
+ (if (gnus-use-long-file-name 'not-save)
+ newsgroup
+ (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
+ (or gnus-article-save-directory "~/News"))))
+
+;; For subscribing new newsgroup
+
+(defun gnus-subscribe-hierarchical-interactive (groups)
+ (let ((groups (sort groups 'string<))
+ prefixes prefix start ans group starts)
+ (while groups
+ (setq prefixes (list "^"))
+ (while (and groups prefixes)
+ (while (not (string-match (car prefixes) (car groups)))
+ (setq prefixes (cdr prefixes)))
+ (setq prefix (car prefixes))
+ (setq start (1- (length prefix)))
+ (if (and (string-match "[^\\.]\\." (car groups) start)
+ (cdr groups)
+ (setq prefix
+ (concat "^" (substring (car groups) 0 (match-end 0))))
+ (string-match prefix (car (cdr groups))))
+ (progn
+ (setq prefixes (cons prefix prefixes))
+ (message "Descend hierarchy %s? ([y]nsq): "
+ (substring prefix 1 (1- (length prefix))))
+ (setq ans (read-char))
+ (cond ((= ans ?n)
+ (while (and groups
+ (string-match prefix
+ (setq group (car groups))))
+ (setq gnus-killed-list
+ (cons group gnus-killed-list))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (setq groups (cdr groups)))
+ (setq starts (cdr starts)))
+ ((= ans ?s)
+ (while (and groups
+ (string-match prefix
+ (setq group (car groups))))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (gnus-subscribe-alphabetically (car groups))
+ (setq groups (cdr groups)))
+ (setq starts (cdr starts)))
+ ((= ans ?q)
+ (while groups
+ (setq group (car groups))
+ (setq gnus-killed-list (cons group gnus-killed-list))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (setq groups (cdr groups))))
+ (t nil)))
+ (message "Subscribe %s? ([n]yq)" (car groups))
+ (setq ans (read-char))
+ (setq group (car groups))
+ (cond ((= ans ?y)
+ (gnus-subscribe-alphabetically (car groups))
+ (gnus-sethash group group gnus-killed-hashtb))
+ ((= ans ?q)
+ (while groups
+ (setq group (car groups))
+ (setq gnus-killed-list (cons group gnus-killed-list))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (setq groups (cdr groups))))
+ (t
+ (setq gnus-killed-list (cons group gnus-killed-list))
+ (gnus-sethash group group gnus-killed-hashtb)))
+ (setq groups (cdr groups)))))))
+
+(defun gnus-subscribe-randomly (newsgroup)
+ "Subscribe new NEWSGROUP by making it the first newsgroup."
+ (gnus-subscribe-newsgroup newsgroup))
+
+(defun gnus-subscribe-alphabetically (newgroup)
+ "Subscribe new NEWSGROUP and insert it in alphabetical order."
+ ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams)
+ (let ((groups (cdr gnus-newsrc-alist))
+ before)
+ (while (and (not before) groups)
+ (if (string< newgroup (car (car groups)))
+ (setq before (car (car groups)))
+ (setq groups (cdr groups))))
+ (gnus-subscribe-newsgroup newgroup before)))
+
+(defun gnus-subscribe-hierarchically (newgroup)
+ "Subscribe new NEWSGROUP and insert it in hierarchical newsgroup order."
+ ;; Basic ideas by mike-w@cs.aukuni.ac.nz (Mike Williams)
+ (save-excursion
+ (set-buffer (find-file-noselect gnus-current-startup-file))
+ (let ((groupkey newgroup)
+ before)
+ (while (and (not before) groupkey)
+ (goto-char (point-min))
+ (let ((groupkey-re
+ (concat "^\\(" (regexp-quote groupkey) ".*\\)[!:]")))
+ (while (and (re-search-forward groupkey-re nil t)
+ (progn
+ (setq before (buffer-substring
+ (match-beginning 1) (match-end 1)))
+ (string< before newgroup)))))
+ ;; Remove tail of newsgroup name (eg. a.b.c -> a.b)
+ (setq groupkey
+ (if (string-match "^\\(.*\\)\\.[^.]+$" groupkey)
+ (substring groupkey (match-beginning 1) (match-end 1)))))
+ (gnus-subscribe-newsgroup newgroup before))))
+
+(defun gnus-subscribe-interactively (newsgroup)
+ "Subscribe new NEWSGROUP interactively.
+It is inserted in hierarchical newsgroup order if subscribed. If not,
+it is killed."
+ (if (gnus-y-or-n-p (format "Subscribe new newsgroup: %s " newsgroup))
+ (gnus-subscribe-hierarchically newsgroup)
+ (setq gnus-killed-list (cons newsgroup gnus-killed-list))))
+
+(defun gnus-subscribe-zombies (newsgroup)
+ "Make new NEWSGROUP a zombie group."
+ (setq gnus-zombie-list (cons newsgroup gnus-zombie-list)))
+
+(defun gnus-subscribe-newsgroup (newsgroup &optional next)
+ "Subscribe new NEWSGROUP.
+If NEXT is non-nil, it is inserted before NEXT. Otherwise it is made
+the first newsgroup."
+ ;; We subscribe the group by changing its level to `subscribed'.
+ (gnus-group-change-level
+ newsgroup gnus-level-default-subscribed
+ gnus-level-killed (gnus-gethash (or next "dummy.group") gnus-newsrc-hashtb))
+ (gnus-message 5 "Subscribe newsgroup: %s" newsgroup))
+
+;; For directories
+
+(defun gnus-newsgroup-directory-form (newsgroup)
+ "Make hierarchical directory name from NEWSGROUP name."
+ (let ((newsgroup (gnus-newsgroup-saveable-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)
+ (if (= (aref newsgroup idx) ?.)
+ (aset newsgroup idx ?/))
+ (setq idx (1+ idx)))
+ newsgroup))
+
+(defun gnus-newsgroup-saveable-name (group)
+ ;; Replace any slashes in a group name (eg. an ange-ftp nndoc group)
+ ;; with dots.
+ (gnus-replace-chars-in-string group ?/ ?.))
+
+(defun gnus-make-directory (dir)
+ "Make DIRECTORY recursively."
+ ;; Why don't we use `(make-directory dir 'parents)'? That's just one
+ ;; of the many mysteries of the universe.
+ (let* ((dir (expand-file-name dir default-directory))
+ dirs err)
+ (if (string-match "/$" dir)
+ (setq dir (substring dir 0 (match-beginning 0))))
+ ;; First go down the path until we find a directory that exists.
+ (while (not (file-exists-p dir))
+ (setq dirs (cons dir dirs))
+ (string-match "/[^/]+$" dir)
+ (setq dir (substring dir 0 (match-beginning 0))))
+ ;; Then create all the subdirs.
+ (while (and dirs (not err))
+ (condition-case ()
+ (make-directory (car dirs))
+ (error (setq err t)))
+ (setq dirs (cdr dirs)))
+ ;; We return whether we were successful or not.
+ (not dirs)))
+
+(defun gnus-capitalize-newsgroup (newsgroup)
+ "Capitalize NEWSGROUP name."
+ (and (not (zerop (length newsgroup)))
+ (concat (char-to-string (upcase (aref newsgroup 0)))
+ (substring newsgroup 1))))
+
+;; Var
+
+(defun gnus-simplify-subject (subject &optional re-only)
+ "Remove `Re:' and words in parentheses.
+If optional argument RE-ONLY is non-nil, strip `Re:' only."
+ (let ((case-fold-search t)) ;Ignore case.
+ ;; Remove `Re:' and `Re^N:'.
+ (if (string-match "^re:[ \t]*" subject)
+ (setq subject (substring subject (match-end 0))))
+ ;; Remove words in parentheses from end.
+ (or re-only
+ (while (string-match "[ \t\n]*([^()]*)[ \t\n]*\\'" subject)
+ (setq subject (substring subject 0 (match-beginning 0)))))
+ ;; Return subject string.
+ subject))
+
+;; Remove any leading "re:"s, any trailing paren phrases, and simplify
+;; all whitespace.
+(defun gnus-simplify-subject-fuzzy (subject)
+ (let ((case-fold-search t))
+ (save-excursion
+ (gnus-set-work-buffer)
+ (insert subject)
+ (inline (gnus-simplify-buffer-fuzzy))
+ (buffer-string))))
+
+(defun gnus-simplify-buffer-fuzzy ()
+ (goto-char (point-min))
+ ;; Fix by Stainless Steel Rat <ratinox@ccs.neu.edu>.
+ (while (re-search-forward "^[ \t]*\\(re\\|fwd\\)[[{(^0-9]*[])}]?[:;][ \t]*"
+ nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t\n]*([^()]*)[ \t\n]*$" nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+" nil t)
+ (replace-match " " t t))
+ (goto-char (point-min))
+ (while (re-search-forward "[ \t]+$" nil t)
+ (replace-match "" t t))
+ (goto-char (point-min))
+ (while (re-search-forward "^[ \t]+" nil t)
+ (replace-match "" t t))
+ (if gnus-simplify-subject-fuzzy-regexp
+ (while (re-search-forward gnus-simplify-subject-fuzzy-regexp nil t)
+ (replace-match "" t t))))
+
+;; Add the current buffer to the list of buffers to be killed on exit.
+(defun gnus-add-current-to-buffer-list ()
+ (or (memq (current-buffer) gnus-buffer-list)
+ (setq gnus-buffer-list (cons (current-buffer) gnus-buffer-list))))
+
+(defun gnus-string> (s1 s2)
+ (not (or (string< s1 s2)
+ (string= s1 s2))))
+
+;; Functions accessing headers.
+;; Functions are more convenient than macros in some cases.
+
+(defun gnus-header-number (header)
+ (mail-header-number header))
+
+(defun gnus-header-subject (header)
+ (mail-header-subject header))
+
+(defun gnus-header-from (header)
+ (mail-header-from header))
+
+(defun gnus-header-xref (header)
+ (mail-header-xref header))
+
+(defun gnus-header-lines (header)
+ (mail-header-lines header))
+
+(defun gnus-header-date (header)
+ (mail-header-date header))
+
+(defun gnus-header-id (header)
+ (mail-header-id header))
+
+(defun gnus-header-message-id (header)
+ (mail-header-id header))
+
+(defun gnus-header-chars (header)
+ (mail-header-chars header))
+
+(defun gnus-header-references (header)
+ (mail-header-references header))
+
+;;; General various misc type functions.
+
+(defun gnus-clear-system ()
+ "Clear all variables and buffers."
+ ;; Clear Gnus variables.
+ (let ((variables gnus-variable-list))
+ (while variables
+ (set (car variables) nil)
+ (setq variables (cdr variables))))
+ ;; Clear other internal variables.
+ (setq gnus-list-of-killed-groups nil
+ gnus-have-read-active-file nil
+ gnus-newsrc-alist nil
+ gnus-newsrc-hashtb nil
+ gnus-killed-list nil
+ gnus-zombie-list nil
+ gnus-killed-hashtb nil
+ gnus-active-hashtb nil
+ gnus-moderated-list nil
+ gnus-description-hashtb nil
+ gnus-newsgroup-headers nil
+ gnus-newsgroup-headers-hashtb-by-number nil
+ gnus-newsgroup-name nil
+ gnus-server-alist nil
+ gnus-current-select-method nil)
+ ;; Reset any score variables.
+ (and (boundp 'gnus-score-cache)
+ (set 'gnus-score-cache nil))
+ (and (boundp 'gnus-internal-global-score-files)
+ (set 'gnus-internal-global-score-files nil))
+ ;; Kill the startup file.
+ (and gnus-current-startup-file
+ (get-file-buffer gnus-current-startup-file)
+ (kill-buffer (get-file-buffer gnus-current-startup-file)))
+ ;; Save any cache buffers.
+ (and gnus-use-cache (gnus-cache-save-buffers))
+ ;; Clear the dribble buffer.
+ (gnus-dribble-clear)
+ ;; Kill global KILL file buffer.
+ (if (get-file-buffer (gnus-newsgroup-kill-file nil))
+ (kill-buffer (get-file-buffer (gnus-newsgroup-kill-file nil))))
+ (gnus-kill-buffer nntp-server-buffer)
+ ;; Kill Gnus buffers.
+ (while gnus-buffer-list
+ (gnus-kill-buffer (car gnus-buffer-list))
+ (setq gnus-buffer-list (cdr gnus-buffer-list))))
+
+(defun gnus-windows-old-to-new (setting)
+ ;; First we take care of the really, really old Gnus 3 actions.
+ (if (symbolp setting)
+ (setq setting
+ (cond ((memq setting '(SelectArticle))
+ 'article)
+ ((memq setting '(SelectSubject ExpandSubject))
+ 'summary)
+ ((memq setting '(SelectNewsgroup ExitNewsgroup))
+ 'group)
+ (t setting))))
+ (if (or (listp setting)
+ (not (and gnus-window-configuration
+ (memq setting '(group summary article)))))
+ setting
+ (let* ((setting (if (eq setting 'group)
+ (if (assq 'newsgroup gnus-window-configuration)
+ 'newsgroup
+ 'newsgroups) setting))
+ (elem (car (cdr (assq setting gnus-window-configuration))))
+ (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 (/ (* 1.0 (nth 0 elem)) total))
+ (setq out (cons (if (eq pbuf (nth i types))
+ (vector (nth i types) perc 'point)
+ (vector (nth i types) perc))
+ out))))
+ (setq i (1+ i)))
+ (list (nreverse out)))))
+
+(defun gnus-add-configuration (conf)
+ (setq gnus-buffer-configuration
+ (cons conf (delq (assq (car conf) gnus-buffer-configuration)
+ gnus-buffer-configuration))))
+
+(defun gnus-configure-windows (setting &optional force)
+ (setq setting (gnus-windows-old-to-new setting))
+ (let ((r (if (symbolp setting)
+ (cdr (assq setting gnus-buffer-configuration))
+ setting))
+ (in-buf (current-buffer))
+ rule val w height hor ohor heights sub jump-buffer
+ rel total to-buf all-visible)
+ (or r (error "No such setting: %s" setting))
+
+ (if (and (not force) (setq all-visible (gnus-all-windows-visible-p r)))
+ ;; All the windows mentioned are already visible, so we just
+ ;; put point in the assigned buffer, and do not touch the
+ ;; winconf.
+ (select-window (get-buffer-window all-visible t))
+
+
+ ;; Either remove all windows or just remove all Gnus windows.
+ (if gnus-use-full-window
+ (delete-other-windows)
+ (gnus-remove-some-windows)
+ (switch-to-buffer nntp-server-buffer))
+
+ (while r
+ (setq hor (car r)
+ ohor nil)
+
+ ;; We have to do the (possible) horizontal splitting before the
+ ;; vertical.
+ (if (and (listp (car hor))
+ (eq (car (car hor)) 'horizontal))
+ (progn
+ (split-window
+ nil
+ (if (integerp (nth 1 (car hor)))
+ (nth 1 (car hor))
+ (- (frame-width) (floor (* (frame-width) (nth 1 (car hor))))))
+ t)
+ (setq hor (cdr hor))))
+
+ ;; Go through the rules and eval the elements that are to be
+ ;; evaled.
+ (while hor
+ (if (setq val (if (vectorp (car hor)) (car hor) (eval (car hor))))
+ (progn
+ ;; Expand short buffer name.
+ (setq w (aref val 0))
+ (and (setq w (cdr (assq w gnus-window-to-buffer)))
+ (progn
+ (setq val (apply 'vector (mapcar 'identity val)))
+ (aset val 0 w)))
+ (setq ohor (cons val ohor))))
+ (setq hor (cdr hor)))
+ (setq rule (cons (nreverse ohor) rule))
+ (setq r (cdr r)))
+ (setq rule (nreverse rule))
+
+ ;; We tally the window sizes.
+ (setq total (window-height))
+ (while rule
+ (setq hor (car rule))
+ (if (and (listp (car hor)) (eq (car (car hor)) 'horizontal))
+ (setq hor (cdr hor)))
+ (setq sub 0)
+ (while hor
+ (setq rel (aref (car hor) 1)
+ heights (cons
+ (cond ((and (floatp rel) (= 1.0 rel))
+ 'x)
+ ((integerp rel)
+ rel)
+ (t
+ (max (floor (* total rel)) 4)))
+ heights)
+ sub (+ sub (if (numberp (car heights)) (car heights) 0))
+ hor (cdr hor)))
+ (setq heights (nreverse heights)
+ hor (car rule))
+
+ ;; We then go through these heighs and create windows for them.
+ (while heights
+ (setq height (car heights)
+ heights (cdr heights))
+ (and (eq height 'x)
+ (setq height (- total sub)))
+ (and heights
+ (split-window nil height))
+ (setq to-buf (aref (car hor) 0))
+ (switch-to-buffer
+ (cond ((not to-buf)
+ in-buf)
+ ((symbolp to-buf)
+ (symbol-value (aref (car hor) 0)))
+ (t
+ (aref (car hor) 0))))
+ (and (> (length (car hor)) 2)
+ (eq (aref (car hor) 2) 'point)
+ (setq jump-buffer (current-buffer)))
+ (other-window 1)
+ (setq hor (cdr hor)))
+
+ (setq rule (cdr rule)))
+
+ ;; Finally, we pop to the buffer that's supposed to have point.
+ (or jump-buffer (error "Missing `point' in spec for %s" setting))
+
+ (select-window (get-buffer-window jump-buffer t))
+ (set-buffer jump-buffer))))
+
+(defun gnus-all-windows-visible-p (rule)
+ (let (invisible hor jump-buffer val buffer)
+ ;; Go through the rules and eval the elements that are to be
+ ;; evaled.
+ (while (and rule (not invisible))
+ (setq hor (car rule)
+ rule (cdr rule))
+ (while (and hor (not invisible))
+ (if (setq val (if (vectorp (car hor))
+ (car hor)
+ (if (not (eq (car (car hor)) 'horizontal))
+ (eval (car hor)))))
+ (progn
+ ;; Expand short buffer name.
+ (setq buffer (or (cdr (assq (aref val 0) gnus-window-to-buffer))
+ (aref val 0)))
+ (setq buffer (if (symbolp buffer) (symbol-value buffer)
+ buffer))
+ (and (> (length val) 2) (eq 'point (aref val 2))
+ (setq jump-buffer buffer))
+ (setq invisible (not (and buffer (get-buffer-window buffer))))))
+ (setq hor (cdr hor))))
+ (and (not invisible) jump-buffer)))
+
+(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 (cdr (car buffers)))
+ (if (symbolp buf)
+ (setq buf (and (boundp buf) (symbol-value buf))))
+ (and buf
+ (get-buffer-window buf)
+ (progn
+ (setq bufs (cons buf bufs))
+ (pop-to-buffer buf)
+ (if (or (not lowest)
+ (< (gnus-window-top-edge) lowest))
+ (progn
+ (setq lowest (gnus-window-top-edge))
+ (setq lowest-buf buf)))))
+ (setq buffers (cdr buffers)))
+ ;; Remove windows on *all* summary buffers.
+ (let (wins)
+ (walk-windows
+ (lambda (win)
+ (let ((buf (window-buffer win)))
+ (if (string-match "^\\*Summary" (buffer-name buf))
+ (progn
+ (setq bufs (cons buf bufs))
+ (pop-to-buffer buf)
+ (if (or (not lowest)
+ (< (gnus-window-top-edge) lowest))
+ (progn
+ (setq lowest-buf buf)
+ (setq lowest (gnus-window-top-edge))))))))))
+ (and lowest-buf
+ (progn
+ (pop-to-buffer lowest-buf)
+ (switch-to-buffer nntp-server-buffer)))
+ (while bufs
+ (and (not (eq (car bufs) lowest-buf))
+ (delete-windows-on (car bufs)))
+ (setq bufs (cdr bufs))))))
+
+(defun gnus-version ()
+ "Version numbers of this version of Gnus."
+ (interactive)
+ (let ((methods gnus-valid-select-methods)
+ (mess gnus-version)
+ meth)
+ ;; Go through all the legal select methods and add their version
+ ;; numbers to the total version string. Only the backends that are
+ ;; currently in use will have their message numbers taken into
+ ;; consideration.
+ (while methods
+ (setq meth (intern (concat (car (car methods)) "-version")))
+ (and (boundp meth)
+ (stringp (symbol-value meth))
+ (setq mess (concat mess "; " (symbol-value meth))))
+ (setq methods (cdr methods)))
+ (gnus-message 2 mess)))
+
+(defun gnus-info-find-node ()
+ "Find Info documentation of Gnus."
+ (interactive)
+ ;; Enlarge info window if needed.
+ (let ((mode major-mode))
+ (gnus-configure-windows 'info)
+ (Info-goto-node (car (cdr (assq mode gnus-info-nodes))))))
+
+(defun gnus-overload-functions (&optional overloads)
+ "Overload functions specified by optional argument OVERLOADS.
+If nothing is specified, use the variable gnus-overload-functions."
+ (let ((defs nil)
+ (overloads (or overloads gnus-overload-functions)))
+ (while overloads
+ (setq defs (car overloads))
+ (setq overloads (cdr overloads))
+ ;; Load file before overloading function if necessary. Make
+ ;; sure we cannot use `require' always.
+ (and (not (fboundp (car defs)))
+ (car (cdr (cdr defs)))
+ (load (car (cdr (cdr defs))) nil 'nomessage))
+ (fset (car defs) (car (cdr defs))))))
+
+(defun gnus-replace-chars-in-string (string &rest pairs)
+ "Replace characters in STRING from FROM to TO."
+ (let ((string (substring string 0)) ;Copy string.
+ (len (length string))
+ (idx 0)
+ sym to)
+ (or (zerop (% (length pairs) 2))
+ (error "Odd number of translation pairs"))
+ (setplist 'sym pairs)
+ ;; Replace all occurrences of FROM with TO.
+ (while (< idx len)
+ (if (setq to (get 'sym (aref string idx)))
+ (aset string idx to))
+ (setq idx (1+ idx)))
+ string))
+
+(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))))
+
+;; Returns a floating point number that says how many seconds have
+;; lapsed between Jan 1 12:00:00 1970 and DATE.
+(defun gnus-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))))
+ (edate (mapcar (lambda (ti) (and ti (string-to-int ti)))
+ (timezone-parse-date "Jan 1 12:00:00 1970")))
+ (tday (- (timezone-absolute-from-gregorian
+ (nth 1 tdate) (nth 2 tdate) (nth 0 tdate))
+ (timezone-absolute-from-gregorian
+ (nth 1 edate) (nth 2 edate) (nth 0 edate)))))
+ (+ (nth 2 ttime)
+ (* (nth 1 ttime) 60)
+ (* 1.0 (nth 0 ttime) 60 60)
+ (* 1.0 tday 60 60 24))))
+
+(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))))))
+
+(defun gnus-group-read-only-p (&optional group)
+ "Check whether GROUP supports editing or not.
+If GROUP is nil, `gnus-newsgroup-name' will be checked instead. Note
+that that variable is buffer-local to the summary buffers."
+ (let ((group (or group gnus-newsgroup-name)))
+ (not (gnus-check-backend-function 'request-replace-article group))))
+
+;; 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 "")))
+
+;; Check whether to use long file names.
+(defun gnus-use-long-file-name (symbol)
+ ;; The variable has to be set...
+ (and gnus-use-long-file-name
+ ;; If it isn't a list, then we return t.
+ (or (not (listp gnus-use-long-file-name))
+ ;; If it is a list, and the list contains `symbol', we
+ ;; return nil.
+ (not (memq symbol gnus-use-long-file-name)))))
+
+;; 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 (timezone-parse-date messy-date)))
+ (format "%2s-%s"
+ (or (aref datevec 2) "??")
+ (capitalize
+ (or (car
+ (nth (1- (string-to-number (aref datevec 1)))
+ timezone-months-assoc))
+ "???")))))
+
+;; Make a hash table (default and minimum size is 255).
+;; Optional argument HASHSIZE specifies the table size.
+(defun gnus-make-hashtable (&optional hashsize)
+ (make-vector (if hashsize (max (gnus-create-hash-size hashsize) 255) 255) 0))
+
+;; Make a number that is suitable for hashing; bigger than MIN and one
+;; less than 2^x.
+(defun gnus-create-hash-size (min)
+ (let ((i 1))
+ (while (< i min)
+ (setq i (* 2 i)))
+ (1- i)))
+
+;; Show message if message has a lower level than `gnus-verbose'.
+;; Guide-line 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 thingie 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)))
+
+;; Generate a unique new group name.
+(defun gnus-generate-new-group-name (leaf)
+ (let ((name leaf)
+ (num 0))
+ (while (gnus-gethash name gnus-newsrc-hashtb)
+ (setq name (concat leaf "<" (int-to-string (setq num (1+ num))) ">")))
+ name))
+
+(defun gnus-ephemeral-group-p (group)
+ "Say whether GROUP is ephemeral or not."
+ (assoc 'quit-config (gnus-find-method-for-group group)))
+
+(defun gnus-group-quit-config (group)
+ "Return the quit-config of GROUP."
+ (cdr (assoc 'quit-config (gnus-find-method-for-group group))))
+
+;;; 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."
+ (if (and (consp list) (not (consp (cdr list))))
+ (cons (car list) (cdr list))
+ (mapcar (lambda (elem) (if (consp elem)
+ (if (consp (cdr elem))
+ (gnus-copy-sequence elem)
+ (cons (car elem) (cdr elem)))
+ elem))
+ list)))
+
+(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
+ (if (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))
+ (if (numberp (car ranges))
+ (setq result (cons (car ranges) result)))
+ (setq first (car (car ranges)))
+ (setq last (cdr (car 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))
+ (or (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))
+ (car (car ranges))))
+ (while (and list (cdr list) (< (car (cdr list)) lowest))
+ (setq list (cdr list)))
+ (if (< (car ilist) lowest)
+ (progn
+ (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))
+ (cdr (car ranges))))
+ (while (and list (<= (car list) highest))
+ (setq list (cdr list)))
+ (setq ranges (cdr ranges)))
+ (if 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))
+ (if (cdr ranges)
+ (if (atom (car (cdr ranges)))
+ (if (= (1+ (car ranges)) (car (cdr ranges)))
+ (progn
+ (setcar ranges (cons (car ranges)
+ (car (cdr ranges))))
+ (setcdr ranges (cdr (cdr ranges)))))
+ (if (= (1+ (car ranges)) (car (car (cdr ranges))))
+ (progn
+ (setcar (car (cdr ranges)) (car ranges))
+ (setcar ranges (car (cdr ranges)))
+ (setcdr ranges (cdr (cdr ranges)))))))
+ (if (cdr ranges)
+ (if (atom (car (cdr ranges)))
+ (if (= (1+ (cdr (car ranges))) (car (cdr ranges)))
+ (progn
+ (setcdr (car ranges) (car (cdr ranges)))
+ (setcdr ranges (cdr (cdr ranges)))))
+ (if (= (1+ (cdr (car ranges))) (car (car (cdr ranges))))
+ (progn
+ (setcdr (car ranges) (cdr (car (cdr ranges))))
+ (setcdr ranges (cdr (cdr 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 (car (car ranges))))
+ not-stop)
+ (if (if (numberp (car ranges))
+ (= number (car ranges))
+ (and (>= number (car (car ranges)))
+ (<= number (cdr (car ranges)))))
+ (setq not-stop nil))
+ (setq ranges (cdr ranges)))
+ (not not-stop))))
+
+
+;;;
+;;; Gnus group mode
+;;;
+
+(defvar gnus-group-mode-map nil)
+(defvar gnus-group-group-map nil)
+(defvar gnus-group-mark-map nil)
+(defvar gnus-group-list-map nil)
+(defvar gnus-group-sub-map nil)
+(put 'gnus-group-mode 'mode-class 'special)
+
+(if gnus-group-mode-map
+ nil
+ (setq gnus-group-mode-map (make-keymap))
+ (suppress-keymap gnus-group-mode-map)
+ (define-key gnus-group-mode-map " " 'gnus-group-read-group)
+ (define-key gnus-group-mode-map "=" 'gnus-group-select-group)
+ (define-key gnus-group-mode-map "\r" 'gnus-group-select-group)
+ (define-key gnus-group-mode-map "j" 'gnus-group-jump-to-group)
+ (define-key gnus-group-mode-map "n" 'gnus-group-next-unread-group)
+ (define-key gnus-group-mode-map "p" 'gnus-group-prev-unread-group)
+ (define-key gnus-group-mode-map "\177" 'gnus-group-prev-unread-group)
+ (define-key gnus-group-mode-map "N" 'gnus-group-next-group)
+ (define-key gnus-group-mode-map "P" 'gnus-group-prev-group)
+ (define-key gnus-group-mode-map
+ "\M-n" 'gnus-group-next-unread-group-same-level)
+ (define-key gnus-group-mode-map
+ "\M-p" 'gnus-group-prev-unread-group-same-level)
+ (define-key gnus-group-mode-map "," 'gnus-group-best-unread-group)
+ (define-key gnus-group-mode-map "." 'gnus-group-first-unread-group)
+ (define-key gnus-group-mode-map "u" 'gnus-group-unsubscribe-current-group)
+ (define-key gnus-group-mode-map "U" 'gnus-group-unsubscribe-group)
+ (define-key gnus-group-mode-map "c" 'gnus-group-catchup-current)
+ (define-key gnus-group-mode-map "C" 'gnus-group-catchup-current-all)
+ (define-key gnus-group-mode-map "l" 'gnus-group-list-groups)
+ (define-key gnus-group-mode-map "L" 'gnus-group-list-all-groups)
+ (define-key gnus-group-mode-map "m" 'gnus-group-mail)
+ (define-key gnus-group-mode-map "g" 'gnus-group-get-new-news)
+ (define-key gnus-group-mode-map "\M-g" 'gnus-group-get-new-news-this-group)
+ (define-key gnus-group-mode-map "R" 'gnus-group-restart)
+ (define-key gnus-group-mode-map "r" 'gnus-group-read-init-file)
+ (define-key gnus-group-mode-map "B" 'gnus-group-browse-foreign-server)
+ (define-key gnus-group-mode-map "b" 'gnus-group-check-bogus-groups)
+ (define-key gnus-group-mode-map "F" 'gnus-find-new-newsgroups)
+ (define-key gnus-group-mode-map "\C-c\C-d" 'gnus-group-describe-group)
+ (define-key gnus-group-mode-map "\M-d" 'gnus-group-describe-all-groups)
+ (define-key gnus-group-mode-map "\C-c\C-a" 'gnus-group-apropos)
+ (define-key gnus-group-mode-map "\C-c\M-\C-a" 'gnus-group-description-apropos)
+ (define-key gnus-group-mode-map "a" 'gnus-group-post-news)
+ (define-key gnus-group-mode-map "\ek" 'gnus-group-edit-local-kill)
+ (define-key gnus-group-mode-map "\eK" 'gnus-group-edit-global-kill)
+ (define-key gnus-group-mode-map "\C-k" 'gnus-group-kill-group)
+ (define-key gnus-group-mode-map "\C-y" 'gnus-group-yank-group)
+ (define-key gnus-group-mode-map "\C-w" 'gnus-group-kill-region)
+ (define-key gnus-group-mode-map "\C-x\C-t" 'gnus-group-transpose-groups)
+ (define-key gnus-group-mode-map "\C-c\C-l" 'gnus-group-list-killed)
+ (define-key gnus-group-mode-map "\C-c\C-x" 'gnus-group-expire-articles)
+ (define-key gnus-group-mode-map "\C-c\M-\C-x" 'gnus-group-expire-all-groups)
+ (define-key gnus-group-mode-map "V" 'gnus-version)
+ (define-key gnus-group-mode-map "s" 'gnus-group-save-newsrc)
+ (define-key gnus-group-mode-map "z" 'gnus-group-suspend)
+ (define-key gnus-group-mode-map "Z" 'gnus-group-clear-dribble)
+ (define-key gnus-group-mode-map "q" 'gnus-group-exit)
+ (define-key gnus-group-mode-map "Q" 'gnus-group-quit)
+ (define-key gnus-group-mode-map "\M-f" 'gnus-group-fetch-faq)
+ (define-key gnus-group-mode-map "?" 'gnus-group-describe-briefly)
+ (define-key gnus-group-mode-map "\C-c\C-i" 'gnus-info-find-node)
+ (define-key gnus-group-mode-map "\M-e" 'gnus-group-edit-group-method)
+ (define-key gnus-group-mode-map "^" 'gnus-group-enter-server-mode)
+ (define-key gnus-group-mode-map gnus-mouse-2 'gnus-mouse-pick-group)
+ (define-key gnus-group-mode-map "<" 'beginning-of-buffer)
+ (define-key gnus-group-mode-map ">" 'end-of-buffer)
+ (define-key gnus-group-mode-map "\C-c\C-b" 'gnus-bug)
+ (define-key gnus-group-mode-map "\C-c\C-s" 'gnus-group-sort-groups)
+
+ (define-key gnus-group-mode-map "#" 'gnus-group-mark-group)
+ (define-key gnus-group-mode-map "\M-#" 'gnus-group-unmark-group)
+ (define-prefix-command 'gnus-group-mark-map)
+ (define-key gnus-group-mode-map "M" 'gnus-group-mark-map)
+ (define-key gnus-group-mark-map "m" 'gnus-group-mark-group)
+ (define-key gnus-group-mark-map "u" 'gnus-group-unmark-group)
+ (define-key gnus-group-mark-map "w" 'gnus-group-mark-region)
+
+ (define-prefix-command 'gnus-group-group-map)
+ (define-key gnus-group-mode-map "G" 'gnus-group-group-map)
+ (define-key gnus-group-group-map "d" 'gnus-group-make-directory-group)
+ (define-key gnus-group-group-map "h" 'gnus-group-make-help-group)
+ (define-key gnus-group-group-map "a" 'gnus-group-make-archive-group)
+ (define-key gnus-group-group-map "k" 'gnus-group-make-kiboze-group)
+ (define-key gnus-group-group-map "m" 'gnus-group-make-group)
+ (define-key gnus-group-group-map "E" 'gnus-group-edit-group)
+ (define-key gnus-group-group-map "e" 'gnus-group-edit-group-method)
+ (define-key gnus-group-group-map "p" 'gnus-group-edit-group-parameters)
+ (define-key gnus-group-group-map "v" 'gnus-group-add-to-virtual)
+ (define-key gnus-group-group-map "V" 'gnus-group-make-empty-virtual)
+ (define-key gnus-group-group-map "D" 'gnus-group-enter-directory)
+ (define-key gnus-group-group-map "f" 'gnus-group-make-doc-group)
+ ;;(define-key gnus-group-group-map "sb" 'gnus-group-brew-soup)
+ ;;(define-key gnus-group-group-map "sw" 'gnus-soup-save-areas)
+ ;;(define-key gnus-group-group-map "ss" 'gnus-soup-send-replies)
+ ;;(define-key gnus-group-group-map "sp" 'gnus-soup-pack-packet)
+ ;;(define-key gnus-group-group-map "sr" 'nnsoup-pack-replies)
+
+ (define-prefix-command 'gnus-group-list-map)
+ (define-key gnus-group-mode-map "A" 'gnus-group-list-map)
+ (define-key gnus-group-list-map "k" 'gnus-group-list-killed)
+ (define-key gnus-group-list-map "z" 'gnus-group-list-zombies)
+ (define-key gnus-group-list-map "s" 'gnus-group-list-groups)
+ (define-key gnus-group-list-map "u" 'gnus-group-list-all-groups)
+ (define-key gnus-group-list-map "a" 'gnus-group-apropos)
+ (define-key gnus-group-list-map "d" 'gnus-group-description-apropos)
+ (define-key gnus-group-list-map "m" 'gnus-group-list-matching)
+ (define-key gnus-group-list-map "M" 'gnus-group-list-all-matching)
+
+ (define-prefix-command 'gnus-group-sub-map)
+ (define-key gnus-group-mode-map "S" 'gnus-group-sub-map)
+ (define-key gnus-group-sub-map "l" 'gnus-group-set-current-level)
+ (define-key gnus-group-sub-map "t" 'gnus-group-unsubscribe-current-group)
+ (define-key gnus-group-sub-map "s" 'gnus-group-unsubscribe-group)
+ (define-key gnus-group-sub-map "k" 'gnus-group-kill-group)
+ (define-key gnus-group-sub-map "y" 'gnus-group-yank-group)
+ (define-key gnus-group-sub-map "w" 'gnus-group-kill-region)
+ (define-key gnus-group-sub-map "z" 'gnus-group-kill-all-zombies))
+
+(defun gnus-group-mode ()
+ "Major mode for reading news.
+
+All normal editing commands are switched off.
+\\<gnus-group-mode-map>
+The group buffer lists (some of) the groups available. For instance,
+`\\[gnus-group-list-groups]' will list all subscribed groups with unread articles, while `\\[gnus-group-list-zombies]'
+lists all zombie groups.
+
+Groups that are displayed can be entered with `\\[gnus-group-read-group]'. To subscribe
+to a group not displayed, type `\\[gnus-group-unsubscribe-group]'.
+
+For more in-depth information on this mode, read the manual (`\\[gnus-info-find-node]').
+
+The following commands are available:
+
+\\{gnus-group-mode-map}"
+ (interactive)
+ (if gnus-visual (gnus-group-make-menu-bar))
+ (kill-all-local-variables)
+ (setq mode-line-modified "-- ")
+ (make-local-variable 'mode-line-format)
+ (setq mode-line-format (copy-sequence mode-line-format))
+ (and (equal (nth 3 mode-line-format) " ")
+ (setcar (nthcdr 3 mode-line-format) ""))
+ (setq major-mode 'gnus-group-mode)
+ (setq mode-name "Group")
+ (gnus-group-set-mode-line)
+ (setq mode-line-process nil)
+ (use-local-map gnus-group-mode-map)
+ (buffer-disable-undo (current-buffer))
+ (setq truncate-lines t)
+ (setq buffer-read-only t)
+ (run-hooks 'gnus-group-mode-hook))
+
+(defun gnus-mouse-pick-group (e)
+ (interactive "e")
+ (mouse-set-point e)
+ (gnus-group-read-group nil))
+
+;; Look at LEVEL and find out what the level is really supposed to be.
+;; If LEVEL is non-nil, LEVEL will be returned, if not, what happens
+;; will depend on whether `gnus-group-use-permanent-levels' is used.
+(defun gnus-group-default-level (&optional level number-or-nil)
+ (cond
+ (gnus-group-use-permanent-levels
+ (setq gnus-group-default-list-level
+ (or level gnus-group-default-list-level))
+ (or gnus-group-default-list-level gnus-level-subscribed))
+ (number-or-nil
+ level)
+ (t
+ (or level gnus-group-default-list-level gnus-level-subscribed))))
+
+
+(defvar gnus-tmp-prev-perm nil)
+
+;;;###autoload
+(defun gnus-no-server (&optional arg)
+ "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."
+ (interactive "P")
+ (let ((perm
+ (cons gnus-group-use-permanent-levels gnus-group-default-list-level)))
+ (setq gnus-tmp-prev-perm nil)
+ (setq gnus-group-use-permanent-levels t)
+ (gnus (or arg (1- gnus-level-default-subscribed)) t)
+ (setq gnus-tmp-prev-perm perm)))
+
+;;;###autoload
+(defun gnus (&optional arg dont-connect)
+ "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."
+ (interactive "P")
+ (if (get-buffer gnus-group-buffer)
+ (progn
+ (switch-to-buffer gnus-group-buffer)
+ (gnus-group-get-new-news))
+
+ (gnus-clear-system)
+
+ (nnheader-init-server-buffer)
+ ;; We do this if `gnus-no-server' has been run.
+ (if gnus-tmp-prev-perm
+ (setq gnus-group-use-permanent-levels (car gnus-tmp-prev-perm)
+ gnus-group-default-list-level (cdr gnus-tmp-prev-perm)
+ gnus-tmp-prev-perm nil))
+ (gnus-read-init-file)
+
+ (gnus-group-setup-buffer)
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (if (not gnus-inhibit-startup-message)
+ (progn
+ (gnus-group-startup-message)
+ (sit-for 0))))
+
+ (let ((level (and arg (numberp arg) (> arg 0) arg))
+ did-connect)
+ (unwind-protect
+ (progn
+ (or dont-connect
+ (setq did-connect
+ (gnus-start-news-server (and arg (not level))))))
+ (if (and (not dont-connect)
+ (not did-connect))
+ (gnus-group-quit)
+ (run-hooks 'gnus-startup-hook)
+ ;; NNTP server is successfully open.
+
+ ;; Find the current startup file name.
+ (setq gnus-current-startup-file
+ (gnus-make-newsrc-file gnus-startup-file))
+
+ ;; Read the dribble file.
+ (and gnus-use-dribble-file (gnus-dribble-read-file))
+
+ (gnus-summary-make-display-table)
+ (gnus-setup-news nil level)
+ (gnus-group-list-groups level)
+ (gnus-configure-windows 'group))))))
+
+(defun gnus-unload ()
+ "Unload all Gnus features."
+ (interactive)
+ (or (boundp 'load-history)
+ (error "Sorry, `gnus-unload' is not implemented in this Emacs version."))
+ (let ((history load-history)
+ feature)
+ (while history
+ (and (string-match "^gnus" (car (car history)))
+ (setq feature (cdr (assq 'provide (car history))))
+ (unload-feature feature 'force))
+ (setq history (cdr history)))))
+
+(defun gnus-group-startup-message (&optional x y)
+ "Insert startup message in current buffer."
+ ;; Insert the message.
+ (erase-buffer)
+ (insert
+ (format "
+ _ ___ _ _
+ _ ___ __ ___ __ _ ___
+ __ _ ___ __ ___
+ _ ___ _
+ _ _ __ _
+ ___ __ _
+ __ _
+ _ _ _
+ _ _ _
+ _ _ _
+ __ ___
+ _ _ _ _
+ _ _
+ _ _
+ _ _
+ _
+ __
+
+
+ Gnus * A newsreader for Emacsen
+ A Praxis release * larsi@ifi.uio.no
+"
+ gnus-version))
+ ;; And then hack it.
+ ;; 18 is the longest line.
+ (indent-rigidly (point-min) (point-max)
+ (/ (max (- (window-width) (or x 46)) 0) 2))
+ (goto-char (point-min))
+ (let* ((pheight (count-lines (point-min) (point-max)))
+ (wheight (window-height))
+ (rest (- wheight pheight)))
+ (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
+
+
+
+ ;; Fontify some.
+ (goto-char (point-min))
+ (search-forward "Praxis")
+ (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
+ (goto-char (point-min)))
+
+(defun gnus-group-startup-message-old (&optional x y)
+ "Insert startup message in current buffer."
+ ;; Insert the message.
+ (erase-buffer)
+ (insert
+ (format "
+ %s
+ A newsreader
+ for GNU Emacs
+
+ Based on GNUS
+ written by
+ Masanobu UMEDA
+
+ A Praxis Release
+ larsi@ifi.uio.no
+"
+ gnus-version))
+ ;; And then hack it.
+ ;; 18 is the longest line.
+ (indent-rigidly (point-min) (point-max)
+ (/ (max (- (window-width) (or x 28)) 0) 2))
+ (goto-char (point-min))
+ ;; +4 is fuzzy factor.
+ (insert-char ?\n (/ (max (- (window-height) (or y 12)) 0) 2))
+
+ ;; Fontify some.
+ (goto-char (point-min))
+ (search-forward "Praxis")
+ (put-text-property (match-beginning 0) (match-end 0) 'face 'bold)
+ (goto-char (point-min)))
+
+(defun gnus-group-setup-buffer ()
+ (or (get-buffer gnus-group-buffer)
+ (progn
+ (switch-to-buffer gnus-group-buffer)
+ (gnus-add-current-to-buffer-list)
+ (gnus-group-mode)
+ (and gnus-carpal (gnus-carpal-setup-buffer 'group)))))
+
+(defun gnus-group-list-groups (&optional level unread)
+ "List newsgroups with level LEVEL or lower that have unread articles.
+Default is all subscribed groups.
+If argument UNREAD is non-nil, groups with no unread articles are also
+listed."
+ (interactive (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ (or
+ (gnus-group-default-level nil t)
+ gnus-group-default-list-level
+ gnus-level-subscribed))))
+ (or level
+ (setq level (car gnus-group-list-mode)
+ unread (cdr gnus-group-list-mode)))
+ (setq level (gnus-group-default-level level))
+ (gnus-group-setup-buffer) ;May call from out of group buffer
+ (let ((case-fold-search nil)
+ (group (gnus-group-group-name)))
+ (funcall gnus-group-prepare-function level unread nil)
+ (if (zerop (buffer-size))
+ (gnus-message 5 gnus-no-groups-message)
+ (goto-char (point-min))
+ (if (not group)
+ ;; Go to the first group with unread articles.
+ (gnus-group-search-forward nil nil nil t)
+ ;; Find the right group to put point on. If the current group
+ ;; has disapeared in the new listing, try to find the next
+ ;; one. If no next one can be found, just leave point at the
+ ;; first newsgroup in the buffer.
+ (if (not (gnus-goto-char
+ (text-property-any (point-min) (point-max)
+ 'gnus-group (intern group))))
+ (let ((newsrc (nthcdr 3 (gnus-gethash group gnus-newsrc-hashtb))))
+ (while (and newsrc
+ (not (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max) 'gnus-group
+ (intern (car (car newsrc)))))))
+ (setq newsrc (cdr newsrc)))
+ (or newsrc (progn (goto-char (point-max))
+ (forward-line -1))))))
+ ;; Adjust cursor point.
+ (gnus-group-position-cursor))))
+
+(defun gnus-group-prepare-flat (level &optional all lowest regexp)
+ "List all newsgroups with unread articles of level LEVEL or lower.
+If ALL is non-nil, list groups that have no unread articles.
+If LOWEST is non-nil, list all newsgroups of level LOWEST or higher.
+If REGEXP, only list groups matching REGEXP."
+ (set-buffer gnus-group-buffer)
+ (let ((buffer-read-only nil)
+ (newsrc (cdr gnus-newsrc-alist))
+ (lowest (or lowest 1))
+ info clevel unread group)
+ (erase-buffer)
+ (if (< lowest gnus-level-zombie)
+ ;; List living groups.
+ (while newsrc
+ (setq info (car newsrc)
+ group (car info)
+ newsrc (cdr newsrc)
+ unread (car (gnus-gethash group gnus-newsrc-hashtb)))
+ (and unread ; This group might be bogus
+ (or (not regexp)
+ (string-match regexp group))
+ (<= (setq clevel (car (cdr info))) level)
+ (>= clevel lowest)
+ (or all ; We list all groups?
+ (eq unread t) ; We list unactivated groups
+ (> unread 0) ; We list groups with unread articles
+ (cdr (assq 'tick (nth 3 info)))) ; And groups with tickeds
+ (gnus-group-insert-group-line
+ nil group (car (cdr info)) (nth 3 info) unread (nth 4 info)))))
+
+ ;; List dead groups.
+ (and (>= level gnus-level-zombie) (<= lowest gnus-level-zombie)
+ (gnus-group-prepare-flat-list-dead
+ (setq gnus-zombie-list (sort gnus-zombie-list 'string<))
+ gnus-level-zombie ?Z
+ regexp))
+ (and (>= level gnus-level-killed) (<= lowest gnus-level-killed)
+ (gnus-group-prepare-flat-list-dead
+ (setq gnus-killed-list (sort gnus-killed-list 'string<))
+ gnus-level-killed ?K regexp))
+
+ (gnus-group-set-mode-line)
+ (setq gnus-group-list-mode (cons level all))
+ (run-hooks 'gnus-group-prepare-hook)))
+
+(defun gnus-group-prepare-flat-list-dead (groups level mark regexp)
+ ;; List zombies and killed lists somehwat faster, which was
+ ;; suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>. It does
+ ;; this by ignoring the group format specification altogether.
+ (let (group beg)
+ (while groups
+ (setq group (car groups)
+ groups (cdr groups))
+ (if (or (not regexp)
+ (string-match regexp group))
+ (progn
+ (setq beg (point))
+ (insert (format " %c *: %s\n" mark group))
+ (add-text-properties
+ beg (1+ beg)
+ (list 'gnus-group (intern group)
+ 'gnus-unread t
+ 'gnus-level level)))))))
+
+(defun gnus-group-real-name (group)
+ "Find the real name of a foreign newsgroup."
+ (if (string-match ":[^:]+$" group)
+ (substring group (1+ (match-beginning 0)))
+ group))
+
+(defun gnus-group-prefixed-name (group method)
+ "Return the whole name from GROUP and METHOD."
+ (and (stringp method) (setq method (gnus-server-to-method method)))
+ (concat (format "%s" (car method))
+ (if (and
+ (assoc (format "%s" (car method)) (gnus-methods-using 'address))
+ (not (string= (nth 1 method) "")))
+ (concat "+" (nth 1 method)))
+ ":" group))
+
+(defun gnus-group-real-prefix (group)
+ "Return the prefix of the current group name."
+ (if (string-match "^[^:]+:" group)
+ (substring group 0 (match-end 0))
+ ""))
+
+(defun gnus-group-method-name (group)
+ "Return the method used for selecting GROUP."
+ (let ((prefix (gnus-group-real-prefix group)))
+ (if (equal prefix "")
+ gnus-select-method
+ (if (string-match "^[^\\+]+\\+" prefix)
+ (list (intern (substring prefix 0 (1- (match-end 0))))
+ (substring prefix (match-end 0) (1- (length prefix))))
+ (list (intern (substring prefix 0 (1- (length prefix)))) "")))))
+
+(defun gnus-group-foreign-p (group)
+ "Return nil if GROUP is native, non-nil if it is foreign."
+ (string-match ":" group))
+
+(defun gnus-group-set-info (info &optional method-only-group part)
+ (let* ((entry (gnus-gethash
+ (or method-only-group (car info)) gnus-newsrc-hashtb))
+ (part-info info)
+ (info (if method-only-group (nth 2 entry) info)))
+ (if (not method-only-group)
+ ()
+ (or entry
+ (error "Trying to change non-existent group %s" method-only-group))
+ ;; We have recevied parts of the actual group info - either the
+ ;; select method or the group parameters. We first check
+ ;; whether we have to extend the info, and if so, do that.
+ (let ((len (length info))
+ (total (if (eq part 'method) 5 6)))
+ (and (< len total)
+ (setcdr (nthcdr (1- len) info)
+ (make-list (- total len) nil)))
+ ;; Then we enter the new info.
+ (setcar (nthcdr (1- total) info) part-info)))
+ ;; We uncompress some lists of marked articles.
+ (let (marked)
+ (if (not (setq marked (nth 3 info)))
+ ()
+ (while marked
+ (or (eq 'score (car (car marked)))
+ (eq 'bookmark (car (car marked)))
+ (eq 'killed (car (car marked)))
+ (setcdr (car marked)
+ (gnus-uncompress-range (cdr (car marked)))))
+ (setq marked (cdr marked)))))
+ (if entry
+ ()
+ ;; This is a new group, so we just create it.
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (if (nth 4 info)
+ ;; It's a foreign group...
+ (gnus-group-make-group
+ (gnus-group-real-name (car info))
+ (prin1-to-string (car (nth 4 info)))
+ (nth 1 (nth 4 info)))
+ ;; It's a native group.
+ (gnus-group-make-group (car info)))
+ (gnus-message 6 "Note: New group created")
+ (setq entry
+ (gnus-gethash (gnus-group-prefixed-name
+ (gnus-group-real-name (car info))
+ (or (nth 4 info) gnus-select-method))
+ gnus-newsrc-hashtb))))
+ ;; Whether it was a new group or not, we now have the entry, so we
+ ;; can do the update.
+ (if entry
+ (progn
+ (setcar (nthcdr 2 entry) info)
+ (if (and (not (eq (car entry) t))
+ (gnus-gethash (car info) gnus-active-hashtb))
+ (let ((marked (nth 3 info)))
+ (setcar entry
+ (max 0 (- (length (gnus-list-of-unread-articles
+ (car info)))
+ (length (cdr (assq 'tick marked)))
+ (length (cdr (assq 'dormant marked)))))))))
+ (error "No such group: %s" (car info)))))
+
+(defun gnus-group-set-method-info (group select-method)
+ (gnus-group-set-info select-method group 'method))
+
+(defun gnus-group-set-params-info (group params)
+ (gnus-group-set-info params group 'params))
+
+(defun gnus-group-update-group-line ()
+ "This function updates the current line in the newsgroup buffer and
+moves the point to the colon."
+ (let* ((buffer-read-only nil)
+ (group (gnus-group-group-name))
+ (entry (and group (gnus-gethash group gnus-newsrc-hashtb))))
+ (if (and entry (not (gnus-ephemeral-group-p group)))
+ (gnus-dribble-enter
+ (concat "(gnus-group-set-info '" (prin1-to-string (nth 2 entry))
+ ")")))
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ (gnus-group-insert-group-line-info group)
+ (forward-line -1)
+ (gnus-group-position-cursor)))
+
+(defun gnus-group-insert-group-line-info (group)
+ (let ((entry (gnus-gethash group gnus-newsrc-hashtb))
+ active info)
+ (if entry
+ (progn
+ (setq info (nth 2 entry))
+ (gnus-group-insert-group-line
+ nil group (nth 1 info) (nth 3 info) (car entry) (nth 4 info)))
+ (setq active (gnus-gethash group gnus-active-hashtb))
+ (gnus-group-insert-group-line
+ nil group
+ (if (member group gnus-zombie-list) gnus-level-zombie gnus-level-killed)
+ nil (if active (- (1+ (cdr active)) (car active)) 0) nil))))
+
+(defun gnus-group-insert-group-line (gformat group level marked number method)
+ (let* ((gformat (or gformat gnus-group-line-format-spec))
+ (active (gnus-gethash group gnus-active-hashtb))
+ (number-total (if active (1+ (- (cdr active) (car active))) 0))
+ (number-of-dormant (length (cdr (assq 'dormant marked))))
+ (number-of-ticked (length (cdr (assq 'tick marked))))
+ (number-of-ticked-and-dormant
+ (+ number-of-ticked number-of-dormant))
+ (number-of-unread-unticked
+ (if (numberp number) (int-to-string (max 0 number))
+ "*"))
+ (number-of-read
+ (if (numberp number)
+ (max 0 (- number-total number))
+ "*"))
+ (subscribed (cond ((<= level gnus-level-subscribed) ? )
+ ((<= level gnus-level-unsubscribed) ?U)
+ ((= level gnus-level-zombie) ?Z)
+ (t ?K)))
+ (qualified-group (gnus-group-real-name group))
+ (newsgroup-description
+ (if gnus-description-hashtb
+ (or (gnus-gethash group gnus-description-hashtb) "")
+ ""))
+ (moderated (if (member group gnus-moderated-list) ?m ? ))
+ (moderated-string (if (eq moderated ?m) "(m)" ""))
+ (method (gnus-server-get-method group method))
+ (news-server (or (car (cdr method)) ""))
+ (news-method (or (car method) ""))
+ (news-method-string
+ (if method (format "(%s:%s)" (car method) (car (cdr method))) ""))
+ (marked (if (and
+ (numberp number)
+ (zerop number)
+ (> number-of-ticked 0))
+ ?* ? ))
+ (number (if (eq number t) "*" (+ number number-of-dormant
+ number-of-ticked)))
+ (process-marked (if (member group gnus-group-marked)
+ gnus-process-mark ? ))
+ (buffer-read-only nil)
+ header ; passed as parameter to user-funcs.
+ b)
+ (beginning-of-line)
+ (setq b (point))
+ ;; Insert the text.
+ (insert (eval gformat))
+
+ (add-text-properties
+ b (1+ b) (list 'gnus-group (intern group)
+ 'gnus-unread (if (numberp number)
+ (string-to-int number-of-unread-unticked)
+ t)
+ 'gnus-marked marked
+ 'gnus-level level))))
+
+(defun gnus-group-update-group (group &optional visible-only)
+ "Update newsgroup info of GROUP.
+If VISIBLE-ONLY is non-nil, the group won't be displayed if it isn't already."
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (let ((buffer-read-only nil)
+ visible)
+ (let ((entry (gnus-gethash group gnus-newsrc-hashtb)))
+ (if (and entry
+ (not (gnus-ephemeral-group-p group)))
+ (gnus-dribble-enter
+ (concat "(gnus-group-set-info '" (prin1-to-string (nth 2 entry))
+ ")"))))
+ ;; Buffer may be narrowed.
+ (save-restriction
+ (widen)
+ ;; Search a line to modify. If the buffer is large, the search
+ ;; takes long time. In most cases, current point is on the line
+ ;; we are looking for. So, first of all, check current line.
+ (if (or (progn
+ (beginning-of-line)
+ (eq (get-text-property (point) 'gnus-group)
+ (intern group)))
+ (progn
+ (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max) 'gnus-group (intern group)))))
+ ;; GROUP is listed in current buffer. So, delete old line.
+ (progn
+ (setq visible t)
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point))))
+ ;; No such line in the buffer, find out where it's supposed to
+ ;; go, and insert it there (or at the end of the buffer).
+ ;; Fix by Per Abrahamsen <amanda@iesd.auc.dk>.
+ (or visible-only
+ (let ((entry
+ (cdr (cdr (gnus-gethash group gnus-newsrc-hashtb)))))
+ (while (and entry
+ (car entry)
+ (not
+ (gnus-goto-char
+ (text-property-any
+ (point-min) (point-max)
+ 'gnus-group (intern (car (car entry)))))))
+ (setq entry (cdr entry)))
+ (or entry (goto-char (point-max)))))))
+ (if (or visible (not visible-only))
+ (gnus-group-insert-group-line-info group))
+ (gnus-group-set-mode-line))))
+
+(defun gnus-group-set-mode-line ()
+ (if (memq 'group gnus-updated-mode-lines)
+ (let* ((gformat (or gnus-group-mode-line-format-spec
+ (setq gnus-group-mode-line-format-spec
+ (gnus-parse-format
+ gnus-group-mode-line-format
+ gnus-group-mode-line-format-alist))))
+ (news-server (car (cdr gnus-select-method)))
+ (news-method (car gnus-select-method))
+ (max-len 60)
+ (mode-string (eval gformat)))
+ (setq mode-string (eval gformat))
+ (if (> (length mode-string) max-len)
+ (setq mode-string (substring mode-string 0 (- max-len 4))))
+ (setq mode-line-buffer-identification mode-string)
+ (set-buffer-modified-p t))))
+
+(defun gnus-group-group-name ()
+ "Get the name of the newsgroup on the current line."
+ (let ((group (get-text-property (gnus-point-at-bol) 'gnus-group)))
+ (and group (symbol-name group))))
+
+(defun gnus-group-group-level ()
+ "Get the level of the newsgroup on the current line."
+ (get-text-property (gnus-point-at-bol) 'gnus-level))
+
+(defun gnus-group-group-unread ()
+ "Get the number of unread articles of the newsgroup on the current line."
+ (get-text-property (gnus-point-at-bol) 'gnus-unread))
+
+(defun gnus-group-search-forward (&optional backward all level first-too)
+ "Find the next newsgroup with unread articles.
+If BACKWARD is non-nil, find the previous newsgroup instead.
+If ALL is non-nil, just find any newsgroup.
+If LEVEL is non-nil, find group with level LEVEL, or higher if no such
+group exists.
+If FIRST-TOO, the current line is also eligible as a target."
+ (let ((way (if backward -1 1))
+ (low gnus-level-killed)
+ (beg (point))
+ pos found lev)
+ (if (and backward (progn (beginning-of-line)) (bobp))
+ nil
+ (or first-too (forward-line way))
+ (while (and
+ (not (eobp))
+ (not (setq
+ found
+ (and (or all
+ (and
+ (let ((unread
+ (get-text-property (point) 'gnus-unread)))
+ (or (eq unread t) (and unread (> unread 0))))
+ (setq lev (get-text-property (point)
+ 'gnus-level))
+ (<= lev gnus-level-subscribed)))
+ (or (not level)
+ (and (setq lev (get-text-property (point)
+ 'gnus-level))
+ (or (= lev level)
+ (and (< lev low)
+ (< level lev)
+ (progn
+ (setq low lev)
+ (setq pos (point))
+ nil))))))))
+ (zerop (forward-line way)))))
+ (if found
+ (progn (gnus-group-position-cursor) t)
+ (goto-char (or pos beg))
+ (and pos t))))
+
+;;; Gnus group mode commands
+
+;; Group marking.
+
+(defun gnus-group-mark-group (n &optional unmark no-advance)
+ "Mark the current group."
+ (interactive "p")
+ (let ((buffer-read-only nil)
+ group)
+ (while
+ (and (> n 0)
+ (setq group (gnus-group-group-name))
+ (progn
+ (beginning-of-line)
+ (forward-char
+ (or (cdr (assq 'process gnus-group-mark-positions)) 2))
+ (delete-char 1)
+ (if unmark
+ (progn
+ (insert " ")
+ (setq gnus-group-marked (delete group gnus-group-marked)))
+ (insert "#")
+ (setq gnus-group-marked
+ (cons group (delete group gnus-group-marked))))
+ t)
+ (or no-advance (zerop (gnus-group-next-group 1))))
+ (setq n (1- n)))
+ (gnus-summary-position-cursor)
+ n))
+
+(defun gnus-group-unmark-group (n)
+ "Remove the mark from the current group."
+ (interactive "p")
+ (gnus-group-mark-group n 'unmark))
+
+(defun gnus-group-mark-region (unmark beg end)
+ "Mark all groups between point and mark.
+If UNMARK, remove the mark instead."
+ (interactive "P\nr")
+ (let ((num (count-lines beg end)))
+ (save-excursion
+ (goto-char beg)
+ (- num (gnus-group-mark-group num unmark)))))
+
+(defun gnus-group-remove-mark (group)
+ (and (gnus-group-goto-group group)
+ (save-excursion
+ (gnus-group-mark-group 1 'unmark t))))
+
+;; Return a list of groups to work on. Take into consideration N (the
+;; prefix) and the list of marked groups.
+(defun gnus-group-process-prefix (n)
+ (cond (n
+ (setq n (prefix-numeric-value n))
+ ;; There is a prefix, so we return a list of the N next
+ ;; groups.
+ (let ((way (if (< n 0) -1 1))
+ (n (abs n))
+ group groups)
+ (save-excursion
+ (while (and (> n 0)
+ (setq group (gnus-group-group-name)))
+ (setq groups (cons group groups))
+ (setq n (1- n))
+ (forward-line way)))
+ (nreverse groups)))
+ (gnus-group-marked
+ ;; No prefix, but a list of marked articles.
+ (reverse gnus-group-marked))
+ (t
+ ;; Neither marked articles or a prefix, so we return the
+ ;; current group.
+ (let ((group (gnus-group-group-name)))
+ (and group (list group))))))
+
+;; Selecting groups.
+
+(defun gnus-group-read-group (&optional all no-article group)
+ "Read news in this newsgroup.
+If the prefix argument ALL is non-nil, already read articles become
+readable. If the optional argument NO-ARTICLE is non-nil, no article
+will be auto-selected upon group entry."
+ (interactive "P")
+ (let ((group (or group (gnus-group-group-name)))
+ number active marked entry)
+ (or group (error "No group on current line"))
+ (setq marked
+ (nth 3 (nth 2 (setq entry (gnus-gethash group gnus-newsrc-hashtb)))))
+ ;; This group might be a dead group. In that case we have to get
+ ;; the number of unread articles from `gnus-active-hashtb'.
+ (if entry
+ (setq number (car entry))
+ (if (setq active (gnus-gethash group gnus-active-hashtb))
+ (setq number (- (1+ (cdr active)) (car active)))))
+ (gnus-summary-read-group
+ group (or all (and (numberp number)
+ (zerop (+ number (length (cdr (assq 'tick marked)))
+ (length (cdr (assq 'dormant marked)))))))
+ no-article)))
+
+(defun gnus-group-select-group (&optional all)
+ "Select this newsgroup.
+No article is selected automatically.
+If argument ALL is non-nil, already read articles become readable."
+ (interactive "P")
+ (gnus-group-read-group all t))
+
+(defun gnus-group-select-group-all ()
+ "Select the current group and display all articles in it."
+ (interactive)
+ (gnus-group-select-group 'all))
+
+;; Enter a group that is not in the group buffer. Non-nil is returned
+;; if selection was successful.
+(defun gnus-group-read-ephemeral-group
+ (group method &optional activate quit-config)
+ (let ((group (if (gnus-group-foreign-p group) group
+ (gnus-group-prefixed-name group method))))
+ (gnus-sethash
+ group
+ (list t nil (list group gnus-level-default-subscribed nil nil
+ (append method
+ (list
+ (list 'quit-config
+ (if quit-config quit-config
+ (cons (current-buffer) 'summary)))))))
+ gnus-newsrc-hashtb)
+ (set-buffer gnus-group-buffer)
+ (or (gnus-check-server method)
+ (error "Unable to contact server: %s" (gnus-status-message method)))
+ (if activate (or (gnus-request-group group)
+ (error "Couldn't request group")))
+ (condition-case ()
+ (gnus-group-read-group t t group)
+ (error nil)
+ (quit nil))
+ (not (equal major-mode 'gnus-group-mode))))
+
+(defun gnus-group-jump-to-group (group)
+ "Jump to newsgroup GROUP."
+ (interactive
+ (list (completing-read
+ "Group: " gnus-active-hashtb nil
+ (memq gnus-select-method gnus-have-read-active-file))))
+
+ (if (equal group "")
+ (error "Empty group name"))
+
+ (let ((b (text-property-any
+ (point-min) (point-max) 'gnus-group (intern group))))
+ (if b
+ ;; Either go to the line in the group buffer...
+ (goto-char b)
+ ;; ... or insert the line.
+ (or
+ (gnus-gethash group gnus-active-hashtb)
+ (gnus-activate-group group)
+ (error "%s error: %s" group (gnus-status-message group)))
+
+ (gnus-group-update-group group)
+ (goto-char (text-property-any
+ (point-min) (point-max) 'gnus-group (intern group)))))
+ ;; Adjust cursor point.
+ (gnus-group-position-cursor))
+
+(defun gnus-group-goto-group (group)
+ "Goto to newsgroup GROUP."
+ (let ((b (text-property-any (point-min) (point-max)
+ 'gnus-group (intern group))))
+ (and b (goto-char b))))
+
+(defun gnus-group-next-group (n)
+ "Go to next N'th newsgroup.
+If N is negative, search backward instead.
+Returns the difference between N and the number of skips actually
+done."
+ (interactive "p")
+ (gnus-group-next-unread-group n t))
+
+(defun gnus-group-next-unread-group (n &optional all level)
+ "Go to next N'th unread newsgroup.
+If N is negative, search backward instead.
+If ALL is non-nil, choose any newsgroup, unread or not.
+If LEVEL is non-nil, choose the next group with level LEVEL, or, if no
+such group can be found, the next group with a level higher than
+LEVEL.
+Returns the difference between N and the number of skips actually
+made."
+ (interactive "p")
+ (let ((backward (< n 0))
+ (n (abs n)))
+ (while (and (> n 0)
+ (gnus-group-search-forward
+ backward (or (not gnus-group-goto-unread) all) level))
+ (setq n (1- n)))
+ (if (/= 0 n) (gnus-message 7 "No more%s newsgroups%s" (if all "" " unread")
+ (if level " on this level or higher" "")))
+ n))
+
+(defun gnus-group-prev-group (n)
+ "Go to previous N'th newsgroup.
+Returns the difference between N and the number of skips actually
+done."
+ (interactive "p")
+ (gnus-group-next-unread-group (- n) t))
+
+(defun gnus-group-prev-unread-group (n)
+ "Go to previous N'th unread newsgroup.
+Returns the difference between N and the number of skips actually
+done."
+ (interactive "p")
+ (gnus-group-next-unread-group (- n)))
+
+(defun gnus-group-next-unread-group-same-level (n)
+ "Go to next N'th unread newsgroup on the same level.
+If N is negative, search backward instead.
+Returns the difference between N and the number of skips actually
+done."
+ (interactive "p")
+ (gnus-group-next-unread-group n t (gnus-group-group-level))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-prev-unread-group-same-level (n)
+ "Go to next N'th unread newsgroup on the same level.
+Returns the difference between N and the number of skips actually
+done."
+ (interactive "p")
+ (gnus-group-next-unread-group (- n) t (gnus-group-group-level))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-best-unread-group (&optional exclude-group)
+ "Go to the group with the highest level.
+If EXCLUDE-GROUP, do not go to that group."
+ (interactive)
+ (goto-char (point-min))
+ (let ((best 100000)
+ unread best-point)
+ (while (setq unread (get-text-property (point) 'gnus-unread))
+ (if (and (numberp unread) (> unread 0))
+ (progn
+ (if (and (< (get-text-property (point) 'gnus-level) best)
+ (or (not exclude-group)
+ (not (equal exclude-group (gnus-group-group-name)))))
+ (progn
+ (setq best (get-text-property (point) 'gnus-level))
+ (setq best-point (point))))))
+ (forward-line 1))
+ (if best-point (goto-char best-point))
+ (gnus-summary-position-cursor)
+ (and best-point (gnus-group-group-name))))
+
+(defun gnus-group-first-unread-group ()
+ "Go to the first group with unread articles."
+ (interactive)
+ (prog1
+ (let ((opoint (point))
+ unread)
+ (goto-char (point-min))
+ (if (or (eq (setq unread (gnus-group-group-unread)) t) ; Not active.
+ (not (zerop unread)) ; Has unread articles.
+ (zerop (gnus-group-next-unread-group 1))) ; Next unread group.
+ (point) ; Success.
+ (goto-char opoint)
+ nil)) ; Not success.
+ (gnus-group-position-cursor)))
+
+(defun gnus-group-enter-server-mode ()
+ "Jump to the server buffer."
+ (interactive)
+ (gnus-server-setup-buffer)
+ (gnus-configure-windows 'server)
+ (gnus-server-prepare))
+
+(defun gnus-group-make-group (name &optional method address)
+ "Add a new newsgroup.
+The user will be prompted for a NAME, for a select METHOD, and an
+ADDRESS."
+ (interactive
+ (cons
+ (read-string "Group name: ")
+ (let ((method
+ (completing-read
+ "Method: " (append gnus-valid-select-methods gnus-server-alist)
+ nil t)))
+ (if (assoc method gnus-valid-select-methods)
+ (list method
+ (if (memq 'prompt-address
+ (assoc method gnus-valid-select-methods))
+ (read-string "Address: ")
+ ""))
+ (list method nil)))))
+
+ (let* ((meth (and method (if address (list (intern method) address) method)))
+ (nname (if method (gnus-group-prefixed-name name meth) name))
+ info)
+ (and (gnus-gethash nname gnus-newsrc-hashtb)
+ (error "Group %s already exists" nname))
+ (gnus-group-change-level
+ (setq info (list t nname gnus-level-default-subscribed nil nil meth))
+ gnus-level-default-subscribed gnus-level-killed
+ (and (gnus-group-group-name)
+ (gnus-gethash (gnus-group-group-name)
+ gnus-newsrc-hashtb))
+ t)
+ (gnus-sethash nname (cons 1 0) gnus-active-hashtb)
+ (or (gnus-ephemeral-group-p name)
+ (gnus-dribble-enter
+ (concat "(gnus-group-set-info '" (prin1-to-string (cdr info)) ")")))
+ (gnus-group-insert-group-line-info nname)
+
+ (if (assoc method gnus-valid-select-methods)
+ (require (intern method)))
+ (and (gnus-check-backend-function 'request-create-group nname)
+ (gnus-request-create-group nname))))
+
+(defun gnus-group-edit-group (group &optional part)
+ "Edit the group on the current line."
+ (interactive (list (gnus-group-group-name)))
+ (let ((done-func '(lambda ()
+ "Exit editing mode and update the information."
+ (interactive)
+ (gnus-group-edit-group-done 'part 'group)))
+ (part (or part 'info))
+ (winconf (current-window-configuration))
+ info)
+ (or group (error "No group on current line"))
+ (or (setq info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
+ (error "Killed group; can't be edited"))
+ (set-buffer (get-buffer-create gnus-group-edit-buffer))
+ (gnus-configure-windows 'edit-group)
+ (gnus-add-current-to-buffer-list)
+ (emacs-lisp-mode)
+ ;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
+ (use-local-map (copy-keymap emacs-lisp-mode-map))
+ (local-set-key "\C-c\C-c" done-func)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf)
+ ;; We modify the func to let it know what part it is editing.
+ (setcar (cdr (nth 4 done-func)) (list 'quote part))
+ (setcar (cdr (cdr (nth 4 done-func))) group)
+ (erase-buffer)
+ (insert
+ (cond
+ ((eq part 'method)
+ ";; Type `C-c C-c' after editing the select method.\n\n")
+ ((eq part 'params)
+ ";; Type `C-c C-c' after editing the group parameters.\n\n")
+ ((eq part 'info)
+ ";; Type `C-c C-c' after editing the group info.\n\n")))
+ (let ((cinfo (gnus-copy-sequence info))
+ marked)
+ (if (not (setq marked (nth 3 cinfo)))
+ ()
+ (while marked
+ (or (eq 'score (car (car marked)))
+ (eq 'bookmark (car (car marked)))
+ (eq 'killed (car (car marked)))
+ (not (numberp (car (cdr (car marked)))))
+ (setcdr (car marked)
+ (gnus-compress-sequence (sort (cdr (car marked)) '<) t)))
+ (setq marked (cdr marked))))
+ (insert
+ (pp-to-string
+ (cond ((eq part 'method)
+ (or (nth 4 info) "native"))
+ ((eq part 'params)
+ (nth 5 info))
+ (t
+ cinfo)))
+ "\n"))))
+
+(defun gnus-group-edit-group-method (group)
+ "Edit the select method of GROUP."
+ (interactive (list (gnus-group-group-name)))
+ (gnus-group-edit-group group 'method))
+
+(defun gnus-group-edit-group-parameters (group)
+ "Edit the group parameters of GROUP."
+ (interactive (list (gnus-group-group-name)))
+ (gnus-group-edit-group group 'params))
+
+(defun gnus-group-edit-group-done (part group)
+ "Get info from buffer, update variables and jump to the group buffer."
+ (set-buffer (get-buffer-create gnus-group-edit-buffer))
+ (goto-char (point-min))
+ (let ((form (read (current-buffer)))
+ (winconf gnus-prev-winconf))
+ (if (eq part 'info)
+ (gnus-group-set-info form)
+ (gnus-group-set-info form group part))
+ (kill-buffer (current-buffer))
+ (and winconf (set-window-configuration winconf))
+ (set-buffer gnus-group-buffer)
+ (gnus-group-update-group (gnus-group-group-name))
+ (gnus-group-position-cursor)))
+
+(defun gnus-group-make-help-group ()
+ "Create the Gnus documentation group."
+ (interactive)
+ (let ((path (cons (concat installation-directory "etc/") load-path))
+ (name (gnus-group-prefixed-name "gnus-help" '(nndoc "gnus-help")))
+ file)
+ (and (gnus-gethash name gnus-newsrc-hashtb)
+ (error "Documentation group already exists"))
+ (while (and path
+ (not (file-exists-p
+ (setq file (concat (file-name-as-directory (car path))
+ "gnus-tut.txt")))))
+ (setq path (cdr path)))
+ (if (not path)
+ (message "Couldn't find doc group")
+ (gnus-group-make-group
+ (gnus-group-real-name name)
+ (list 'nndoc name
+ (list 'nndoc-address file)
+ (list 'nndoc-article-type 'mbox)))))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-make-doc-group (file type)
+ "Create a group that uses a single file as the source."
+ (interactive
+ (list (read-file-name "File name: ")
+ (let ((err "")
+ found char)
+ (while (not found)
+ (message "%sFile type (mbox, babyl, digest) [mbd]: " err)
+ (setq found (cond ((= (setq char (read-char)) ?m) 'mbox)
+ ((= char ?b) 'babyl)
+ ((= char ?d) 'digest)
+ (t (setq err (format "%c unknown. " char))
+ nil))))
+ found)))
+ (let* ((file (expand-file-name file))
+ (name (gnus-generate-new-group-name
+ (gnus-group-prefixed-name
+ (file-name-nondirectory file) '(nndoc "")))))
+ (gnus-group-make-group
+ (gnus-group-real-name name)
+ (list 'nndoc name
+ (list 'nndoc-address file)
+ (list 'nndoc-article-type type)))))
+
+(defun gnus-group-make-archive-group (&optional all)
+ "Create the (ding) Gnus archive group of the most recent articles.
+Given a prefix, create a full group."
+ (interactive "P")
+ (let ((group (gnus-group-prefixed-name
+ (if all "ding.archives" "ding.recent") '(nndir ""))))
+ (and (gnus-gethash group gnus-newsrc-hashtb)
+ (error "Archive group already exists"))
+ (gnus-group-make-group
+ (gnus-group-real-name group)
+ "nndir"
+ (if all gnus-group-archive-directory
+ gnus-group-recent-archive-directory)))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-make-directory-group (dir)
+ "Create an nndir group.
+The user will be prompted for a directory. The contents of this
+directory will be used as a newsgroup. The directory should contain
+mail messages or news articles in files that have numeric names."
+ (interactive
+ (list (read-file-name "Create group from directory: ")))
+ (or (file-exists-p dir) (error "No such directory"))
+ (or (file-directory-p dir) (error "Not a directory"))
+ (gnus-group-make-group dir "nndir" dir)
+ (gnus-group-position-cursor))
+
+(defun gnus-group-make-kiboze-group (group address scores)
+ "Create an nnkiboze group.
+The user will be prompted for a name, a regexp to match groups, and
+score file entries for articles to include in the group."
+ (interactive
+ (list
+ (read-string "nnkiboze group name: ")
+ (read-string "Source groups (regexp): ")
+ (let ((headers (mapcar (lambda (group) (list group))
+ '("subject" "from" "number" "date" "message-id"
+ "references" "chars" "lines" "xref")))
+ scores header regexp regexps)
+ (while (not (equal "" (setq header (completing-read
+ "Match on header: " headers nil t))))
+ (setq regexps nil)
+ (while (not (equal "" (setq regexp (read-string
+ (format "Match on %s (string): "
+ header)))))
+ (setq regexps (cons (list regexp nil nil 'r) regexps)))
+ (setq scores (cons (cons header regexps) scores)))
+ scores)))
+ (gnus-group-make-group group "nnkiboze" address)
+ (save-excursion
+ (gnus-set-work-buffer)
+ (let (emacs-lisp-mode-hook)
+ (pp scores (current-buffer)))
+ (write-region (point-min) (point-max)
+ (concat (or gnus-kill-files-directory "~/News")
+ "nnkiboze:" group "." gnus-score-file-suffix)))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-add-to-virtual (n vgroup)
+ "Add the current group to a virtual group."
+ (interactive
+ (list current-prefix-arg
+ (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t
+ "nnvirtual:")))
+ (or (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual)
+ (error "%s is not an nnvirtual group" vgroup))
+ (let* ((groups (gnus-group-process-prefix n))
+ (method (nth 4 (nth 2 (gnus-gethash vgroup gnus-newsrc-hashtb)))))
+ (setcar (cdr method)
+ (concat
+ (nth 1 method) "\\|"
+ (mapconcat
+ (lambda (s)
+ (gnus-group-remove-mark s)
+ (concat "\\(^" (regexp-quote s) "$\\)"))
+ groups "\\|"))))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-make-empty-virtual (group)
+ "Create a new, fresh, empty virtual group."
+ (interactive "sCreate new, empty virtual group: ")
+ (let* ((method (list 'nnvirtual "^$"))
+ (pgroup (gnus-group-prefixed-name group method)))
+ ;; Check whether it exists already.
+ (and (gnus-gethash pgroup gnus-newsrc-hashtb)
+ (error "Group %s already exists." pgroup))
+ ;; Subscribe the new group after the group on the current line.
+ (gnus-subscribe-group pgroup (gnus-group-group-name) method)
+ (gnus-group-update-group pgroup)
+ (forward-line -1)
+ (gnus-group-position-cursor)))
+
+(defun gnus-group-enter-directory (dir)
+ "Enter an ephemeral nneething group."
+ (interactive "DDirectory to read: ")
+ (let* ((method (list 'nneething dir))
+ (leaf (gnus-group-prefixed-name
+ (file-name-nondirectory (directory-file-name dir))
+ method))
+ (name (gnus-generate-new-group-name leaf)))
+ (let ((nneething-read-only t))
+ (or (gnus-group-read-ephemeral-group
+ name method t
+ (cons (current-buffer) (if (eq major-mode 'gnus-summary-mode)
+ 'summary 'group)))
+ (error "Couldn't enter %s" dir)))))
+
+;; Group sorting commands
+;; Suggested by Joe Hildebrand <hildjj@idaho.fuentez.com>.
+
+(defun gnus-group-sort-groups ()
+ "Sort the group buffer using `gnus-group-sort-function'."
+ (interactive)
+ (setq gnus-newsrc-alist
+ (sort (cdr gnus-newsrc-alist) gnus-group-sort-function))
+ (gnus-make-hashtable-from-newsrc-alist)
+ (gnus-group-list-groups))
+
+(defun gnus-group-sort-by-alphabet (info1 info2)
+ (string< (car info1) (car info2)))
+
+(defun gnus-group-sort-by-unread (info1 info2)
+ (let ((n1 (car (gnus-gethash (car info1) gnus-newsrc-hashtb)))
+ (n2 (car (gnus-gethash (car info2) gnus-newsrc-hashtb))))
+ (< (or (and (numberp n1) n1) 0)
+ (or (and (numberp n2) n2) 0))))
+
+(defun gnus-group-sort-by-level (info1 info2)
+ (< (nth 1 info1) (nth 1 info2)))
+
+;; Group catching up.
+
+(defun gnus-group-catchup-current (&optional n all)
+ "Mark all articles not marked as unread in current newsgroup as read.
+If prefix argument N is numeric, the ARG next newsgroups will be
+caught up. If ALL is non-nil, marked articles will also be marked as
+read. Cross references (Xref: header) of articles are ignored.
+The difference between N and actual number of newsgroups that were
+caught up is returned."
+ (interactive "P")
+ (if (not (or (not gnus-interactive-catchup) ;Without confirmation?
+ gnus-expert-user
+ (gnus-y-or-n-p
+ (if all
+ "Do you really want to mark all articles as read? "
+ "Mark all unread articles as read? "))))
+ n
+ (let ((groups (gnus-group-process-prefix n))
+ (ret 0))
+ (while groups
+ ;; Virtual groups have to be given special treatment.
+ (let ((method (gnus-find-method-for-group (car groups))))
+ (if (eq 'nnvirtual (car method))
+ (nnvirtual-catchup-group
+ (gnus-group-real-name (car groups)) (nth 1 method) all)))
+ (gnus-group-remove-mark (car groups))
+ (if (prog1
+ (gnus-group-goto-group (car groups))
+ (gnus-group-catchup (car groups) all))
+ (gnus-group-update-group-line)
+ (setq ret (1+ ret)))
+ (setq groups (cdr groups)))
+ (gnus-group-next-unread-group 1)
+ ret)))
+
+(defun gnus-group-catchup-current-all (&optional n)
+ "Mark all articles in current newsgroup as read.
+Cross references (Xref: header) of articles are ignored."
+ (interactive "P")
+ (gnus-group-catchup-current n 'all))
+
+(defun gnus-group-catchup (group &optional all)
+ "Mark all articles in GROUP as read.
+If ALL is non-nil, all articles are marked as read.
+The return value is the number of articles that were marked as read,
+or nil if no action could be taken."
+ (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
+ (num (car entry))
+ (marked (nth 3 (nth 2 entry))))
+ (if (not (numberp (car entry)))
+ (gnus-message 1 "Can't catch up; non-active group")
+ ;; Do the updating only if the newsgroup isn't killed.
+ (if (not entry)
+ ()
+ (gnus-update-read-articles
+ group (and (not all) (append (cdr (assq 'tick marked))
+ (cdr (assq 'dormant marked))))
+ nil (and (not all) (cdr (assq 'tick marked))))
+ (and all
+ (setq marked (nth 3 (nth 2 entry)))
+ (setcar (nthcdr 3 (nth 2 entry))
+ (delq (assq 'dormant marked)
+ (nth 3 (nth 2 entry)))))))
+ num))
+
+(defun gnus-group-expire-articles (&optional n)
+ "Expire all expirable articles in the current newsgroup."
+ (interactive "P")
+ (let ((groups (gnus-group-process-prefix n))
+ group)
+ (or groups (error "No groups to expire"))
+ (while groups
+ (setq group (car groups)
+ groups (cdr groups))
+ (gnus-group-remove-mark group)
+ (if (not (gnus-check-backend-function 'request-expire-articles group))
+ ()
+ (let* ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
+ (expirable (if (memq 'total-expire (nth 5 info))
+ (cons nil (gnus-list-of-read-articles group))
+ (assq 'expire (nth 3 info)))))
+ (and expirable
+ (setcdr expirable
+ (gnus-request-expire-articles
+ (cdr expirable) group))))))))
+
+(defun gnus-group-expire-all-groups ()
+ "Expire all expirable articles in all newsgroups."
+ (interactive)
+ (save-excursion
+ (gnus-message 5 "Expiring...")
+ (let ((gnus-group-marked (mapcar (lambda (info) (car info))
+ (cdr gnus-newsrc-alist))))
+ (gnus-group-expire-articles nil)))
+ (gnus-group-position-cursor)
+ (gnus-message 5 "Expiring...done"))
+
+(defun gnus-group-set-current-level (n level)
+ "Set the level of the next N groups to LEVEL."
+ (interactive "P\nnLevel: ")
+ (or (and (>= level 1) (<= level gnus-level-killed))
+ (error "Illegal level: %d" level))
+ (let ((groups (gnus-group-process-prefix n))
+ group)
+ (while groups
+ (setq group (car groups)
+ groups (cdr groups))
+ (gnus-group-remove-mark group)
+ (gnus-message 6 "Changed level of %s from %d to %d"
+ group (gnus-group-group-level) level)
+ (gnus-group-change-level group level
+ (gnus-group-group-level))
+ (gnus-group-update-group-line)))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-unsubscribe-current-group (&optional n)
+ "Toggle subscription of the current group.
+If given numerical prefix, toggle the N next groups."
+ (interactive "P")
+ (let ((groups (gnus-group-process-prefix n))
+ group)
+ (while groups
+ (setq group (car groups)
+ groups (cdr groups))
+ (gnus-group-remove-mark group)
+ (gnus-group-unsubscribe-group
+ group (if (<= (gnus-group-group-level) gnus-level-subscribed)
+ gnus-level-default-unsubscribed
+ gnus-level-default-subscribed))
+ (gnus-group-update-group-line))
+ (gnus-group-next-group 1)))
+
+(defun gnus-group-unsubscribe-group (group &optional level)
+ "Toggle subscribe from/to unsubscribe GROUP.
+New newsgroup is added to .newsrc automatically."
+ (interactive
+ (list (completing-read
+ "Group: " gnus-active-hashtb nil
+ (memq gnus-select-method gnus-have-read-active-file))))
+ (let ((newsrc (gnus-gethash group gnus-newsrc-hashtb)))
+ (cond
+ ((string-match "^[ \t]$" group)
+ (error "Empty group name"))
+ (newsrc
+ ;; Toggle subscription flag.
+ (gnus-group-change-level
+ newsrc (if level level (if (<= (nth 1 (nth 2 newsrc))
+ gnus-level-subscribed)
+ (1+ gnus-level-subscribed)
+ gnus-level-default-subscribed)))
+ (gnus-group-update-group group))
+ ((and (stringp group)
+ (or (not (memq gnus-select-method gnus-have-read-active-file))
+ (gnus-gethash group gnus-active-hashtb)))
+ ;; Add new newsgroup.
+ (gnus-group-change-level
+ group
+ (if level level gnus-level-default-subscribed)
+ (or (and (member group gnus-zombie-list)
+ gnus-level-zombie)
+ gnus-level-killed)
+ (and (gnus-group-group-name)
+ (gnus-gethash (gnus-group-group-name) gnus-newsrc-hashtb)))
+ (gnus-group-update-group group))
+ (t (error "No such newsgroup: %s" group)))
+ (gnus-group-position-cursor)))
+
+(defun gnus-group-transpose-groups (n)
+ "Move the current newsgroup up N places.
+If given a negative prefix, move down instead. The difference between
+N and the number of steps taken is returned."
+ (interactive "p")
+ (or (gnus-group-group-name)
+ (error "No group on current line"))
+ (gnus-group-kill-group 1)
+ (prog1
+ (forward-line (- n))
+ (gnus-group-yank-group)
+ (gnus-group-position-cursor)))
+
+(defun gnus-group-kill-all-zombies ()
+ "Kill all zombie newsgroups."
+ (interactive)
+ (setq gnus-killed-list (nconc gnus-zombie-list gnus-killed-list))
+ (setq gnus-zombie-list nil)
+ (gnus-group-list-groups))
+
+(defun gnus-group-kill-region (begin end)
+ "Kill newsgroups in current region (excluding current point).
+The killed newsgroups can be yanked by using \\[gnus-group-yank-group]."
+ (interactive "r")
+ (let ((lines
+ ;; Count lines.
+ (save-excursion
+ (count-lines
+ (progn
+ (goto-char begin)
+ (beginning-of-line)
+ (point))
+ (progn
+ (goto-char end)
+ (beginning-of-line)
+ (point))))))
+ (goto-char begin)
+ (beginning-of-line) ;Important when LINES < 1
+ (gnus-group-kill-group lines)))
+
+(defun gnus-group-kill-group (&optional n)
+ "The the next N groups.
+The killed newsgroups can be yanked by using \\[gnus-group-yank-group].
+However, only groups that were alive can be yanked; already killed
+groups or zombie groups can't be yanked.
+The return value is the name of the (last) group that was killed."
+ (interactive "P")
+ (let ((buffer-read-only nil)
+ (groups (gnus-group-process-prefix n))
+ group entry level)
+ (while groups
+ (setq group (car groups)
+ groups (cdr groups))
+ (gnus-group-remove-mark group)
+ (setq level (gnus-group-group-level))
+ (gnus-delete-line)
+ (if (setq entry (gnus-gethash group gnus-newsrc-hashtb))
+ (setq gnus-list-of-killed-groups
+ (cons (cons (car entry) (nth 2 entry))
+ gnus-list-of-killed-groups)))
+ (gnus-group-change-level
+ (if entry entry group) gnus-level-killed (if entry nil level)))
+ (gnus-group-position-cursor)
+ group))
+
+(defun gnus-group-yank-group (&optional arg)
+ "Yank the last newsgroups killed with \\[gnus-group-kill-group],
+inserting it before the current newsgroup. The numeric ARG specifies
+how many newsgroups are to be yanked. The name of the (last)
+newsgroup yanked is returned."
+ (interactive "p")
+ (if (not arg) (setq arg 1))
+ (let (info group prev)
+ (while (>= (setq arg (1- arg)) 0)
+ (if (not (setq info (car gnus-list-of-killed-groups)))
+ (error "No more newsgroups to yank"))
+ (setq group (nth 2 info))
+ ;; Find which newsgroup to insert this one before - search
+ ;; backward until something suitable is found. If there are no
+ ;; other newsgroups in this buffer, just make this newsgroup the
+ ;; first newsgroup.
+ (setq prev (gnus-group-group-name))
+ (gnus-group-change-level
+ info (nth 2 info) gnus-level-killed
+ (and prev (gnus-gethash prev gnus-newsrc-hashtb))
+ t)
+ (gnus-group-insert-group-line-info (nth 1 info))
+ (setq gnus-list-of-killed-groups
+ (cdr gnus-list-of-killed-groups)))
+ (forward-line -1)
+ (gnus-group-position-cursor)
+ group))
+
+(defun gnus-group-list-all-groups (&optional arg)
+ "List all newsgroups with level ARG or lower.
+Default is gnus-level-unsubscribed, which lists all subscribed and most
+unsubscribed groups."
+ (interactive "P")
+ (gnus-group-list-groups (or arg gnus-level-unsubscribed) t))
+
+(defun gnus-group-list-killed ()
+ "List all killed newsgroups in the group buffer."
+ (interactive)
+ (if (not gnus-killed-list)
+ (gnus-message 6 "No killed groups")
+ (let (gnus-group-list-mode)
+ (funcall gnus-group-prepare-function
+ gnus-level-killed t gnus-level-killed))
+ (goto-char (point-min)))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-list-zombies ()
+ "List all zombie newsgroups in the group buffer."
+ (interactive)
+ (if (not gnus-zombie-list)
+ (gnus-message 6 "No zombie groups")
+ (let (gnus-group-list-mode)
+ (funcall gnus-group-prepare-function
+ gnus-level-zombie t gnus-level-zombie))
+ (goto-char (point-min)))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-get-new-news (&optional arg)
+ "Get newly arrived articles.
+If ARG is non-nil, it should be a number between one and nine to
+specify which levels you are interested in re-scanning."
+ (interactive "P")
+ (run-hooks 'gnus-get-new-news-hook)
+ (setq arg (gnus-group-default-level arg t))
+ (if (and gnus-read-active-file (not arg))
+ (progn
+ (gnus-read-active-file)
+ (gnus-get-unread-articles (or arg (1+ gnus-level-subscribed))))
+ (let ((gnus-read-active-file (if arg nil gnus-read-active-file)))
+ (gnus-get-unread-articles (or arg (1+ gnus-level-subscribed)))))
+ (gnus-group-list-groups))
+
+(defun gnus-group-get-new-news-this-group (&optional n)
+ "Check for newly arrived news in the current group (and the N-1 next groups).
+The difference between N and the number of newsgroup checked is returned.
+If N is negative, this group and the N-1 previous groups will be checked."
+ (interactive "P")
+ (let* ((groups (gnus-group-process-prefix n))
+ (ret (if (numberp n) (- n (length groups)) 0))
+ group)
+ (while groups
+ (setq group (car groups)
+ groups (cdr groups))
+ (gnus-group-remove-mark group)
+ (or (gnus-get-new-news-in-group group)
+ (progn
+ (ding)
+ (message "%s error: %s" group (gnus-status-message group))
+ (sit-for 2))))
+ (gnus-group-next-unread-group 1 t)
+ (gnus-summary-position-cursor)
+ ret))
+
+(defun gnus-get-new-news-in-group (group)
+ (and group
+ (gnus-activate-group group)
+ (progn
+ (gnus-get-unread-articles-in-group
+ (nth 2 (gnus-gethash group gnus-newsrc-hashtb))
+ (gnus-gethash group gnus-active-hashtb))
+ (gnus-group-update-group-line)
+ t)))
+
+(defun gnus-group-fetch-faq (group)
+ "Fetch the FAQ for the current group."
+ (interactive (list (gnus-group-real-name (gnus-group-group-name))))
+ (or group (error "No group name given"))
+ (let ((file (concat gnus-group-faq-directory (gnus-group-real-name group))))
+ (if (not (file-exists-p file))
+ (error "No such file: %s" file)
+ (find-file file))))
+
+(defun gnus-group-describe-group (force &optional group)
+ "Display a description of the current newsgroup."
+ (interactive (list current-prefix-arg (gnus-group-group-name)))
+ (and force (setq gnus-description-hashtb nil))
+ (let ((method (gnus-find-method-for-group group))
+ desc)
+ (or group (error "No group name given"))
+ (and (or (and gnus-description-hashtb
+ ;; We check whether this group's method has been
+ ;; queried for a description file.
+ (gnus-gethash
+ (gnus-group-prefixed-name "" method)
+ gnus-description-hashtb))
+ (setq desc (gnus-group-get-description group))
+ (gnus-read-descriptions-file method))
+ (message
+ (or desc (gnus-gethash group gnus-description-hashtb)
+ "No description available")))))
+
+;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defun gnus-group-describe-all-groups (&optional force)
+ "Pop up a buffer with descriptions of all newsgroups."
+ (interactive "P")
+ (and force (setq gnus-description-hashtb nil))
+ (if (not (or gnus-description-hashtb
+ (gnus-read-all-descriptions-files)))
+ (error "Couldn't request descriptions file"))
+ (let ((buffer-read-only nil)
+ b)
+ (erase-buffer)
+ (mapatoms
+ (lambda (group)
+ (setq b (point))
+ (insert (format " *: %-20s %s\n" (symbol-name group)
+ (symbol-value group)))
+ (add-text-properties
+ b (1+ b) (list 'gnus-group group
+ 'gnus-unread t 'gnus-marked nil
+ 'gnus-level (1+ gnus-level-subscribed))))
+ gnus-description-hashtb)
+ (goto-char (point-min))
+ (gnus-group-position-cursor)))
+
+;; Suggested by by Daniel Quinlan <quinlan@best.com>.
+(defun gnus-group-apropos (regexp &optional search-description)
+ "List all newsgroups that have names that match a regexp."
+ (interactive "sGnus apropos (regexp): ")
+ (let ((prev "")
+ (obuf (current-buffer))
+ groups des)
+ ;; Go through all newsgroups that are known to Gnus.
+ (mapatoms
+ (lambda (group)
+ (and (symbol-name group)
+ (string-match regexp (symbol-name group))
+ (setq groups (cons (symbol-name group) groups))))
+ gnus-active-hashtb)
+ ;; Go through all descriptions that are known to Gnus.
+ (if search-description
+ (mapatoms
+ (lambda (group)
+ (and (string-match regexp (symbol-value group))
+ (gnus-gethash (symbol-name group) gnus-active-hashtb)
+ (setq groups (cons (symbol-name group) groups))))
+ gnus-description-hashtb))
+ (if (not groups)
+ (gnus-message 3 "No groups matched \"%s\"." regexp)
+ ;; Print out all the groups.
+ (save-excursion
+ (pop-to-buffer "*Gnus Help*")
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (setq groups (sort groups 'string<))
+ (while groups
+ ;; Groups may be entered twice into the list of groups.
+ (if (not (string= (car groups) prev))
+ (progn
+ (insert (setq prev (car groups)) "\n")
+ (if (and gnus-description-hashtb
+ (setq des (gnus-gethash (car groups)
+ gnus-description-hashtb)))
+ (insert " " des "\n"))))
+ (setq groups (cdr groups)))
+ (goto-char (point-min))))
+ (pop-to-buffer obuf)))
+
+(defun gnus-group-description-apropos (regexp)
+ "List all newsgroups that have names or descriptions that match a regexp."
+ (interactive "sGnus description apropos (regexp): ")
+ (if (not (or gnus-description-hashtb
+ (gnus-read-all-descriptions-files)))
+ (error "Couldn't request descriptions file"))
+ (gnus-group-apropos regexp t))
+
+;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defun gnus-group-list-matching (level regexp &optional all lowest)
+ "List all groups with unread articles that match REGEXP.
+If the prefix LEVEL is non-nil, it should be a number that says which
+level to cut off listing groups.
+If ALL, also list groups with no unread articles.
+If LOWEST, don't list groups with level lower than LOWEST."
+ (interactive "P\nsList newsgroups matching: ")
+ (gnus-group-prepare-flat (or level gnus-level-subscribed)
+ all (or lowest 1) regexp)
+ (goto-char (point-min))
+ (gnus-group-position-cursor))
+
+(defun gnus-group-list-all-matching (level regexp &optional lowest)
+ "List all groups that match REGEXP.
+If the prefix LEVEL is non-nil, it should be a number that says which
+level to cut off listing groups.
+If LOWEST, don't list groups with level lower than LOWEST."
+ (interactive "P\nsList newsgroups matching: ")
+ (gnus-group-list-matching (or level gnus-level-killed) regexp t lowest))
+
+;; Suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>.
+(defun gnus-group-save-newsrc ()
+ "Save the Gnus startup files."
+ (interactive)
+ (gnus-save-newsrc-file))
+
+(defun gnus-group-restart (&optional arg)
+ "Force Gnus to read the .newsrc file."
+ (interactive "P")
+ (gnus-save-newsrc-file)
+ (gnus-setup-news 'force)
+ (gnus-group-list-groups arg))
+
+(defun gnus-group-read-init-file ()
+ "Read the Gnus elisp init file."
+ (interactive)
+ (gnus-read-init-file))
+
+(defun gnus-group-check-bogus-groups (&optional silent)
+ "Check bogus newsgroups.
+If given a prefix, don't ask for confirmation before removing a bogus
+group."
+ (interactive "P")
+ (gnus-check-bogus-newsgroups (and (not silent) (not gnus-expert-user)))
+ (gnus-group-list-groups))
+
+(defun gnus-group-edit-global-kill (&optional article group)
+ "Edit the global kill file.
+If GROUP, edit that local kill file instead."
+ (interactive "P")
+ (setq gnus-current-kill-article article)
+ (gnus-kill-file-edit-file group)
+ (gnus-message
+ 6
+ (substitute-command-keys
+ "Editing a global kill file (Type \\[gnus-kill-file-exit] to exit)")))
+
+(defun gnus-group-edit-local-kill (article group)
+ "Edit a local kill file."
+ (interactive (list nil (gnus-group-group-name)))
+ (gnus-group-edit-global-kill article group))
+
+(defun gnus-group-force-update ()
+ "Update `.newsrc' file."
+ (interactive)
+ (gnus-save-newsrc-file))
+
+(defun gnus-group-suspend ()
+ "Suspend the current Gnus session.
+In fact, cleanup buffers except for group mode buffer.
+The hook gnus-suspend-gnus-hook is called before actually suspending."
+ (interactive)
+ (run-hooks 'gnus-suspend-gnus-hook)
+ ;; Kill Gnus buffers except for group mode buffer.
+ (let ((group-buf (get-buffer gnus-group-buffer)))
+ ;; Do this on a separate list in case the user does a ^G before we finish
+ (let ((gnus-buffer-list
+ (delq group-buf (delq gnus-dribble-buffer
+ (append gnus-buffer-list nil)))))
+ (while gnus-buffer-list
+ (gnus-kill-buffer (car gnus-buffer-list))
+ (setq gnus-buffer-list (cdr gnus-buffer-list))))
+ (if group-buf
+ (progn
+ (setq gnus-buffer-list (list group-buf))
+ (bury-buffer group-buf)
+ (delete-windows-on group-buf t)))))
+
+(defun gnus-group-clear-dribble ()
+ "Clear all information from the dribble buffer."
+ (interactive)
+ (gnus-dribble-clear))
+
+(defun gnus-group-exit ()
+ "Quit reading news after updating .newsrc.eld and .newsrc.
+The hook `gnus-exit-gnus-hook' is called before actually exiting."
+ (interactive)
+ (if (or noninteractive ;For gnus-batch-kill
+ (not (gnus-server-opened gnus-select-method)) ;NNTP connection closed
+ (not gnus-interactive-exit) ;Without confirmation
+ gnus-expert-user
+ (gnus-y-or-n-p "Are you sure you want to quit reading news? "))
+ (progn
+ (run-hooks 'gnus-exit-gnus-hook)
+ ;; Offer to save data from non-quitted summary buffers.
+ (gnus-offer-save-summaries)
+ ;; Save the newsrc file(s).
+ (gnus-save-newsrc-file)
+ ;; Kill-em-all.
+ (gnus-close-backends)
+ ;; Reset everything.
+ (gnus-clear-system))))
+
+(defun gnus-close-backends ()
+ ;; Send a close request to all backends that support such a request.
+ (let ((methods gnus-valid-select-methods)
+ func)
+ (while methods
+ (if (fboundp (setq func (intern (concat (car (car methods))
+ "-request-close"))))
+ (funcall func))
+ (setq methods (cdr methods)))))
+
+(defun gnus-group-quit ()
+ "Quit reading news without updating .newsrc.eld or .newsrc.
+The hook `gnus-exit-gnus-hook' is called before actually exiting."
+ (interactive)
+ (if (or noninteractive ;For gnus-batch-kill
+ (zerop (buffer-size))
+ (not (gnus-server-opened gnus-select-method))
+ gnus-expert-user
+ (not gnus-current-startup-file)
+ (gnus-yes-or-no-p
+ (format "Quit reading news without saving %s? "
+ (file-name-nondirectory gnus-current-startup-file))))
+ (progn
+ (run-hooks 'gnus-exit-gnus-hook)
+ (if gnus-use-full-window
+ (delete-other-windows)
+ (gnus-remove-some-windows))
+ (gnus-dribble-save)
+ (gnus-close-backends)
+ (gnus-clear-system))))
+
+(defun gnus-offer-save-summaries ()
+ (save-excursion
+ (let ((buflist (buffer-list))
+ buffers bufname)
+ (while buflist
+ (and (setq bufname (buffer-name (car buflist)))
+ (string-match "Summary" bufname)
+ (save-excursion
+ (set-buffer bufname)
+ ;; We check that this is, indeed, a summary buffer.
+ (eq major-mode 'gnus-summary-mode))
+ (setq buffers (cons bufname buffers)))
+ (setq buflist (cdr buflist)))
+ (and buffers
+ (map-y-or-n-p
+ "Update summary buffer %s? "
+ (lambda (buf)
+ (set-buffer buf)
+ (gnus-summary-exit))
+ buffers)))))
+
+(defun gnus-group-describe-briefly ()
+ "Give a one line description of the group mode commands."
+ (interactive)
+ (gnus-message 7 (substitute-command-keys "\\<gnus-group-mode-map>\\[gnus-group-read-group]:Select \\[gnus-group-next-unread-group]:Forward \\[gnus-group-prev-unread-group]:Backward \\[gnus-group-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-group-describe-briefly]:This help")))
+
+(defun gnus-group-browse-foreign-server (method)
+ "Browse a foreign news server.
+If called interactively, this function will ask for a select method
+ (nntp, nnspool, etc.) and a server address (eg. nntp.some.where).
+If not, METHOD should be a list where the first element is the method
+and the second element is the address."
+ (interactive
+ (list (let ((how (completing-read
+ "Which backend: "
+ (append gnus-valid-select-methods gnus-server-alist)
+ nil t "nntp")))
+ ;; We either got a backend name or a virtual server name.
+ ;; If the first, we also need an address.
+ (if (assoc how gnus-valid-select-methods)
+ (list (intern how)
+ ;; Suggested by mapjph@bath.ac.uk.
+ (completing-read
+ "Address: "
+ (mapcar (lambda (server) (list server))
+ gnus-secondary-servers)))
+ ;; We got a server name, so we find the method.
+ (gnus-server-to-method how)))))
+ (gnus-browse-foreign-server method))
+
+
+;;;
+;;; Browse Server Mode
+;;;
+
+(defvar gnus-browse-mode-hook nil)
+(defvar gnus-browse-mode-map nil)
+(put 'gnus-browse-mode 'mode-class 'special)
+
+(if gnus-browse-mode-map
+ nil
+ (setq gnus-browse-mode-map (make-keymap))
+ (suppress-keymap gnus-browse-mode-map)
+ (define-key gnus-browse-mode-map " " 'gnus-browse-read-group)
+ (define-key gnus-browse-mode-map "=" 'gnus-browse-select-group)
+ (define-key gnus-browse-mode-map "n" 'gnus-browse-next-group)
+ (define-key gnus-browse-mode-map "p" 'gnus-browse-prev-group)
+ (define-key gnus-browse-mode-map "\177" 'gnus-browse-prev-group)
+ (define-key gnus-browse-mode-map "N" 'gnus-browse-next-group)
+ (define-key gnus-browse-mode-map "P" 'gnus-browse-prev-group)
+ (define-key gnus-browse-mode-map "\M-n" 'gnus-browse-next-group)
+ (define-key gnus-browse-mode-map "\M-p" 'gnus-browse-prev-group)
+ (define-key gnus-browse-mode-map "\r" 'gnus-browse-select-group)
+ (define-key gnus-browse-mode-map "u" 'gnus-browse-unsubscribe-current-group)
+ (define-key gnus-browse-mode-map "l" 'gnus-browse-exit)
+ (define-key gnus-browse-mode-map "L" 'gnus-browse-exit)
+ (define-key gnus-browse-mode-map "q" 'gnus-browse-exit)
+ (define-key gnus-browse-mode-map "Q" 'gnus-browse-exit)
+ (define-key gnus-browse-mode-map "\C-c\C-c" 'gnus-browse-exit)
+ (define-key gnus-browse-mode-map "?" 'gnus-browse-describe-briefly)
+ (define-key gnus-browse-mode-map "\C-c\C-i" 'gnus-info-find-node)
+ )
+
+(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)
+ (setq gnus-browse-current-method method)
+ (setq gnus-browse-return-buffer return-buffer)
+ (let ((gnus-select-method method)
+ groups group)
+ (gnus-message 5 "Connecting to %s..." (nth 1 method))
+ (or (gnus-check-server method)
+ (error "Unable to contact server: %s" (gnus-status-message method)))
+ (or (gnus-request-list method)
+ (error "Couldn't request list: %s" (gnus-status-message method)))
+ (get-buffer-create gnus-browse-buffer)
+ (gnus-add-current-to-buffer-list)
+ (and 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
+ (format
+ "Gnus Browse Server {%s:%s}" (car method) (car (cdr method))))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (let ((cur (current-buffer)))
+ (goto-char (point-min))
+ (or (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))
+ (setq groups (cons (cons (buffer-substring (match-beginning 1)
+ (match-end 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-cursor)))
+
+(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)
+ (if gnus-visual (gnus-browse-make-menu-bar))
+ (setq mode-line-modified "-- ")
+ (make-local-variable 'mode-line-format)
+ (setq mode-line-format (copy-sequence mode-line-format))
+ (and (equal (nth 3 mode-line-format) " ")
+ (setcar (nthcdr 3 mode-line-format) ""))
+ (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)
+ (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-browse-group-name)))
+ (or (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-cursor)))
+
+(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")
+ (and (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)))
+ (setq arg (1- arg)))
+ (gnus-group-position-cursor)
+ (if (/= 0 arg) (gnus-message 7 "No more newsgroups"))
+ arg))
+
+(defun gnus-browse-group-name ()
+ (save-excursion
+ (beginning-of-line)
+ (if (not (re-search-forward ": \\(.*\\)$" (gnus-point-at-eol) t))
+ ()
+ (gnus-group-prefixed-name
+ (buffer-substring (match-beginning 1) (match-end 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.
+ (if (= (following-char) ?K) (setq sub t))
+ (setq group (gnus-browse-group-name))
+ (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)
+ (if (eq major-mode 'gnus-browse-mode)
+ (kill-buffer (current-buffer)))
+ (if gnus-browse-return-buffer
+ (gnus-configure-windows 'server 'force)
+ (gnus-configure-windows 'group 'force)
+ (gnus-group-list-groups nil)))
+
+(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")))
+
+
+;;;
+;;; Gnus summary mode
+;;;
+
+(defvar gnus-summary-mode-map nil)
+(defvar gnus-summary-mark-map nil)
+(defvar gnus-summary-mscore-map nil)
+(defvar gnus-summary-article-map nil)
+(defvar gnus-summary-thread-map nil)
+(defvar gnus-summary-goto-map nil)
+(defvar gnus-summary-exit-map nil)
+(defvar gnus-summary-interest-map nil)
+(defvar gnus-summary-sort-map nil)
+(defvar gnus-summary-backend-map nil)
+(defvar gnus-summary-save-map nil)
+(defvar gnus-summary-wash-map nil)
+(defvar gnus-summary-wash-hide-map nil)
+(defvar gnus-summary-wash-highlight-map nil)
+(defvar gnus-summary-wash-time-map nil)
+(defvar gnus-summary-help-map nil)
+
+(put 'gnus-summary-mode 'mode-class 'special)
+
+(if gnus-summary-mode-map
+ nil
+ (setq gnus-summary-mode-map (make-keymap))
+ (suppress-keymap gnus-summary-mode-map)
+
+ ;; Non-orthogonal keys
+
+ (define-key gnus-summary-mode-map " " 'gnus-summary-next-page)
+ (define-key gnus-summary-mode-map "\177" 'gnus-summary-prev-page)
+ (define-key gnus-summary-mode-map "\r" 'gnus-summary-scroll-up)
+ (define-key gnus-summary-mode-map "n" 'gnus-summary-next-unread-article)
+ (define-key gnus-summary-mode-map "p" 'gnus-summary-prev-unread-article)
+ (define-key gnus-summary-mode-map "N" 'gnus-summary-next-article)
+ (define-key gnus-summary-mode-map "P" 'gnus-summary-prev-article)
+ (define-key gnus-summary-mode-map "\M-\C-n" 'gnus-summary-next-same-subject)
+ (define-key gnus-summary-mode-map "\M-\C-p" 'gnus-summary-prev-same-subject)
+ (define-key gnus-summary-mode-map "\M-n" 'gnus-summary-next-unread-subject)
+ (define-key gnus-summary-mode-map "\M-p" 'gnus-summary-prev-unread-subject)
+ (define-key gnus-summary-mode-map "." 'gnus-summary-first-unread-article)
+ (define-key gnus-summary-mode-map "," 'gnus-summary-best-unread-article)
+ (define-key gnus-summary-mode-map
+ "\M-s" 'gnus-summary-search-article-forward)
+ (define-key gnus-summary-mode-map
+ "\M-r" 'gnus-summary-search-article-backward)
+ (define-key gnus-summary-mode-map "<" 'gnus-summary-beginning-of-article)
+ (define-key gnus-summary-mode-map ">" 'gnus-summary-end-of-article)
+ (define-key gnus-summary-mode-map "j" 'gnus-summary-goto-subject)
+ (define-key gnus-summary-mode-map "^" 'gnus-summary-refer-parent-article)
+ (define-key gnus-summary-mode-map "\M-^" 'gnus-summary-refer-article)
+ (define-key gnus-summary-mode-map "u" 'gnus-summary-tick-article-forward)
+ (define-key gnus-summary-mode-map "!" 'gnus-summary-tick-article-forward)
+ (define-key gnus-summary-mode-map "U" 'gnus-summary-tick-article-backward)
+ (define-key gnus-summary-mode-map "d" 'gnus-summary-mark-as-read-forward)
+ (define-key gnus-summary-mode-map "D" 'gnus-summary-mark-as-read-backward)
+ (define-key gnus-summary-mode-map "E" 'gnus-summary-mark-as-expirable)
+ (define-key gnus-summary-mode-map "\M-u" 'gnus-summary-clear-mark-forward)
+ (define-key gnus-summary-mode-map "\M-U" 'gnus-summary-clear-mark-backward)
+ (define-key gnus-summary-mode-map
+ "k" 'gnus-summary-kill-same-subject-and-select)
+ (define-key gnus-summary-mode-map "\C-k" 'gnus-summary-kill-same-subject)
+ (define-key gnus-summary-mode-map "\M-\C-k" 'gnus-summary-kill-thread)
+ (define-key gnus-summary-mode-map "\M-\C-l" 'gnus-summary-lower-thread)
+ (define-key gnus-summary-mode-map "e" 'gnus-summary-edit-article)
+ (define-key gnus-summary-mode-map "#" 'gnus-summary-mark-as-processable)
+ (define-key gnus-summary-mode-map "\M-#" 'gnus-summary-unmark-as-processable)
+ (define-key gnus-summary-mode-map "\M-\C-t" 'gnus-summary-toggle-threads)
+ (define-key gnus-summary-mode-map "\M-\C-s" 'gnus-summary-show-thread)
+ (define-key gnus-summary-mode-map "\M-\C-h" 'gnus-summary-hide-thread)
+ (define-key gnus-summary-mode-map "\M-\C-f" 'gnus-summary-next-thread)
+ (define-key gnus-summary-mode-map "\M-\C-b" 'gnus-summary-prev-thread)
+ (define-key gnus-summary-mode-map "\M-\C-u" 'gnus-summary-up-thread)
+ (define-key gnus-summary-mode-map "\M-\C-d" 'gnus-summary-down-thread)
+ (define-key gnus-summary-mode-map "&" 'gnus-summary-execute-command)
+ (define-key gnus-summary-mode-map "c" 'gnus-summary-catchup-and-exit)
+ (define-key gnus-summary-mode-map "\C-w" 'gnus-summary-mark-region-as-read)
+ (define-key gnus-summary-mode-map "\C-t" 'gnus-summary-toggle-truncation)
+ (define-key gnus-summary-mode-map "?" 'gnus-summary-mark-as-dormant)
+ (define-key gnus-summary-mode-map
+ "\C-c\M-\C-s" 'gnus-summary-show-all-expunged)
+ (define-key gnus-summary-mode-map
+ "\C-c\C-s\C-n" 'gnus-summary-sort-by-number)
+ (define-key gnus-summary-mode-map
+ "\C-c\C-s\C-a" 'gnus-summary-sort-by-author)
+ (define-key gnus-summary-mode-map
+ "\C-c\C-s\C-s" 'gnus-summary-sort-by-subject)
+ (define-key gnus-summary-mode-map "\C-c\C-s\C-d" 'gnus-summary-sort-by-date)
+ (define-key gnus-summary-mode-map "\C-c\C-s\C-i" 'gnus-summary-sort-by-score)
+ (define-key gnus-summary-mode-map "=" 'gnus-summary-expand-window)
+ (define-key gnus-summary-mode-map
+ "\C-x\C-s" 'gnus-summary-reselect-current-group)
+ (define-key gnus-summary-mode-map "\M-g" 'gnus-summary-rescan-group)
+ (define-key gnus-summary-mode-map "w" 'gnus-summary-stop-page-breaking)
+ (define-key gnus-summary-mode-map "\C-c\C-r" 'gnus-summary-caesar-message)
+ (define-key gnus-summary-mode-map "\M-t" 'gnus-summary-toggle-mime)
+ (define-key gnus-summary-mode-map "f" 'gnus-summary-followup)
+ (define-key gnus-summary-mode-map "F" 'gnus-summary-followup-with-original)
+ (define-key gnus-summary-mode-map "C" 'gnus-summary-cancel-article)
+ (define-key gnus-summary-mode-map "r" 'gnus-summary-reply)
+ (define-key gnus-summary-mode-map "R" 'gnus-summary-reply-with-original)
+ (define-key gnus-summary-mode-map "\C-c\C-f" 'gnus-summary-mail-forward)
+ (define-key gnus-summary-mode-map "o" 'gnus-summary-save-article)
+ (define-key gnus-summary-mode-map "\C-o" 'gnus-summary-save-article-mail)
+ (define-key gnus-summary-mode-map "|" 'gnus-summary-pipe-output)
+ (define-key gnus-summary-mode-map "\M-k" 'gnus-summary-edit-local-kill)
+ (define-key gnus-summary-mode-map "\M-K" 'gnus-summary-edit-global-kill)
+ (define-key gnus-summary-mode-map "V" 'gnus-version)
+ (define-key gnus-summary-mode-map "\C-c\C-d" 'gnus-summary-describe-group)
+ (define-key gnus-summary-mode-map "q" 'gnus-summary-exit)
+ (define-key gnus-summary-mode-map "Q" 'gnus-summary-exit-no-update)
+ (define-key gnus-summary-mode-map "\C-c\C-i" 'gnus-info-find-node)
+ (define-key gnus-summary-mode-map gnus-mouse-2 'gnus-mouse-pick-article)
+ (define-key gnus-summary-mode-map "m" 'gnus-summary-mail-other-window)
+ (define-key gnus-summary-mode-map "a" 'gnus-summary-post-news)
+ (define-key gnus-summary-mode-map
+ "x" 'gnus-summary-remove-lines-marked-as-read)
+; (define-key gnus-summary-mode-map "X" 'gnus-summary-remove-lines-marked-with)
+ (define-key gnus-summary-mode-map "s" 'gnus-summary-isearch-article)
+ (define-key gnus-summary-mode-map "t" 'gnus-summary-toggle-header)
+ (define-key gnus-summary-mode-map "g" 'gnus-summary-show-article)
+; (define-key gnus-summary-mode-map "?" 'gnus-summary-describe-briefly)
+ (define-key gnus-summary-mode-map "l" 'gnus-summary-goto-last-article)
+ (define-key gnus-summary-mode-map "\C-c\C-v\C-v" 'gnus-uu-decode-uu-view)
+ (define-key gnus-summary-mode-map "\C-d" 'gnus-summary-enter-digest-group)
+ (define-key gnus-summary-mode-map "v" 'gnus-summary-verbose-headers)
+ (define-key gnus-summary-mode-map "\C-c\C-b" 'gnus-bug)
+
+
+ ;; Sort of orthogonal keymap
+ (define-prefix-command 'gnus-summary-mark-map)
+ (define-key gnus-summary-mode-map "M" 'gnus-summary-mark-map)
+ (define-key gnus-summary-mark-map "t" 'gnus-summary-tick-article-forward)
+ (define-key gnus-summary-mark-map "!" 'gnus-summary-tick-article-forward)
+ (define-key gnus-summary-mark-map "d" 'gnus-summary-mark-as-read-forward)
+ (define-key gnus-summary-mark-map "r" 'gnus-summary-mark-as-read-forward)
+ (define-key gnus-summary-mark-map "c" 'gnus-summary-clear-mark-forward)
+ (define-key gnus-summary-mark-map " " 'gnus-summary-clear-mark-forward)
+ (define-key gnus-summary-mark-map "e" 'gnus-summary-mark-as-expirable)
+ (define-key gnus-summary-mark-map "x" 'gnus-summary-mark-as-expirable)
+ (define-key gnus-summary-mark-map "?" 'gnus-summary-mark-as-dormant)
+ (define-key gnus-summary-mark-map "b" 'gnus-summary-set-bookmark)
+ (define-key gnus-summary-mark-map "B" 'gnus-summary-remove-bookmark)
+ (define-key gnus-summary-mark-map "#" 'gnus-summary-mark-as-processable)
+ (define-key gnus-summary-mark-map "\M-#" 'gnus-summary-unmark-as-processable)
+ (define-key gnus-summary-mark-map
+ "\M-r" 'gnus-summary-remove-lines-marked-as-read)
+ (define-key gnus-summary-mark-map
+ "\M-\C-r" 'gnus-summary-remove-lines-marked-with)
+ (define-key gnus-summary-mark-map "D" 'gnus-summary-show-all-dormant)
+ (define-key gnus-summary-mark-map "\M-D" 'gnus-summary-hide-all-dormant)
+ (define-key gnus-summary-mark-map "S" 'gnus-summary-show-all-expunged)
+ (define-key gnus-summary-mark-map "C" 'gnus-summary-catchup)
+ (define-key gnus-summary-mark-map "H" 'gnus-summary-catchup-to-here)
+ (define-key gnus-summary-mark-map "\C-c" 'gnus-summary-catchup-all)
+ (define-key gnus-summary-mark-map
+ "k" 'gnus-summary-kill-same-subject-and-select)
+ (define-key gnus-summary-mark-map "K" 'gnus-summary-kill-same-subject)
+
+ (define-prefix-command 'gnus-summary-mscore-map)
+ (define-key gnus-summary-mark-map "V" 'gnus-summary-mscore-map)
+ (define-key gnus-summary-mscore-map "c" 'gnus-summary-clear-above)
+ (define-key gnus-summary-mscore-map "u" 'gnus-summary-tick-above)
+ (define-key gnus-summary-mscore-map "m" 'gnus-summary-mark-above)
+ (define-key gnus-summary-mscore-map "k" 'gnus-summary-kill-below)
+
+ (define-key gnus-summary-mark-map "P" 'gnus-uu-mark-map)
+
+ (define-key gnus-summary-mode-map "S" 'gnus-summary-send-map)
+
+ (define-prefix-command 'gnus-summary-goto-map)
+ (define-key gnus-summary-mode-map "G" 'gnus-summary-goto-map)
+ (define-key gnus-summary-goto-map "n" 'gnus-summary-next-unread-article)
+ (define-key gnus-summary-goto-map "p" 'gnus-summary-prev-unread-article)
+ (define-key gnus-summary-goto-map "N" 'gnus-summary-next-article)
+ (define-key gnus-summary-goto-map "P" 'gnus-summary-prev-article)
+ (define-key gnus-summary-goto-map "\C-n" 'gnus-summary-next-same-subject)
+ (define-key gnus-summary-goto-map "\C-p" 'gnus-summary-prev-same-subject)
+ (define-key gnus-summary-goto-map "\M-n" 'gnus-summary-next-unread-subject)
+ (define-key gnus-summary-goto-map "\M-p" 'gnus-summary-prev-unread-subject)
+ (define-key gnus-summary-goto-map "f" 'gnus-summary-first-unread-article)
+ (define-key gnus-summary-goto-map "b" 'gnus-summary-best-unread-article)
+ (define-key gnus-summary-goto-map "g" 'gnus-summary-goto-subject)
+ (define-key gnus-summary-goto-map "l" 'gnus-summary-goto-last-article)
+ (define-key gnus-summary-goto-map "p" 'gnus-summary-pop-article)
+
+
+ (define-prefix-command 'gnus-summary-thread-map)
+ (define-key gnus-summary-mode-map "T" 'gnus-summary-thread-map)
+ (define-key gnus-summary-thread-map "k" 'gnus-summary-kill-thread)
+ (define-key gnus-summary-thread-map "l" 'gnus-summary-lower-thread)
+ (define-key gnus-summary-thread-map "i" 'gnus-summary-raise-thread)
+ (define-key gnus-summary-thread-map "T" 'gnus-summary-toggle-threads)
+ (define-key gnus-summary-thread-map "s" 'gnus-summary-show-thread)
+ (define-key gnus-summary-thread-map "S" 'gnus-summary-show-all-threads)
+ (define-key gnus-summary-thread-map "h" 'gnus-summary-hide-thread)
+ (define-key gnus-summary-thread-map "H" 'gnus-summary-hide-all-threads)
+ (define-key gnus-summary-thread-map "n" 'gnus-summary-next-thread)
+ (define-key gnus-summary-thread-map "p" 'gnus-summary-prev-thread)
+ (define-key gnus-summary-thread-map "u" 'gnus-summary-up-thread)
+ (define-key gnus-summary-thread-map "d" 'gnus-summary-down-thread)
+ (define-key gnus-summary-thread-map "#" 'gnus-uu-mark-thread)
+
+
+ (define-prefix-command 'gnus-summary-exit-map)
+ (define-key gnus-summary-mode-map "Z" 'gnus-summary-exit-map)
+ (define-key gnus-summary-exit-map "c" 'gnus-summary-catchup-and-exit)
+ (define-key gnus-summary-exit-map "C" 'gnus-summary-catchup-all-and-exit)
+ (define-key gnus-summary-exit-map "E" 'gnus-summary-exit-no-update)
+ (define-key gnus-summary-exit-map "Q" 'gnus-summary-exit)
+ (define-key gnus-summary-exit-map "Z" 'gnus-summary-exit)
+ (define-key gnus-summary-exit-map
+ "n" 'gnus-summary-catchup-and-goto-next-group)
+ (define-key gnus-summary-exit-map "R" 'gnus-summary-reselect-current-group)
+ (define-key gnus-summary-exit-map "G" 'gnus-summary-rescan-group)
+ (define-key gnus-summary-exit-map "N" 'gnus-summary-next-group)
+ (define-key gnus-summary-exit-map "P" 'gnus-summary-prev-group)
+
+
+ (define-prefix-command 'gnus-summary-article-map)
+ (define-key gnus-summary-mode-map "A" 'gnus-summary-article-map)
+ (define-key gnus-summary-article-map " " 'gnus-summary-next-page)
+ (define-key gnus-summary-article-map "n" 'gnus-summary-next-page)
+ (define-key gnus-summary-article-map "\177" 'gnus-summary-prev-page)
+ (define-key gnus-summary-article-map "p" 'gnus-summary-prev-page)
+ (define-key gnus-summary-article-map "\r" 'gnus-summary-scroll-up)
+ (define-key gnus-summary-article-map "<" 'gnus-summary-beginning-of-article)
+ (define-key gnus-summary-article-map ">" 'gnus-summary-end-of-article)
+ (define-key gnus-summary-article-map "b" 'gnus-summary-beginning-of-article)
+ (define-key gnus-summary-article-map "e" 'gnus-summary-end-of-article)
+ (define-key gnus-summary-article-map "^" 'gnus-summary-refer-parent-article)
+ (define-key gnus-summary-article-map "r" 'gnus-summary-refer-parent-article)
+ (define-key gnus-summary-article-map "g" 'gnus-summary-show-article)
+ (define-key gnus-summary-article-map "s" 'gnus-summary-isearch-article)
+
+
+
+ (define-prefix-command 'gnus-summary-wash-map)
+ (define-key gnus-summary-mode-map "W" 'gnus-summary-wash-map)
+
+ (define-prefix-command 'gnus-summary-wash-hide-map)
+ (define-key gnus-summary-wash-map "W" 'gnus-summary-wash-hide-map)
+ (define-key gnus-summary-wash-hide-map "a" 'gnus-article-hide)
+ (define-key gnus-summary-wash-hide-map "h" 'gnus-article-hide-headers)
+ (define-key gnus-summary-wash-hide-map "s" 'gnus-article-hide-signature)
+ (define-key gnus-summary-wash-hide-map "c" 'gnus-article-hide-citation)
+ (define-key gnus-summary-wash-hide-map
+ "\C-c" 'gnus-article-hide-citation-maybe)
+
+ (define-prefix-command 'gnus-summary-wash-highlight-map)
+ (define-key gnus-summary-wash-map "H" 'gnus-summary-wash-highlight-map)
+ (define-key gnus-summary-wash-highlight-map "a" 'gnus-article-highlight)
+ (define-key gnus-summary-wash-highlight-map
+ "h" 'gnus-article-highlight-headers)
+ (define-key gnus-summary-wash-highlight-map
+ "c" 'gnus-article-highlight-citation)
+ (define-key gnus-summary-wash-highlight-map
+ "s" 'gnus-article-highlight-signature)
+
+ (define-prefix-command 'gnus-summary-wash-time-map)
+ (define-key gnus-summary-wash-map "T" 'gnus-summary-wash-time-map)
+ (define-key gnus-summary-wash-time-map "z" 'gnus-article-date-ut)
+ (define-key gnus-summary-wash-time-map "u" 'gnus-article-date-ut)
+ (define-key gnus-summary-wash-time-map "l" 'gnus-article-date-local)
+ (define-key gnus-summary-wash-time-map "e" 'gnus-article-date-lapsed)
+
+ (define-key gnus-summary-wash-map "b" 'gnus-article-add-buttons)
+ (define-key gnus-summary-wash-map "o" 'gnus-article-treat-overstrike)
+ (define-key gnus-summary-wash-map "w" 'gnus-article-word-wrap)
+ (define-key gnus-summary-wash-map "c" 'gnus-article-remove-cr)
+ (define-key gnus-summary-wash-map "q" 'gnus-article-de-quoted-unreadable)
+ (define-key gnus-summary-wash-map "f" 'gnus-article-display-x-face)
+ (define-key gnus-summary-wash-map "l" 'gnus-summary-stop-page-breaking)
+ (define-key gnus-summary-wash-map "r" 'gnus-summary-caesar-message)
+ (define-key gnus-summary-wash-map "t" 'gnus-summary-toggle-header)
+ (define-key gnus-summary-wash-map "m" 'gnus-summary-toggle-mime)
+
+
+ (define-prefix-command 'gnus-summary-help-map)
+ (define-key gnus-summary-mode-map "H" 'gnus-summary-help-map)
+ (define-key gnus-summary-help-map "v" 'gnus-version)
+ (define-key gnus-summary-help-map "f" 'gnus-summary-fetch-faq)
+ (define-key gnus-summary-help-map "d" 'gnus-summary-describe-group)
+ (define-key gnus-summary-help-map "h" 'gnus-summary-describe-briefly)
+ (define-key gnus-summary-help-map "i" 'gnus-info-find-node)
+
+
+ (define-prefix-command 'gnus-summary-backend-map)
+ (define-key gnus-summary-mode-map "B" 'gnus-summary-backend-map)
+ (define-key gnus-summary-backend-map "e" 'gnus-summary-expire-articles)
+ (define-key gnus-summary-backend-map "\M-\C-e"
+ 'gnus-summary-expire-articles-now)
+ (define-key gnus-summary-backend-map "\177" 'gnus-summary-delete-article)
+ (define-key gnus-summary-backend-map "m" 'gnus-summary-move-article)
+ (define-key gnus-summary-backend-map "r" 'gnus-summary-respool-article)
+ (define-key gnus-summary-backend-map "w" 'gnus-summary-edit-article)
+ (define-key gnus-summary-backend-map "c" 'gnus-summary-copy-article)
+ (define-key gnus-summary-backend-map "q" 'gnus-summary-fancy-query)
+ (define-key gnus-summary-backend-map "i" 'gnus-summary-import-article)
+
+
+ (define-prefix-command 'gnus-summary-save-map)
+ (define-key gnus-summary-mode-map "O" 'gnus-summary-save-map)
+ (define-key gnus-summary-save-map "o" 'gnus-summary-save-article)
+ (define-key gnus-summary-save-map "m" 'gnus-summary-save-article-mail)
+ (define-key gnus-summary-save-map "r" 'gnus-summary-save-article-rmail)
+ (define-key gnus-summary-save-map "f" 'gnus-summary-save-article-file)
+ (define-key gnus-summary-save-map "h" 'gnus-summary-save-article-folder)
+ (define-key gnus-summary-save-map "v" 'gnus-summary-save-article-vm)
+ (define-key gnus-summary-save-map "p" 'gnus-summary-pipe-output)
+; (define-key gnus-summary-save-map "s" 'gnus-soup-add-article)
+
+ (define-key gnus-summary-mode-map "X" 'gnus-uu-extract-map)
+
+ (define-key gnus-summary-mode-map "\M-&" 'gnus-summary-universal-argument)
+; (define-key gnus-summary-various-map "\C-s" 'gnus-summary-search-article-forward)
+; (define-key gnus-summary-various-map "\C-r" 'gnus-summary-search-article-backward)
+; (define-key gnus-summary-various-map "r" 'gnus-summary-refer-article)
+; (define-key gnus-summary-various-map "&" 'gnus-summary-execute-command)
+; (define-key gnus-summary-various-map "T" 'gnus-summary-toggle-truncation)
+; (define-key gnus-summary-various-map "e" 'gnus-summary-expand-window)
+ (define-key gnus-summary-article-map "D" 'gnus-summary-enter-digest-group)
+; (define-key gnus-summary-various-map "k" 'gnus-summary-edit-local-kill)
+; (define-key gnus-summary-various-map "K" 'gnus-summary-edit-global-kill)
+
+ (define-key gnus-summary-mode-map "V" 'gnus-summary-score-map)
+
+; (define-prefix-command 'gnus-summary-sort-map)
+; (define-key gnus-summary-various-map "s" 'gnus-summary-sort-map)
+; (define-key gnus-summary-sort-map "n" 'gnus-summary-sort-by-number)
+; (define-key gnus-summary-sort-map "a" 'gnus-summary-sort-by-author)
+; (define-key gnus-summary-sort-map "s" 'gnus-summary-sort-by-subject)
+; (define-key gnus-summary-sort-map "d" 'gnus-summary-sort-by-date)
+; (define-key gnus-summary-sort-map "i" 'gnus-summary-sort-by-score)
+
+ (define-key gnus-summary-mode-map "I" 'gnus-summary-increase-score)
+ (define-key gnus-summary-mode-map "L" 'gnus-summary-lower-score)
+ )
+
+
+
+
+(defun gnus-summary-mode (&optional group)
+ "Major mode for reading articles.
+
+All normal editing commands are switched off.
+\\<gnus-summary-mode-map>
+Each line in this buffer represents one article. To read an
+article, you can, for instance, type `\\[gnus-summary-next-page]'. To move forwards
+and backwards while displaying articles, type `\\[gnus-summary-next-unread-article]' and `\\[gnus-summary-prev-unread-article]',
+respectively.
+
+You can also post articles and send mail from this buffer. To
+follow up an article, type `\\[gnus-summary-followup]'. To mail a reply to the author
+of an article, type `\\[gnus-summary-reply]'.
+
+There are approx. one gazillion commands you can execute in this
+buffer; read the info pages for more information (`\\[gnus-info-find-node]').
+
+The following commands are available:
+
+\\{gnus-summary-mode-map}"
+ (interactive)
+ (if gnus-visual (gnus-summary-make-menu-bar))
+ (kill-all-local-variables)
+ (let ((locals gnus-summary-local-variables))
+ (while locals
+ (if (consp (car locals))
+ (progn
+ (make-local-variable (car (car locals)))
+ (set (car (car locals)) (eval (cdr (car locals)))))
+ (make-local-variable (car locals))
+ (set (car locals) nil))
+ (setq locals (cdr locals))))
+ (gnus-make-thread-indent-array)
+ (setq mode-line-modified "-- ")
+ (make-local-variable 'mode-line-format)
+ (setq mode-line-format (copy-sequence mode-line-format))
+ (and (equal (nth 3 mode-line-format) " ")
+ (setcar (nthcdr 3 mode-line-format) ""))
+ (setq major-mode 'gnus-summary-mode)
+ (setq mode-name "Summary")
+ (make-local-variable 'minor-mode-alist)
+ (use-local-map gnus-summary-mode-map)
+ (buffer-disable-undo (current-buffer))
+ (setq buffer-read-only t) ;Disable modification
+ (setq truncate-lines t)
+ (setq selective-display t)
+ (setq selective-display-ellipses t) ;Display `...'
+ (setq buffer-display-table gnus-summary-display-table)
+ (setq gnus-newsgroup-name group)
+ (run-hooks 'gnus-summary-mode-hook))
+
+(defun gnus-summary-make-display-table ()
+ ;; Change the display table. Odd characters have a tendency to mess
+ ;; up nicely formatted displays - we make all possible glyphs
+ ;; display only a single character.
+
+ ;; We start from the standard display table, if any.
+ (setq gnus-summary-display-table
+ (or (copy-sequence standard-display-table)
+ (make-display-table)))
+ ;; Nix out all the control chars...
+ (let ((i 32))
+ (while (>= (setq i (1- i)) 0)
+ (aset gnus-summary-display-table i [??])))
+ ;; ... but not newline and cr, of course. (cr is necessary for the
+ ;; selective display).
+ (aset gnus-summary-display-table ?\n nil)
+ (aset gnus-summary-display-table ?\r nil)
+ ;; We nix out any glyphs over 126 that are not set already.
+ (let ((i 256))
+ (while (>= (setq i (1- i)) 127)
+ ;; Only modify if the entry is nil.
+ (or (aref gnus-summary-display-table i)
+ (aset gnus-summary-display-table i [??])))))
+
+(defun gnus-summary-clear-local-variables ()
+ (let ((locals gnus-summary-local-variables))
+ (while locals
+ (if (consp (car locals))
+ (and (vectorp (car (car locals)))
+ (set (car (car locals)) nil))
+ (and (vectorp (car locals))
+ (set (car locals) nil)))
+ (setq locals (cdr locals)))))
+
+;; Some summary mode macros.
+
+;; Return a header specified by a NUMBER.
+(defun gnus-get-header-by-number (number)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (or gnus-newsgroup-headers-hashtb-by-number
+ (gnus-make-headers-hashtable-by-number))
+ (gnus-gethash (int-to-string number)
+ gnus-newsgroup-headers-hashtb-by-number)))
+
+;; Fast version of the function above.
+(defmacro gnus-get-header-by-num (number)
+ (` (gnus-gethash (int-to-string (, number))
+ gnus-newsgroup-headers-hashtb-by-number)))
+
+(defmacro gnus-summary-search-forward (&optional unread subject backward)
+ "Search for article forward.
+If UNREAD is non-nil, only unread articles are selected.
+If SUBJECT is non-nil, the article which has the same subject will be
+searched for.
+If BACKWARD is non-nil, the search will be performed backwards instead."
+ (` (gnus-summary-search-subject (, backward) (, unread) (, subject))))
+
+(defmacro gnus-summary-search-backward (&optional unread subject)
+ "Search for article backward.
+If 1st optional argument UNREAD is non-nil, only unread article is selected.
+If 2nd optional argument SUBJECT is non-nil, the article which has
+the same subject will be searched for."
+ (` (gnus-summary-search-forward (, unread) (, subject) t)))
+
+(defmacro gnus-summary-article-number (&optional number-or-nil)
+ "The article number of the article on the current line.
+If there isn's an article number here, then we return the current
+article number."
+ (if number-or-nil
+ '(get-text-property (gnus-point-at-bol) 'gnus-number)
+ '(or (get-text-property (gnus-point-at-bol) 'gnus-number)
+ gnus-current-article)))
+
+(defmacro gnus-summary-thread-level ()
+ "The thread level of the article on the current line."
+ '(or (get-text-property (gnus-point-at-bol) 'gnus-level)
+ 0))
+
+(defmacro gnus-summary-article-mark ()
+ "The mark on the current line."
+ '(get-text-property (gnus-point-at-bol) 'gnus-mark))
+
+(defun gnus-summary-subject-string ()
+ "Return current subject string or nil if nothing."
+ (let ((article (gnus-summary-article-number))
+ header)
+ (and article
+ (setq header (gnus-get-header-by-num article))
+ (vectorp header)
+ (mail-header-subject header))))
+
+;; Various summary mode internalish functions.
+
+(defun gnus-mouse-pick-article (e)
+ (interactive "e")
+ (mouse-set-point e)
+ (gnus-summary-next-page nil t))
+
+(defun gnus-summary-setup-buffer (group)
+ "Initialize summary buffer."
+ (let ((buffer (concat "*Summary " group "*")))
+ (if (get-buffer buffer)
+ (progn
+ (set-buffer buffer)
+ (not gnus-newsgroup-begin))
+ ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
+ (setq gnus-summary-buffer (set-buffer (get-buffer-create buffer)))
+ (gnus-add-current-to-buffer-list)
+ (gnus-summary-mode group)
+ (and gnus-carpal (gnus-carpal-setup-buffer 'summary))
+ (setq gnus-newsgroup-name group)
+ t)))
+
+(defun gnus-set-global-variables ()
+ ;; Set the global equivalents of the summary buffer-local variables
+ ;; to the latest values they had. These reflect the summary buffer
+ ;; that was in action when the last article was fetched.
+ (if (eq major-mode 'gnus-summary-mode)
+ (progn
+ (setq gnus-summary-buffer (current-buffer))
+ (let ((name gnus-newsgroup-name)
+ (marked gnus-newsgroup-marked)
+ (unread gnus-newsgroup-unreads)
+ (headers gnus-current-headers)
+ (score-file gnus-current-score-file))
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (setq gnus-newsgroup-name name)
+ (setq gnus-newsgroup-marked marked)
+ (setq gnus-newsgroup-unreads unread)
+ (setq gnus-current-headers headers)
+ (setq gnus-current-score-file score-file))))))
+
+(defun gnus-summary-insert-dummy-line (sformat subject number)
+ (if (not sformat)
+ (setq sformat gnus-summary-dummy-line-format-spec))
+ (let (b)
+ (beginning-of-line)
+ (setq b (point))
+ (insert (eval sformat))
+ (add-text-properties
+ b (1+ b)
+ (list 'gnus-number number
+ 'gnus-mark gnus-dummy-mark
+ 'gnus-level 0))))
+
+(defvar gnus-thread-indent-array nil)
+(defvar gnus-thread-indent-array-level gnus-thread-indent-level)
+(defun gnus-make-thread-indent-array ()
+ (let ((n 200))
+ (if (and gnus-thread-indent-array
+ (= gnus-thread-indent-level gnus-thread-indent-array-level))
+ nil
+ (setq gnus-thread-indent-array (make-vector 201 "")
+ gnus-thread-indent-array-level gnus-thread-indent-level)
+ (while (>= n 0)
+ (aset gnus-thread-indent-array n
+ (make-string (* n gnus-thread-indent-level) ? ))
+ (setq n (1- n))))))
+
+(defun gnus-summary-insert-line
+ (sformat header level current unread replied expirable subject-or-nil
+ &optional dummy score process)
+ (or sformat (setq sformat gnus-summary-line-format-spec))
+ (let* ((indentation (aref gnus-thread-indent-array level))
+ (lines (mail-header-lines header))
+ (score (or score gnus-summary-default-score 0))
+ (score-char
+ (if (or (null gnus-summary-default-score)
+ (<= (abs (- score gnus-summary-default-score))
+ gnus-summary-zcore-fuzz)) ?
+ (if (< score gnus-summary-default-score)
+ gnus-score-below-mark gnus-score-over-mark)))
+ (replied (cond (process gnus-process-mark)
+ (replied gnus-replied-mark)
+ (t gnus-unread-mark)))
+ (from (mail-header-from header))
+ (name (cond
+ ((string-match "(.+)" from)
+ (substring from (1+ (match-beginning 0)) (1- (match-end 0))))
+ ((string-match "<[^>]+> *$" from)
+ (let ((beg (match-beginning 0)))
+ (or (and (string-match "^\"[^\"]*\"" from)
+ (substring from (1+ (match-beginning 0))
+ (1- (match-end 0))))
+ (substring from 0 beg))))
+ (t from)))
+ (subject (mail-header-subject header))
+ (number (mail-header-number header))
+ (opening-bracket (if dummy ?\< ?\[))
+ (closing-bracket (if dummy ?\> ?\]))
+ (buffer-read-only nil)
+ (b (progn (beginning-of-line) (point))))
+ (or (numberp lines) (setq lines 0))
+ (insert (eval sformat))
+ (add-text-properties
+ b (1+ b) (list 'gnus-number number
+ 'gnus-mark (or unread gnus-unread-mark)
+ 'gnus-level level))))
+
+(defun gnus-summary-update-line (&optional dont-update)
+ ;; Update summary line after change.
+ (or (not gnus-summary-default-score)
+ gnus-summary-inhibit-highlight
+ (let ((gnus-summary-inhibit-highlight t)
+ (article (gnus-summary-article-number)))
+ (progn
+ (or dont-update
+ (if (and gnus-summary-mark-below
+ (< (gnus-summary-article-score)
+ gnus-summary-mark-below))
+ (and (not (memq article gnus-newsgroup-marked))
+ (not (memq article gnus-newsgroup-dormant))
+ (memq article gnus-newsgroup-unreads)
+ (gnus-summary-mark-article-as-read gnus-low-score-mark))
+ (and (eq (gnus-summary-article-mark) gnus-low-score-mark)
+ (gnus-summary-mark-article-as-unread gnus-unread-mark))))
+ (and gnus-visual
+ (run-hooks 'gnus-summary-update-hook))))))
+
+(defun gnus-summary-update-lines (&optional beg end)
+ ;; Mark article as read (or not) by taking into account scores.
+ (let ((beg (or beg (point-min)))
+ (end (or end (point-max))))
+ (if (or (not gnus-summary-default-score)
+ gnus-summary-inhibit-highlight)
+ ()
+ (let ((gnus-summary-inhibit-highlight t)
+ article)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (goto-char beg)
+ (beginning-of-line)
+ (while (and (not (eobp)) (< (point) end))
+ (if (and gnus-summary-mark-below
+ (< (or (cdr (assq
+ (setq article (get-text-property
+ (point) 'gnus-number))
+ gnus-newsgroup-scored))
+ gnus-summary-default-score 0)
+ gnus-summary-mark-below))
+ ;; We want to possibly mark it as read...
+ (and (not (memq article gnus-newsgroup-marked))
+ (not (memq article gnus-newsgroup-dormant))
+ (memq article gnus-newsgroup-unreads)
+ (gnus-summary-mark-article-as-read gnus-low-score-mark))
+ ;; We want to possibly mark it as unread.
+ (and (eq (get-text-property (point) 'gnus-mark)
+ gnus-low-score-mark)
+ (gnus-summary-mark-article-as-unread gnus-unread-mark)))
+ ;; Do the visual highlights at the same time.
+ (and gnus-visual (run-hooks 'gnus-summary-update-hook))
+ (forward-line 1)))))))
+
+(defvar gnus-tmp-gathered nil)
+
+(defun gnus-summary-number-of-articles-in-thread (thread &optional char)
+ ;; Sum up all elements (and sub-elements) in a list.
+ (let* ((number
+ ;; Fix by Luc Van Eycken <Luc.VanEycken@esat.kuleuven.ac.be>.
+ (if (and (consp thread) (cdr thread))
+ (apply
+ '+ 1 (mapcar
+ 'gnus-summary-number-of-articles-in-thread
+ (cdr thread)))
+ 1)))
+ (if char
+ (if (> number 1) gnus-not-empty-thread-mark
+ gnus-empty-thread-mark)
+ number)))
+
+(defun gnus-summary-read-group
+ (group &optional show-all no-article kill-buffer)
+ "Start reading news in newsgroup GROUP.
+If SHOW-ALL is non-nil, already read articles are also listed.
+If NO-ARTICLE is non-nil, no article is selected initially."
+ (gnus-message 5 "Retrieving newsgroup: %s..." group)
+ (let* ((new-group (gnus-summary-setup-buffer group))
+ (quit-config (gnus-group-quit-config group))
+ (did-select (and new-group (gnus-select-newsgroup group show-all))))
+ (cond
+ ((not new-group)
+ (gnus-set-global-variables)
+ (gnus-kill-buffer kill-buffer)
+ (gnus-configure-windows 'summary 'force)
+ (gnus-set-mode-line 'summary)
+ (gnus-summary-position-cursor)
+ (message "")
+ t)
+ ((null did-select)
+ (and (eq major-mode 'gnus-summary-mode)
+ (not (equal (current-buffer) kill-buffer))
+ (progn
+ (kill-buffer (current-buffer))
+ (if (not quit-config)
+ (progn
+ (set-buffer gnus-group-buffer)
+ (gnus-group-jump-to-group group)
+ (gnus-group-next-unread-group 1))
+ (if (not (buffer-name (car quit-config)))
+ (gnus-configure-windows 'group 'force)
+ (set-buffer (car quit-config))
+ (and (eq major-mode 'gnus-summary-mode)
+ (gnus-set-global-variables))
+ (gnus-configure-windows (cdr quit-config))))))
+ (message "Can't select group")
+ nil)
+ ((eq did-select 'quit)
+ (and (eq major-mode 'gnus-summary-mode)
+ (not (equal (current-buffer) kill-buffer))
+ (kill-buffer (current-buffer)))
+ (gnus-kill-buffer kill-buffer)
+ (if (not quit-config)
+ (progn
+ (set-buffer gnus-group-buffer)
+ (gnus-group-jump-to-group group)
+ (gnus-group-next-unread-group 1)
+ (gnus-configure-windows 'group 'force))
+ (if (not (buffer-name (car quit-config)))
+ (gnus-configure-windows 'group 'force)
+ (set-buffer (car quit-config))
+ (and (eq major-mode 'gnus-summary-mode)
+ (gnus-set-global-variables))
+ (gnus-configure-windows (cdr quit-config))))
+ (signal 'quit nil))
+ (t
+ (gnus-set-global-variables)
+ ;; Save the active value in effect when the group was entered.
+ (setq gnus-newsgroup-active
+ (gnus-copy-sequence
+ (gnus-gethash gnus-newsgroup-name gnus-active-hashtb)))
+ ;; You can change the subjects in this hook.
+ (run-hooks 'gnus-select-group-hook)
+ ;; Do score processing.
+ (and gnus-use-scoring (gnus-possibly-score-headers))
+ (gnus-update-format-specifications)
+ ;; Generate the summary buffer.
+ (gnus-summary-prepare)
+ (if (zerop (buffer-size))
+ (cond (gnus-newsgroup-dormant
+ (gnus-summary-show-all-dormant))
+ ((and gnus-newsgroup-scored show-all)
+ (gnus-summary-show-all-expunged))))
+ ;; Function `gnus-apply-kill-file' must be called in this hook.
+ (run-hooks 'gnus-apply-kill-hook)
+ (if (zerop (buffer-size))
+ (progn
+ ;; This newsgroup is empty.
+ (gnus-summary-catchup-and-exit nil t) ;Without confirmations.
+ (gnus-message 6 "No unread news")
+ (gnus-kill-buffer kill-buffer)
+ nil)
+ ;;(save-excursion
+ ;; (if kill-buffer
+ ;; (let ((gnus-summary-buffer kill-buffer))
+ ;; (gnus-configure-windows 'group))))
+ ;; Hide conversation thread subtrees. We cannot do this in
+ ;; gnus-summary-prepare-hook since kill processing may not
+ ;; work with hidden articles.
+ (and gnus-show-threads
+ gnus-thread-hide-subtree
+ (gnus-summary-hide-all-threads))
+ ;; Show first unread article if requested.
+ (goto-char (point-min))
+ (if (and (not no-article)
+ gnus-auto-select-first
+ (gnus-summary-first-unread-article))
+ ()
+ (gnus-configure-windows 'summary 'force))
+ (gnus-set-mode-line 'summary)
+ (gnus-summary-position-cursor)
+ ;; If in async mode, we send some info to the backend.
+ (and gnus-newsgroup-async
+ (setq gnus-newsgroup-threads (nreverse gnus-newsgroup-threads))
+ (gnus-request-asynchronous
+ gnus-newsgroup-name
+ (if (and gnus-asynchronous-article-function
+ (fboundp gnus-asynchronous-article-function))
+ (funcall gnus-asynchronous-article-function
+ gnus-newsgroup-threads)
+ gnus-newsgroup-threads)))
+ (gnus-kill-buffer kill-buffer)
+ (if (not (get-buffer-window gnus-group-buffer))
+ ()
+ ;; gotta use windows, because recenter does wierd stuff if
+ ;; the current buffer ain't the displayed window.
+ (let ((owin (selected-window)))
+ (select-window (get-buffer-window gnus-group-buffer))
+ (and (gnus-group-goto-group group)
+ (recenter))
+ (select-window owin))))
+ t))))
+
+(defun gnus-summary-prepare ()
+ ;; Generate the summary buffer.
+ (let ((buffer-read-only nil))
+ (erase-buffer)
+ (gnus-summary-prepare-threads
+ (if gnus-show-threads
+ (gnus-gather-threads
+ (gnus-sort-threads
+ (if (and gnus-summary-expunge-below
+ (not gnus-fetch-old-headers))
+ (gnus-make-threads-and-expunge)
+ (gnus-make-threads))))
+ gnus-newsgroup-headers)
+ 'cull)
+ (gnus-summary-update-lines)
+ ;; Create the header hashtb.
+ (gnus-make-headers-hashtable-by-number)
+ ;; Call hooks for modifying summary buffer.
+ ;; Suggested by sven@tde.LTH.Se (Sven Mattisson).
+ (goto-char (point-min))
+ (run-hooks 'gnus-summary-prepare-hook)))
+
+(defun gnus-gather-threads (threads)
+ "Gather threads that have lost their roots."
+ (if (not gnus-summary-make-false-root)
+ threads
+ (let ((hashtb (gnus-make-hashtable 1023))
+ (prev threads)
+ (result threads)
+ subject hthread whole-subject)
+ (while threads
+ (setq whole-subject
+ (setq subject (mail-header-subject (car (car threads)))))
+ (if gnus-summary-gather-subject-limit
+ (or (and (numberp gnus-summary-gather-subject-limit)
+ (> (length subject) gnus-summary-gather-subject-limit)
+ (setq subject
+ (substring subject 0
+ gnus-summary-gather-subject-limit)))
+ (and (eq 'fuzzy gnus-summary-gather-subject-limit)
+ (setq subject (gnus-simplify-subject-fuzzy subject))))
+ (setq subject (gnus-simplify-subject-re subject)))
+ (if (setq hthread
+ (gnus-gethash subject hashtb))
+ (progn
+ (or (stringp (car (car hthread)))
+ (setcar hthread (list whole-subject (car hthread))))
+ (setcdr (car hthread) (nconc (cdr (car hthread))
+ (list (car threads))))
+ (setcdr prev (cdr threads))
+ (setq threads prev))
+ (gnus-sethash subject threads hashtb))
+ (setq prev threads)
+ (setq threads (cdr threads)))
+ result)))
+
+(defun gnus-make-threads ()
+ ;; This function takes the dependencies already made by
+ ;; `gnus-get-newsgroup-headers' and builds the trees. First we go
+ ;; through the dependecies in the hash table and finds all the
+ ;; roots. Roots do not refer back to any valid articles.
+ (gnus-message 6 "Threading...")
+ (let (roots new-roots)
+ (and gnus-fetch-old-headers
+ (eq gnus-headers-retrieved-by 'nov)
+ (gnus-build-old-threads))
+ (mapatoms
+ (lambda (refs)
+ (if (not (car (symbol-value refs)))
+ (setq roots (append (cdr (symbol-value refs)) roots))
+ ;; Ok, these refer back to valid articles, but if
+ ;; `gnus-thread-ignore-subject' is nil, we have to check that
+ ;; the root has the same subject as its children. The children
+ ;; that do not are made into roots and removed from the list
+ ;; of children.
+ (or gnus-thread-ignore-subject
+ (let* ((prev (symbol-value refs))
+ (subject (gnus-simplify-subject-re
+ (mail-header-subject (car prev))))
+ (headers (cdr prev)))
+ (while headers
+ (if (not (string= subject
+ (gnus-simplify-subject-re
+ (mail-header-subject (car headers)))))
+ (progn
+ (setq new-roots (cons (car headers) new-roots))
+ (setcdr prev (cdr headers)))
+ (setq prev headers))
+ (setq headers (cdr headers)))))))
+ gnus-newsgroup-dependencies)
+
+ ;; We enter the new roots into the dependencies structure to
+ ;; ensure that any possible later thread-regeneration will be
+ ;; possible.
+ (let ((r new-roots))
+ (while r
+ (gnus-sethash (concat (mail-header-id (car r)) ".boo")
+ (list nil (car r)) gnus-newsgroup-dependencies)
+ (setq r (cdr r))))
+
+ (setq roots (nconc new-roots roots))
+
+ (prog1
+ (mapcar 'gnus-trim-thread
+ (apply 'append
+ (mapcar 'gnus-cut-thread
+ (mapcar 'gnus-make-sub-thread roots))))
+ (gnus-message 6 "Threading...done"))))
+
+
+(defun gnus-make-threads-and-expunge ()
+ ;; This function takes the dependencies already made by
+ ;; `gnus-get-newsgroup-headers' and builds the trees. First we go
+ ;; through the dependecies in the hash table and finds all the
+ ;; roots. Roots do not refer back to any valid articles.
+ (gnus-message 6 "Threading...")
+ (let ((default (or gnus-summary-default-score 0))
+ (below gnus-summary-expunge-below)
+ roots article new-roots)
+ (and gnus-fetch-old-headers
+ (eq gnus-headers-retrieved-by 'nov)
+ (gnus-build-old-threads))
+ (mapatoms
+ (lambda (refs)
+ (if (not (car (symbol-value refs)))
+ ;; These articles do not refer back to any other articles -
+ ;; they are roots.
+ (let ((headers (cdr (symbol-value refs))))
+ ;; We weed out the low-scored articles.
+ (while headers
+ (if (not (< (or (cdr (assq (mail-header-number (car headers))
+ gnus-newsgroup-scored)) default)
+ below))
+ ;; It is over.
+ (setq roots (cons (car headers) roots))
+ ;; It is below, so we mark it as read.
+ (setq gnus-newsgroup-unreads
+ (delq (mail-header-number (car headers))
+ gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-reads
+ (cons (cons (mail-header-number (car headers))
+ gnus-low-score-mark)
+ gnus-newsgroup-reads)))
+ (setq headers (cdr headers))))
+ ;; Ok, these refer back to valid articles, but if
+ ;; `gnus-thread-ignore-subject' is nil, we have to check that
+ ;; the root has the same subject as its children. The children
+ ;; that do not are made into roots and removed from the list
+ ;; of children.
+ (or gnus-thread-ignore-subject
+ (let* ((prev (symbol-value refs))
+ (subject (gnus-simplify-subject-re
+ (mail-header-subject (car prev))))
+ (headers (cdr prev)))
+ (while headers
+ (if (not (string= subject
+ (gnus-simplify-subject-re
+ (mail-header-subject (car headers)))))
+ (progn
+ (if (not (< (or (cdr (assq (mail-header-number
+ (car headers))
+ gnus-newsgroup-scored))
+ default) below))
+ (setq new-roots (cons (car headers) new-roots))
+ (setq gnus-newsgroup-unreads
+ (delq (mail-header-number (car headers))
+ gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-reads
+ (cons (cons (mail-header-number (car headers))
+ gnus-low-score-mark)
+ gnus-newsgroup-reads)))
+ (setcdr prev (cdr headers)))
+ (setq prev headers))
+ (setq headers (cdr headers)))))
+ ;; If this article is expunged, some of the children might be
+ ;; roots.
+ (if (< (or (cdr (assq (mail-header-number (car (symbol-value refs)))
+ gnus-newsgroup-scored)) default)
+ below)
+ (let* ((prev (symbol-value refs))
+ (headers (cdr prev)))
+ (while headers
+ (setq article (mail-header-number (car headers)))
+ (if (not (< (or (cdr (assq article gnus-newsgroup-scored))
+ default) below))
+ (progn (setq new-roots (cons (car headers) new-roots))
+ (setq prev headers))
+ (setq gnus-newsgroup-unreads
+ (delq article gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-reads
+ (cons (cons article gnus-low-score-mark)
+ gnus-newsgroup-reads))
+ (setcdr prev (cdr headers)))
+ (setq headers (cdr headers))))
+ ;; It was not expunged, but we look at expunged children.
+ (let* ((prev (symbol-value refs))
+ (headers (cdr prev))
+ article)
+ (while headers
+ (setq article (mail-header-number (car headers)))
+ (if (not (< (or (cdr (assq article gnus-newsgroup-scored))
+ default) below))
+ (setq prev headers)
+ (setq gnus-newsgroup-unreads
+ (delq article gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-reads
+ (cons (cons article gnus-low-score-mark)
+ gnus-newsgroup-reads))
+ (setcdr prev (cdr headers)))
+ (setq headers (cdr headers)))))))
+ gnus-newsgroup-dependencies)
+
+ ;; We enter the new roots into the dependencies structure to
+ ;; ensure that any possible later thread-regeneration will be
+ ;; possible.
+ (let ((r new-roots))
+ (while r
+ (gnus-sethash (concat (mail-header-id (car r)) ".boo")
+ (list nil (car r)) gnus-newsgroup-dependencies)
+ (setq r (cdr r))))
+
+ (setq roots (nconc new-roots roots))
+
+ (prog1
+ (mapcar 'gnus-trim-thread
+ (apply 'append
+ (mapcar 'gnus-cut-thread
+ (mapcar 'gnus-make-sub-thread roots))))
+ (gnus-message 6 "Threading...done"))))
+
+
+(defun gnus-cut-thread (thread)
+ ;; Remove leaf dormant or ancient articles from THREAD.
+ (let ((head (car thread))
+ (tail (apply 'append (mapcar 'gnus-cut-thread (cdr thread)))))
+ (if (and (null tail)
+ (let ((number (mail-header-number head)))
+ (or (memq number gnus-newsgroup-ancient)
+ (memq number gnus-newsgroup-dormant)
+ (and gnus-summary-expunge-below
+ (eq gnus-fetch-old-headers 'some)
+ (< (or (cdr (assq number gnus-newsgroup-scored))
+ gnus-summary-default-score 0)
+ gnus-summary-expunge-below)
+ (progn
+ (setq gnus-newsgroup-unreads
+ (delq number gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-reads
+ (cons (cons number gnus-low-score-mark)
+ gnus-newsgroup-reads))
+ t)))))
+ nil
+ (list (cons head tail)))))
+
+(defun gnus-trim-thread (thread)
+ ;; Remove root ancient articles with only one child from THREAD.
+ (if (and (eq gnus-fetch-old-headers 'some)
+ (memq (mail-header-number (car thread)) gnus-newsgroup-ancient)
+ (= (length thread) 2))
+ (gnus-trim-thread (nth 1 thread))
+ thread))
+
+(defun gnus-make-sub-thread (root)
+ ;; This function makes a sub-tree for a node in the tree.
+ (let ((children (reverse (cdr (gnus-gethash (downcase (mail-header-id root))
+ gnus-newsgroup-dependencies)))))
+ (cons root (mapcar 'gnus-make-sub-thread children))))
+
+(defun gnus-build-old-threads ()
+ ;; Look at all the articles that refer back to old articles, and
+ ;; fetch the headers for the articles that aren't there. This will
+ ;; build complete threads - if the roots haven't been expired by the
+ ;; server, that is.
+ (let (id heads)
+ (mapatoms
+ (lambda (refs)
+ (if (not (car (symbol-value refs)))
+ (progn
+ (setq heads (cdr (symbol-value refs)))
+ (while heads
+ (if (not (memq (mail-header-number (car heads))
+ gnus-newsgroup-dormant))
+ (progn
+ (setq id (symbol-name refs))
+ (while (and (setq id (gnus-build-get-header id))
+ (not (car (gnus-gethash
+ id gnus-newsgroup-dependencies)))))
+ (setq heads nil))
+ (setq heads (cdr heads)))))))
+ gnus-newsgroup-dependencies)))
+
+(defun gnus-build-get-header (id)
+ ;; Look through the buffer of NOV lines and find the header to
+ ;; ID. Enter this line into the dependencies hash table, and return
+ ;; the id of the parent article (if any).
+ (let ((deps gnus-newsgroup-dependencies)
+ found header)
+ (prog1
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (while (and (not found) (search-forward id nil t))
+ (beginning-of-line)
+ (setq found (looking-at
+ (format "^[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t%s"
+ (regexp-quote id))))
+ (or found (beginning-of-line 2)))
+ (if found
+ (let (ref)
+ (beginning-of-line)
+ (and
+ (setq header (gnus-nov-parse-line
+ (read (current-buffer)) deps))
+ (setq ref (mail-header-references header))
+ (string-match "\\(<[^>]+>\\) *$" ref)
+ (substring ref (match-beginning 1) (match-end 1))))))
+ (and header
+ (setq gnus-newsgroup-headers (cons header gnus-newsgroup-headers)
+ gnus-newsgroup-ancient (cons (mail-header-number header)
+ gnus-newsgroup-ancient))))))
+
+;; Re-build the thread containing ID.
+(defun gnus-rebuild-thread (id)
+ (let ((dep gnus-newsgroup-dependencies)
+ (buffer-read-only nil)
+ parent headers refs thread art)
+ (while (and id (setq headers
+ (car (setq art (gnus-gethash (downcase id) dep)))))
+ (setq parent art)
+ (setq id (and (setq refs (mail-header-references headers))
+ (string-match "\\(<[^>]+>\\) *$" refs)
+ (substring refs (match-beginning 1) (match-end 1)))))
+ (setq thread (gnus-make-sub-thread (car parent)))
+ (gnus-rebuild-remove-articles thread)
+ (let ((beg (point)))
+ (gnus-summary-prepare-threads (list thread))
+ (gnus-summary-update-lines beg (point)))))
+
+;; Delete all lines in the summary buffer that correspond to articles
+;; in this thread.
+(defun gnus-rebuild-remove-articles (thread)
+ (and (gnus-summary-goto-subject (mail-header-number (car thread)))
+ (gnus-delete-line))
+ (mapcar (lambda (th) (gnus-rebuild-remove-articles th)) (cdr thread)))
+
+(defun gnus-sort-threads (threads)
+ ;; Sort threads as specified in `gnus-thread-sort-functions'.
+ (let ((fun gnus-thread-sort-functions))
+ (while fun
+ (gnus-message 6 "Sorting with %S..." fun)
+ (setq threads (sort threads (car fun))
+ fun (cdr fun))))
+ (if gnus-thread-sort-functions
+ (gnus-message 6 "Sorting...done"))
+ threads)
+
+;; Written by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
+(defmacro gnus-thread-header (thread)
+ ;; Return header of first article in THREAD.
+ ;; Note that THREAD must never, evr be anything else than a variable -
+ ;; using some other form will lead to serious barfage.
+ (or (symbolp thread) (signal 'wrong-type-argument '(symbolp thread)))
+ ;; (8% speedup to gnus-summary-prepare, just for fun :-)
+ (list 'byte-code "\10\211:\203\17\0\211@;\203\16\0A@@\207" ;
+ (vector thread) 2))
+
+(defun gnus-thread-sort-by-number (h1 h2)
+ "Sort threads by root article number."
+ (< (mail-header-number (gnus-thread-header h1))
+ (mail-header-number (gnus-thread-header h2))))
+
+(defun gnus-thread-sort-by-author (h1 h2)
+ "Sort threads by root author."
+ (string-lessp
+ (let ((extract (funcall
+ gnus-extract-address-components
+ (mail-header-from (gnus-thread-header h1)))))
+ (or (car extract) (cdr extract)))
+ (let ((extract (funcall
+ gnus-extract-address-components
+ (mail-header-from (gnus-thread-header h2)))))
+ (or (car extract) (cdr extract)))))
+
+(defun gnus-thread-sort-by-subject (h1 h2)
+ "Sort threads by root subject."
+ (string-lessp
+ (downcase (gnus-simplify-subject-re
+ (mail-header-subject (gnus-thread-header h1))))
+ (downcase (gnus-simplify-subject-re
+ (mail-header-subject (gnus-thread-header h2))))))
+
+(defun gnus-thread-sort-by-date (h1 h2)
+ "Sort threads by root article date."
+ (string-lessp
+ (gnus-sortable-date (mail-header-date (gnus-thread-header h1)))
+ (gnus-sortable-date (mail-header-date (gnus-thread-header h2)))))
+
+(defun gnus-thread-sort-by-score (h1 h2)
+ "Sort threads by root article score.
+Unscored articles will be counted as having a score of zero."
+ (> (or (cdr (assq (mail-header-number (gnus-thread-header h1))
+ gnus-newsgroup-scored))
+ gnus-summary-default-score 0)
+ (or (cdr (assq (mail-header-number (gnus-thread-header h2))
+ gnus-newsgroup-scored))
+ gnus-summary-default-score 0)))
+
+(defun gnus-thread-sort-by-total-score (h1 h2)
+ "Sort threads by the sum of all scores in the thread.
+Unscored articles will be counted as having a score of zero."
+ (> (gnus-thread-total-score h1) (gnus-thread-total-score h2)))
+
+(defun gnus-thread-total-score (thread)
+ ;; This function find the total score of THREAD.
+ (if (consp thread)
+ (if (stringp (car thread))
+ (apply gnus-thread-score-function 0
+ (mapcar 'gnus-thread-total-score-1 (cdr thread)))
+ (gnus-thread-total-score-1 thread))
+ (gnus-thread-total-score-1 (list thread))))
+
+(defun gnus-thread-total-score-1 (root)
+ ;; This function find the total score of the thread below ROOT.
+ (setq root (car root))
+ (apply gnus-thread-score-function
+ (or (cdr (assq (mail-header-number root) gnus-newsgroup-scored))
+ gnus-summary-default-score 0)
+ (mapcar 'gnus-thread-total-score
+ (cdr (gnus-gethash (downcase (mail-header-id root))
+ gnus-newsgroup-dependencies)))))
+
+;; Added by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defvar gnus-tmp-prev-subject "")
+
+(defun gnus-summary-prepare-threads (threads &optional cull)
+ "Prepare summary buffer from THREADS and indentation LEVEL.
+THREADS is either a list of `(PARENT [(CHILD1 [(GRANDCHILD ...]...) ...])'
+or a straight list of headers."
+ (message "Generating summary...")
+ (let ((level 0)
+ thread header number subject stack state gnus-tmp-gathered)
+ (if (vectorp (car threads))
+ ;; If this is a straight (sic) list of headers, then a
+ ;; threaded summary display isn't required, so we just create
+ ;; an unthreaded one.
+ (gnus-summary-prepare-unthreaded threads cull)
+
+ ;; Do the threaded display.
+
+ (while (or threads stack)
+
+ (if threads
+ ;; If there are some threads, we do them before the
+ ;; threads on the stack.
+ (setq thread threads
+ header (car (car thread)))
+ ;; There were no current threads, so we pop something off
+ ;; the stack.
+ (setq state (car stack)
+ level (car state)
+ thread (cdr state)
+ stack (cdr stack)
+ header (car (car thread))))
+
+ (if (stringp header)
+ (progn
+ ;; The header is a dummy root.
+ (cond
+ ((eq gnus-summary-make-false-root 'adopt)
+ ;; We let the first article adopt the rest.
+ (let ((th (car (cdr (car thread)))))
+ (while (cdr th)
+ (setq th (cdr th)))
+ (setcdr th (cdr (cdr (car thread))))
+ (setq gnus-tmp-gathered
+ (nconc (mapcar
+ (lambda (h) (mail-header-number (car h)))
+ (cdr (cdr (car thread))))
+ gnus-tmp-gathered))
+ (setcdr (cdr (car thread)) nil))
+ (setq level -1))
+ ((eq gnus-summary-make-false-root 'empty)
+ ;; We print adopted articles with empty subject fields.
+ (setq gnus-tmp-gathered
+ (nconc (mapcar
+ (lambda (h) (mail-header-number (car h)))
+ (cdr (cdr (car thread))))
+ gnus-tmp-gathered))
+ (setq level -1))
+ ((eq gnus-summary-make-false-root 'dummy)
+ ;; We output a dummy root.
+ (gnus-summary-insert-dummy-line
+ nil header (mail-header-number
+ (car (car (cdr (car thread)))))))
+ (t
+ ;; We do not make a root for the gathered
+ ;; sub-threads at all.
+ (setq level -1))))
+
+ (setq number (mail-header-number header)
+ subject (mail-header-subject header))
+
+ ;; Do the async thing.
+ (and gnus-newsgroup-async
+ (setq gnus-newsgroup-threads
+ (cons (cons number (mail-header-lines header))
+ gnus-newsgroup-threads)))
+
+ ;; We may have to root out some bad articles...
+ (and cull
+ (= level 0)
+ (cond ((and (memq (setq number (mail-header-number header))
+ gnus-newsgroup-dormant)
+ (null thread))
+ (setq header nil))
+ ((and gnus-summary-expunge-below
+ (< (or (cdr (assq number gnus-newsgroup-scored))
+ gnus-summary-default-score 0)
+ gnus-summary-expunge-below))
+ (setq header nil)
+ (setq gnus-newsgroup-unreads
+ (delq number gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-reads
+ (cons (cons number gnus-low-score-mark)
+ gnus-newsgroup-reads)))))
+
+ (and
+ header
+ (progn
+ (inline
+ (gnus-summary-insert-line
+ nil header level nil
+ (cond
+ ((memq number gnus-newsgroup-marked) gnus-ticked-mark)
+ ((memq number gnus-newsgroup-dormant) gnus-dormant-mark)
+ ((memq number gnus-newsgroup-unreads) gnus-unread-mark)
+ ((memq number gnus-newsgroup-expirable) gnus-expirable-mark)
+ (t (or (cdr (assq number gnus-newsgroup-reads))
+ gnus-ancient-mark)))
+ (memq number gnus-newsgroup-replied)
+ (memq number gnus-newsgroup-expirable)
+ (cond
+ ((and gnus-thread-ignore-subject
+ (not (string=
+ (gnus-simplify-subject-re gnus-tmp-prev-subject)
+ (gnus-simplify-subject-re subject))))
+ subject)
+ ((zerop level)
+ (if (and (eq gnus-summary-make-false-root 'empty)
+ (memq number gnus-tmp-gathered))
+ gnus-summary-same-subject
+ subject))
+ (t gnus-summary-same-subject))
+ (and (eq gnus-summary-make-false-root 'adopt)
+ (memq number gnus-tmp-gathered))
+ (cdr (assq number gnus-newsgroup-scored))
+ (memq number gnus-newsgroup-processable))
+
+ (setq gnus-tmp-prev-subject subject)))))
+
+ (if (nth 1 thread)
+ (setq stack (cons (cons (max 0 level) (nthcdr 1 thread)) stack)))
+ (setq level (1+ level))
+ (setq threads (cdr (car thread))))))
+ (message "Generating summary...done"))
+
+
+
+(defun gnus-summary-prepare-unthreaded (headers &optional cull)
+ (let (header number)
+
+ ;; Do the async thing, if that is required.
+ (if gnus-newsgroup-async
+ (setq gnus-newsgroup-threads
+ (mapcar (lambda (h)
+ (cons (mail-header-number h) (mail-header-lines h)))
+ headers)))
+
+ (while headers
+ (setq header (car headers)
+ headers (cdr headers)
+ number (mail-header-number header))
+
+ ;; We may have to root out some bad articles...
+ (cond
+ ((and cull
+ (memq (setq number (mail-header-number header))
+ gnus-newsgroup-dormant)))
+ ((and cull gnus-summary-expunge-below
+ (< (or (cdr (assq number gnus-newsgroup-scored))
+ gnus-summary-default-score 0)
+ gnus-summary-expunge-below))
+ (setq gnus-newsgroup-unreads
+ (delq number gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-reads
+ (cons (cons number gnus-low-score-mark)
+ gnus-newsgroup-reads)))
+ (t
+ (gnus-summary-insert-line
+ nil header 0 nil
+ (cond ((memq number gnus-newsgroup-marked) gnus-ticked-mark)
+ ((memq number gnus-newsgroup-dormant) gnus-dormant-mark)
+ ((memq number gnus-newsgroup-unreads) gnus-unread-mark)
+ ((memq number gnus-newsgroup-expirable) gnus-expirable-mark)
+ (t (or (cdr (assq number gnus-newsgroup-reads))
+ gnus-ancient-mark)))
+ (memq number gnus-newsgroup-replied)
+ (memq number gnus-newsgroup-expirable)
+ (mail-header-subject header) nil
+ (cdr (assq number gnus-newsgroup-scored))
+ (memq number gnus-newsgroup-processable)))))))
+
+(defun gnus-select-newsgroup (group &optional read-all)
+ "Select newsgroup GROUP.
+If READ-ALL is non-nil, all articles in the group are selected."
+ (let* ((entry (gnus-gethash group gnus-newsrc-hashtb))
+ (info (nth 2 entry))
+ articles)
+
+ (or (gnus-check-server
+ (setq gnus-current-select-method (gnus-find-method-for-group group)))
+ (error "Couldn't open server"))
+
+ (or (and entry (not (eq (car entry) t))) ; Either it's active...
+ (gnus-activate-group group) ; Or we can activate it...
+ (progn ; Or we bug out.
+ (kill-buffer (current-buffer))
+ (error "Couldn't request group %s: %s"
+ group (gnus-status-message group))))
+
+ (setq gnus-newsgroup-name group)
+ (setq gnus-newsgroup-unselected nil)
+ (setq gnus-newsgroup-unreads (gnus-list-of-unread-articles group))
+
+ (and gnus-asynchronous
+ (gnus-check-backend-function
+ 'request-asynchronous gnus-newsgroup-name)
+ (setq gnus-newsgroup-async
+ (gnus-request-asynchronous gnus-newsgroup-name)))
+
+ (setq articles (gnus-articles-to-read group read-all))
+
+ (cond
+ ((null articles)
+ (gnus-message 3 "Couldn't select newsgroup")
+ 'quit)
+ ((eq articles 0) nil)
+ (t
+ ;; Init the dependencies hash table.
+ (setq gnus-newsgroup-dependencies
+ (gnus-make-hashtable (length articles)))
+ ;; Retrieve the headers and read them in.
+ (gnus-message 5 "Fetching headers...")
+ (setq gnus-newsgroup-headers
+ (if (eq 'nov (setq gnus-headers-retrieved-by
+ ;; This is a naughty hack. To get the
+ ;; retrieval of old headers to work, we
+ ;; set `nntp-nov-gap' to nil (locally),
+ ;; and then just retrieve the headers.
+ ;; Mucho magic.
+ (if gnus-fetch-old-headers
+ (let (nntp-nov-gap)
+ (gnus-retrieve-headers
+ (if (not (eq 1 (car articles)))
+ (cons 1 articles)
+ articles)
+ gnus-newsgroup-name))
+ (gnus-retrieve-headers
+ articles gnus-newsgroup-name))))
+ (progn
+ (gnus-get-newsgroup-headers-xover articles))
+ ;; If we were to fetch old headers, but the backend didn't
+ ;; support XOVER, then it is possible we fetched one article
+ ;; that we shouldn't have. If that's the case, we remove it.
+ (if (or (not gnus-fetch-old-headers)
+ (eq 1 (car articles)))
+ ()
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (and
+ (looking-at "[0-9]+[ \t]+1[ \t]") ; This is not a NOV line.
+ (delete-region ; So we delete this head.
+ (point)
+ (search-forward "\n.\n" nil t)))))
+ (gnus-get-newsgroup-headers)))
+ (gnus-message 5 "Fetching headers...done")
+ ;; Remove canceled articles from the list of unread articles.
+ (setq gnus-newsgroup-unreads
+ (gnus-set-sorted-intersection
+ gnus-newsgroup-unreads
+ (mapcar (lambda (headers) (mail-header-number headers))
+ gnus-newsgroup-headers)))
+ ;; Adjust and set lists of article marks.
+ (and info
+ (let (marked)
+ (gnus-adjust-marked-articles info)
+ (setq gnus-newsgroup-marked
+ (copy-sequence
+ (cdr (assq 'tick (setq marked (nth 3 info))))))
+ (setq gnus-newsgroup-replied
+ (copy-sequence (cdr (assq 'reply marked))))
+ (setq gnus-newsgroup-expirable
+ (copy-sequence (cdr (assq 'expire marked))))
+ (setq gnus-newsgroup-killed
+ (copy-sequence (cdr (assq 'killed marked))))
+ (setq gnus-newsgroup-bookmarks
+ (copy-sequence (cdr (assq 'bookmark marked))))
+ (setq gnus-newsgroup-dormant
+ (copy-sequence (cdr (assq 'dormant marked))))
+ (setq gnus-newsgroup-scored
+ (copy-sequence (cdr (assq 'score marked))))
+ (setq gnus-newsgroup-processable nil)))
+ ;; Check whether auto-expire is to be done in this group.
+ (setq gnus-newsgroup-auto-expire
+ (or (and (stringp gnus-auto-expirable-newsgroups)
+ (string-match gnus-auto-expirable-newsgroups group))
+ (memq 'auto-expire (nth 5 info))))
+ ;; First and last article in this newsgroup.
+ (and gnus-newsgroup-headers
+ (setq gnus-newsgroup-begin
+ (mail-header-number (car gnus-newsgroup-headers)))
+ (setq gnus-newsgroup-end
+ (mail-header-number
+ (gnus-last-element gnus-newsgroup-headers))))
+ (setq gnus-reffed-article-number -1)
+ ;; GROUP is successfully selected.
+ (or gnus-newsgroup-headers t)))))
+
+(defun gnus-articles-to-read (group read-all)
+ ;; Find out what articles the user wants to read.
+ (let* ((articles
+ ;; Select all articles if `read-all' is non-nil, or if all the
+ ;; unread articles are dormant articles.
+ (if (or read-all
+ (= (length gnus-newsgroup-unreads)
+ (length gnus-newsgroup-dormant)))
+ (gnus-uncompress-range
+ (gnus-gethash group gnus-active-hashtb))
+ gnus-newsgroup-unreads))
+ (scored-list (gnus-killed-articles gnus-newsgroup-killed articles))
+ (scored (length scored-list))
+ (number (length articles))
+ (marked (+ (length gnus-newsgroup-marked)
+ (length gnus-newsgroup-dormant)))
+ (select
+ (cond
+ ((numberp read-all)
+ read-all)
+ (t
+ (condition-case ()
+ (cond ((and (or (<= scored marked)
+ (= scored number))
+ (numberp gnus-large-newsgroup)
+ (> number gnus-large-newsgroup))
+ (let ((input
+ (read-string
+ (format
+ "How many articles from %s (default %d): "
+ gnus-newsgroup-name number))))
+ (if (string-match "^[ \t]*$" input)
+ number input)))
+ ((and (> scored marked) (< scored number))
+ (let ((input
+ (read-string
+ (format
+ "%s %s (%d scored, %d total): "
+ "How many articles from"
+ group scored number))))
+ (if (string-match "^[ \t]*$" input)
+ number input)))
+ (t number))
+ (quit nil))))))
+ (setq select (if (stringp select) (string-to-number select) select))
+ (if (or (null select) (zerop select))
+ select
+ (if (and (not (zerop scored)) (<= (abs select) scored))
+ (progn
+ (setq articles (sort scored-list '<))
+ (setq number (length articles)))
+ (setq articles (copy-sequence articles)))
+
+ (if (< (abs select) number)
+ (if (< select 0)
+ ;; Select the N oldest articles.
+ (setcdr (nthcdr (1- (abs select)) articles) nil)
+ ;; Select the N most recent articles.
+ (setq articles (nthcdr (- number select) articles))))
+ (setq gnus-newsgroup-unselected
+ (gnus-sorted-intersection
+ gnus-newsgroup-unreads
+ (gnus-sorted-complement gnus-newsgroup-unreads articles)))
+ articles)))
+
+(defun gnus-killed-articles (killed articles)
+ (let (out)
+ (while articles
+ (if (inline (gnus-member-of-range (car articles) killed))
+ (setq out (cons (car articles) out)))
+ (setq articles (cdr articles)))
+ out))
+
+(defun gnus-adjust-marked-articles (info &optional active)
+ "Remove all marked articles that are no longer legal."
+ (let ((marked-lists (nth 3 info))
+ (active (or active (gnus-gethash (car info) gnus-active-hashtb)))
+ m prev)
+ ;; There are many types of marked articles.
+ (while marked-lists
+ (setq m (cdr (setq prev (car marked-lists))))
+ (cond ((or (eq 'tick (car prev)) (eq 'dormant (car prev)))
+ ;; Make sure that all ticked articles are a subset of the
+ ;; unread/unselected articles.
+ (while m
+ (if (or (memq (car m) gnus-newsgroup-unreads)
+ (memq (car m) gnus-newsgroup-unselected))
+ (setq prev m)
+ (setcdr prev (cdr m)))
+ (setq m (cdr m))))
+ ((eq 'score (car prev))
+ ;; Scored articles should be a subset of
+ ;; unread/unselected articles.
+ (while m
+ (if (or (memq (car (car m)) gnus-newsgroup-unreads)
+ (memq (car (car m)) gnus-newsgroup-unreads))
+ (setq prev m)
+ (setcdr prev (cdr m)))
+ (setq m (cdr m))))
+ ((eq 'bookmark (car prev))
+ ;; Bookmarks should be a subset of active articles.
+ (while m
+ (if (< (car (car m)) (car active))
+ (setcdr prev (cdr m))
+ (setq prev m))
+ (setq m (cdr m))))
+ ((eq 'killed (car prev))
+ ;; Articles that have been through the kill process are
+ ;; to be a subset of active articles.
+ (while (and m (< (or (and (numberp (car m)) (car m))
+ (cdr (car m)))
+ (car active)))
+ (setcdr prev (cdr m))
+ (setq m (cdr m)))
+ (if (and m (< (or (and (numberp (car m)) (car m))
+ (car (car m)))
+ (car active)))
+ (setcar (if (numberp (car m)) m (car m)) (car active))))
+ ((or (eq 'reply (car prev)) (eq 'expire (car prev)))
+ ;; The replied and expirable articles have to be articles
+ ;; that are active.
+ (while m
+ (if (< (car m) (car active))
+ (setcdr prev (cdr m))
+ (setq prev m))
+ (setq m (cdr m)))))
+ (setq marked-lists (cdr marked-lists)))
+ ;; Remove all lists that are empty.
+ (setq marked-lists (nth 3 info))
+ (if marked-lists
+ (progn
+ (while (= 1 (length (car marked-lists)))
+ (setq marked-lists (cdr marked-lists)))
+ (setq m (cdr (setq prev marked-lists)))
+ (while m
+ (if (= 1 (length (car m)))
+ (setcdr prev (cdr m))
+ (setq prev m))
+ (setq m (cdr m)))
+ (setcar (nthcdr 3 info) marked-lists)))
+ ;; Finally, if there are no marked lists at all left, and if there
+ ;; are no elements after the lists in the info list, we just chop
+ ;; the info list off before the marked lists.
+ (and (null marked-lists)
+ (not (nthcdr 4 info))
+ (setcdr (nthcdr 2 info) nil)))
+ info)
+
+(defun gnus-set-marked-articles
+ (info ticked replied expirable killed dormant bookmark score)
+ "Enter the various lists of marked articles into the newsgroup info list."
+ (let (newmarked)
+ (and ticked (setq newmarked (cons (cons 'tick ticked) nil)))
+ (and replied (setq newmarked (cons (cons 'reply replied) newmarked)))
+ (and expirable (setq newmarked (cons (cons 'expire expirable)
+ newmarked)))
+ (and killed (setq newmarked (cons (cons 'killed killed) newmarked)))
+ (and dormant (setq newmarked (cons (cons 'dormant dormant) newmarked)))
+ (and bookmark (setq newmarked (cons (cons 'bookmark bookmark)
+ newmarked)))
+ (and score (setq newmarked (cons (cons 'score score) newmarked)))
+ (if (nthcdr 3 info)
+ (progn
+ (setcar (nthcdr 3 info) newmarked)
+ (and (not newmarked)
+ (not (nthcdr 4 info))
+ (setcdr (nthcdr 2 info) nil)))
+ (if newmarked
+ (setcdr (nthcdr 2 info) (list newmarked))))))
+
+(defun gnus-add-marked-articles (group type articles &optional info force)
+ ;; Add ARTICLES of TYPE to the info of GROUP.
+ ;; If INFO is non-nil, use that info. If FORCE is non-nil, don't
+ ;; add, but replace marked articles of TYPE with ARTICLES.
+ (let ((info (or info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))))
+ marked m)
+ (or (not info)
+ (and (not (setq marked (nthcdr 3 info)))
+ (setcdr (nthcdr 2 info) (list (list (cons type articles)))))
+ (and (not (setq m (assq type (car marked))))
+ (setcar marked (cons (cons type articles) (car marked))))
+ (if force
+ (setcdr m articles)
+ (nconc m articles)))))
+
+(defun gnus-set-mode-line (where)
+ "This function sets the mode line of the article or summary buffers.
+If WHERE is `summary', the summary mode line format will be used."
+ (if (memq where gnus-updated-mode-lines)
+ (let (mode-string)
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (let* ((mformat (if (eq where 'article)
+ gnus-article-mode-line-format-spec
+ gnus-summary-mode-line-format-spec))
+ (group-name gnus-newsgroup-name)
+ (article-number (or gnus-current-article 0))
+ (unread (- (length gnus-newsgroup-unreads)
+ (length gnus-newsgroup-dormant)))
+ (unread-and-unticked
+ (- unread (length gnus-newsgroup-marked)))
+ (unselected (length gnus-newsgroup-unselected))
+ (unread-and-unselected
+ (cond ((and (zerop unread-and-unticked)
+ (zerop unselected)) "")
+ ((zerop unselected)
+ (format "{%d more}" unread-and-unticked))
+ (t (format "{%d(+%d) more}"
+ unread-and-unticked unselected))))
+ (subject
+ (if gnus-current-headers
+ (mail-header-subject gnus-current-headers) ""))
+ (max-len (and gnus-mode-non-string-length
+ (- (frame-width) gnus-mode-non-string-length)))
+ header);; passed as argument to any user-format-funcs
+ (setq mode-string (eval mformat))
+ (or (numberp max-len)
+ (setq max-len (length mode-string)))
+ (if (< max-len 4) (setq max-len 4))
+ (if (> (length mode-string) max-len)
+ ;; modified by MORIOKA Tomohiko <morioka@jaist.ac.jp>
+ ;; function `substring' might cut on a middle
+ ;; of multi-octet character.
+ (setq mode-string
+ (concat (gnus-truncate-string mode-string (- max-len 3))
+ "...")))
+ (setq mode-string (format (format "%%-%ds" max-len)
+ mode-string))))
+ (setq mode-line-buffer-identification mode-string)
+ (set-buffer-modified-p t))))
+
+(defun gnus-create-xref-hashtb (from-newsgroup headers unreads)
+ "Go through the HEADERS list and add all Xrefs to a hash table.
+The resulting hash table is returned, or nil if no Xrefs were found."
+ (let* ((from-method (gnus-find-method-for-group from-newsgroup))
+ (prefix (if (and
+ (gnus-group-foreign-p from-newsgroup)
+ (not (memq 'virtual
+ (assoc (symbol-name (car from-method))
+ gnus-valid-select-methods))))
+ (gnus-group-real-prefix from-newsgroup)))
+ (xref-hashtb (make-vector 63 0))
+ start group entry number xrefs header)
+ (while headers
+ (setq header (car headers))
+ (if (and (setq xrefs (mail-header-xref header))
+ (not (memq (mail-header-number header) unreads)))
+ (progn
+ (setq start 0)
+ (while (string-match "\\([^ ]+\\):\\([0-9]+\\)" xrefs start)
+ (setq start (match-end 0))
+ (setq group (concat prefix (substring xrefs (match-beginning 1)
+ (match-end 1))))
+ (setq number
+ (string-to-int (substring xrefs (match-beginning 2)
+ (match-end 2))))
+ (if (setq entry (gnus-gethash group xref-hashtb))
+ (setcdr entry (cons number (cdr entry)))
+ (gnus-sethash group (cons number nil) xref-hashtb)))))
+ (setq headers (cdr headers)))
+ (if start xref-hashtb nil)))
+
+(defun gnus-mark-xrefs-as-read (from-newsgroup headers unreads expirable)
+ "Look through all the headers and mark the Xrefs as read."
+ (let ((virtual (memq 'virtual
+ (assoc (symbol-name (car (gnus-find-method-for-group
+ from-newsgroup)))
+ gnus-valid-select-methods)))
+ name entry info xref-hashtb idlist method
+ nth4)
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (if (setq xref-hashtb
+ (gnus-create-xref-hashtb from-newsgroup headers unreads))
+ (mapatoms
+ (lambda (group)
+ (if (string= from-newsgroup (setq name (symbol-name group)))
+ ()
+ (setq idlist (symbol-value group))
+ ;; Dead groups are not updated.
+ (if (and (prog1
+ (setq entry (gnus-gethash name gnus-newsrc-hashtb)
+ info (nth 2 entry))
+ (if (stringp (setq nth4 (nth 4 info)))
+ (setq nth4 (gnus-server-to-method nth4))))
+ ;; Only do the xrefs if the group has the same
+ ;; select method as the group we have just read.
+ (or (gnus-methods-equal-p
+ nth4 (gnus-find-method-for-group from-newsgroup))
+ virtual
+ (equal nth4
+ (setq method (gnus-find-method-for-group
+ from-newsgroup)))
+ (and (equal (car nth4) (car method))
+ (equal (nth 1 nth4) (nth 1 method))))
+ gnus-use-cross-reference
+ (or (not (eq gnus-use-cross-reference t))
+ virtual
+ ;; Only do cross-references on subscribed
+ ;; groups, if that is what is wanted.
+ (<= (nth 1 info) gnus-level-subscribed)))
+ (gnus-group-make-articles-read name idlist expirable))))
+ xref-hashtb)))))
+
+(defun gnus-group-make-articles-read (group articles expirable)
+ (let* ((num 0)
+ (entry (gnus-gethash group gnus-newsrc-hashtb))
+ (info (nth 2 entry))
+ (active (gnus-gethash group gnus-active-hashtb))
+ exps expirable range)
+ ;; First peel off all illegal article numbers.
+ (if active
+ (let ((ids articles)
+ (ticked (cdr (assq 'tick (nth 3 info))))
+ (dormant (cdr (assq 'dormant (nth 3 info))))
+ id first)
+ (setq exps nil)
+ (while ids
+ (setq id (car ids))
+ (if (and first (> id (cdr active)))
+ (progn
+ ;; We'll end up in this situation in one particular
+ ;; obscure situation. If you re-scan a group and get
+ ;; a new article that is cross-posted to a different
+ ;; group that has not been re-scanned, you might get
+ ;; crossposted article that has a higher number than
+ ;; Gnus believes possible. So we re-activate this
+ ;; group as well. This might mean doing the
+ ;; crossposting thingie will *increase* the number
+ ;; of articles in some groups. Tsk, tsk.
+ (setq active (or (gnus-activate-group group) active))))
+ (if (or (> id (cdr active))
+ (< id (car active))
+ (memq id ticked)
+ (memq id dormant))
+ (setq articles (delq id articles)))
+ (and (memq id expirable)
+ (setq exps (cons id exps)))
+ (setq ids (cdr ids)))))
+ ;; Update expirable articles.
+ (gnus-add-marked-articles nil 'expirable exps info)
+ (and active
+ (null (nth 2 info))
+ (> (car active) 1)
+ (setcar (nthcdr 2 info) (cons 1 (1- (car active)))))
+ (setcar (nthcdr 2 info)
+ (setq range
+ (gnus-add-to-range
+ (nth 2 info)
+ (setq articles (sort articles '<)))))
+ ;; Then we have to re-compute how many unread
+ ;; articles there are in this group.
+ (if active
+ (progn
+ (cond
+ ((not range)
+ (setq num (- (1+ (cdr active)) (car active))))
+ ((not (listp (cdr range)))
+ (setq num (- (cdr active) (- (1+ (cdr range))
+ (car range)))))
+ (t
+ (while range
+ (if (numberp (car range))
+ (setq num (1+ num))
+ (setq num (+ num (- (1+ (cdr (car range)))
+ (car (car range))))))
+ (setq range (cdr range)))
+ (setq num (- (cdr active) num))))
+ ;; Update the number of unread articles.
+ (setcar
+ entry
+ (max 0 (- num
+ (length (cdr (assq 'tick (nth 3 info))))
+ (length
+ (cdr (assq 'dormant (nth 3 info)))))))
+ ;; Update the group buffer.
+ (gnus-group-update-group group t)))))
+
+(defun gnus-methods-equal-p (m1 m2)
+ (let ((m1 (or m1 gnus-select-method))
+ (m2 (or m2 gnus-select-method)))
+ (or (equal m1 m2)
+ (and (eq (car m1) (car m2))
+ (or (not (memq 'address (assoc (symbol-name (car m1))
+ gnus-valid-select-methods)))
+ (equal (nth 1 m1) (nth 1 m2)))))))
+
+(defsubst gnus-header-value ()
+ (buffer-substring (match-end 0) (gnus-point-at-eol)))
+
+(defvar gnus-newsgroup-none-id 0)
+
+(defun gnus-get-newsgroup-headers ()
+ (setq gnus-article-internal-prepare-hook nil)
+ (let ((cur nntp-server-buffer)
+ (dependencies gnus-newsgroup-dependencies)
+ headers id dep end ref)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ ;; Search to the beginning of the next header. Error messages
+ ;; do not begin with 2 or 3.
+ (while (re-search-forward "^[23][0-9]+ " nil t)
+ (let ((header (make-vector 9 nil))
+ (case-fold-search t)
+ (p (point))
+ in-reply-to)
+ (setq id nil
+ ref nil)
+ (mail-header-set-number header (read cur))
+ ;; 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
+ ;; doesn't always come hand in hand.
+ (save-restriction
+ (narrow-to-region (point) (or (save-excursion
+ (search-forward "\n.\n" nil t))
+ (point)))
+ (if (search-forward "\nfrom: " nil t)
+ (mail-header-set-from header (gnus-header-value))
+ (mail-header-set-from header "(nobody)"))
+ (goto-char p)
+ (if (search-forward "\nsubject: " nil t)
+ (mail-header-set-subject header (gnus-header-value))
+ (mail-header-set-subject header "(none)"))
+ (goto-char p)
+ (and (search-forward "\nxref: " nil t)
+ (mail-header-set-xref header (gnus-header-value)))
+ (goto-char p)
+ (or (numberp (and (search-forward "\nlines: " nil t)
+ (mail-header-set-lines header (read cur))))
+ (mail-header-set-lines header 0))
+ (goto-char p)
+ (and (search-forward "\ndate: " nil t)
+ (mail-header-set-date header (gnus-header-value)))
+ (goto-char p)
+ (if (search-forward "\nmessage-id: " nil t)
+ (mail-header-set-id header (setq id (gnus-header-value)))
+ ;; If there was no message-id, we just fake one to make
+ ;; subsequent routines simpler.
+ (mail-header-set-id
+ header
+ (setq id (concat "none+"
+ (int-to-string
+ (setq gnus-newsgroup-none-id
+ (1+ gnus-newsgroup-none-id)))))))
+ (goto-char p)
+ (if (search-forward "\nreferences: " nil t)
+ (progn
+ (mail-header-set-references header (gnus-header-value))
+ (setq end (match-end 0))
+ (save-excursion
+ (setq ref
+ (downcase
+ (buffer-substring
+ (progn
+ (end-of-line)
+ (search-backward ">" end t)
+ (1+ (point)))
+ (progn
+ (search-backward "<" end t)
+ (point)))))))
+ ;; Get the references from the in-reply-to header if there
+ ;; ware no references and the in-reply-to header looks
+ ;; promising.
+ (if (and (search-forward "\nin-reply-to: " nil t)
+ (setq in-reply-to (gnus-header-value))
+ (string-match "<[^>]+>" in-reply-to))
+ (progn
+ (mail-header-set-references
+ header
+ (setq ref (substring in-reply-to (match-beginning 0)
+ (match-end 0))))
+ (setq ref (downcase ref)))
+ (setq ref "none")))
+ ;; We do some threading while we read the headers. The
+ ;; message-id and the last reference are both entered into
+ ;; the same hash table. Some tippy-toeing around has to be
+ ;; done in case an article has arrived before the article
+ ;; which it refers to.
+ (if (boundp (setq dep (intern (downcase id) dependencies)))
+ (if (car (symbol-value dep))
+ ;; An article with this Message-ID has already
+ ;; been seen, so we ignore this one, except we add
+ ;; any additional Xrefs (in case the two articles
+ ;; came from different servers.
+ (progn
+ (mail-header-set-xref
+ (car (symbol-value dep))
+ (concat (or (mail-header-xref
+ (car (symbol-value dep))) "")
+ (or (mail-header-xref header) "")))
+ (setq header nil))
+ (setcar (symbol-value dep) header))
+ (set dep (list header)))
+ (if header
+ (progn
+ (if (boundp (setq dep (intern ref dependencies)))
+ (setcdr (symbol-value dep)
+ (cons header (cdr (symbol-value dep))))
+ (set dep (list nil header)))
+ (setq headers (cons header headers))))
+ (goto-char (point-max))))))
+ (nreverse headers)))
+
+;; The following macros and functions were written by Felix Lee
+;; <flee@cse.psu.edu>.
+
+(defmacro gnus-nov-read-integer ()
+ '(prog1
+ (if (= (following-char) ?\t)
+ 0
+ (let ((num (condition-case nil (read buffer) (error nil))))
+ (if (numberp num) num 0)))
+ (or (eobp) (forward-char 1))))
+
+(defmacro gnus-nov-skip-field ()
+ '(search-forward "\t" eol 'move))
+
+(defmacro gnus-nov-field ()
+ '(buffer-substring (point) (if (gnus-nov-skip-field) (1- (point)) eol)))
+
+;; Goes through the xover lines and returns a list of vectors
+(defun gnus-get-newsgroup-headers-xover (sequence)
+ "Parse the news overview data in the server buffer, and return a
+list of headers that match SEQUENCE (see `nntp-retrieve-headers')."
+ ;; Get the Xref when the users reads the articles since most/some
+ ;; NNTP servers do not include Xrefs when using XOVER.
+ (setq gnus-article-internal-prepare-hook '(gnus-article-get-xrefs))
+ (let ((cur nntp-server-buffer)
+ (dependencies gnus-newsgroup-dependencies)
+ number headers header)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (while (and sequence (not (eobp)))
+ (setq number (read cur))
+ (while (and sequence (< (car sequence) number))
+ (setq sequence (cdr sequence)))
+ (and sequence
+ (eq number (car sequence))
+ (progn
+ (setq sequence (cdr sequence))
+ (if (setq header
+ (inline (gnus-nov-parse-line number dependencies)))
+ (setq headers (cons header headers)))))
+ (forward-line 1))
+ (setq headers (nreverse headers)))
+ headers))
+
+;; This function has to be called with point after the article number
+;; on the beginning of the line.
+(defun gnus-nov-parse-line (number dependencies)
+ (let ((none 0)
+ (eol (gnus-point-at-eol))
+ (buffer (current-buffer))
+ header ref id dep)
+
+ ;; overview: [num subject from date id refs chars lines misc]
+ (narrow-to-region (point) eol)
+ (or (eobp) (forward-char))
+
+ (condition-case nil
+ (setq header
+ (vector
+ number ; number
+ (gnus-nov-field) ; subject
+ (gnus-nov-field) ; from
+ (gnus-nov-field) ; date
+ (setq id (or (gnus-nov-field)
+ (concat "none+"
+ (int-to-string
+ (setq none (1+ none)))))) ; id
+ (progn
+ (save-excursion
+ (let ((beg (point)))
+ (search-forward "\t" eol)
+ (if (search-backward ">" beg t)
+ (setq ref
+ (downcase
+ (buffer-substring
+ (1+ (point))
+ (progn
+ (search-backward "<" beg t)
+ (point)))))
+ (setq ref nil))))
+ (gnus-nov-field)) ; refs
+ (gnus-nov-read-integer) ; chars
+ (gnus-nov-read-integer) ; lines
+ (if (= (following-char) ?\n)
+ nil
+ (gnus-nov-field)) ; misc
+ ))
+ (error (progn
+ (ding)
+ (message "Strange nov line.")
+ (setq header nil)
+ (goto-char eol))))
+
+ (widen)
+
+ ;; We build the thread tree.
+ (and header
+ (if (boundp (setq dep (intern (downcase id) dependencies)))
+ (if (car (symbol-value dep))
+ ;; An article with this Message-ID has already been seen,
+ ;; so we ignore this one, except we add any additional
+ ;; Xrefs (in case the two articles came from different
+ ;; servers.
+ (progn
+ (mail-header-set-xref
+ (car (symbol-value dep))
+ (concat (or (mail-header-xref (car (symbol-value dep))) "")
+ (or (mail-header-xref header) "")))
+ (setq header nil))
+ (setcar (symbol-value dep) header))
+ (set dep (list header))))
+ (if header
+ (progn
+ (if (boundp (setq dep (intern (or ref "none")
+ dependencies)))
+ (setcdr (symbol-value dep)
+ (cons header (cdr (symbol-value dep))))
+ (set dep (list nil header)))))
+ header))
+
+(defun gnus-article-get-xrefs ()
+ "Fill in the Xref value in `gnus-current-headers', if necessary.
+This is meant to be called in `gnus-article-internal-prepare-hook'."
+ (let ((headers (save-excursion (set-buffer gnus-summary-buffer)
+ gnus-current-headers)))
+ (or (not gnus-use-cross-reference)
+ (not headers)
+ (and (mail-header-xref headers)
+ (not (string= (mail-header-xref headers) "")))
+ (let ((case-fold-search t)
+ xref)
+ (save-restriction
+ (gnus-narrow-to-headers)
+ (goto-char (point-min))
+ (if (or (and (eq (downcase (following-char)) ?x)
+ (looking-at "Xref:"))
+ (search-forward "\nXref:" nil t))
+ (progn
+ (goto-char (1+ (match-end 0)))
+ (setq xref (buffer-substring (point)
+ (progn (end-of-line) (point))))
+ (mail-header-set-xref headers xref))))))))
+
+(defalias 'gnus-find-header-by-number 'gnus-get-header-by-number)
+(make-obsolete 'gnus-find-header-by-number 'gnus-get-header-by-number)
+
+(defun gnus-make-headers-hashtable-by-number ()
+ "Make hashtable for the variable gnus-newsgroup-headers by number."
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (let ((headers gnus-newsgroup-headers)
+ header)
+ (setq gnus-newsgroup-headers-hashtb-by-number
+ (gnus-make-hashtable (length headers)))
+ (while headers
+ (setq header (car headers))
+ (gnus-sethash (int-to-string (mail-header-number header))
+ header gnus-newsgroup-headers-hashtb-by-number)
+ (setq headers (cdr headers))))))
+
+(defun gnus-more-header-backward ()
+ "Find new header backward."
+ (let ((first (car (gnus-gethash gnus-newsgroup-name gnus-active-hashtb)))
+ (artnum gnus-newsgroup-begin)
+ (header nil))
+ (while (and (not header)
+ (> artnum first))
+ (setq artnum (1- artnum))
+ (setq header (gnus-read-header artnum)))
+ header))
+
+(defun gnus-more-header-forward (&optional backward)
+ "Find new header forward.
+If BACKWARD, find new header backward instead."
+ (if backward
+ (gnus-more-header-backward)
+ (let ((last (cdr (gnus-gethash gnus-newsgroup-name gnus-active-hashtb)))
+ (artnum gnus-newsgroup-end)
+ (header nil))
+ (while (and (not header)
+ (< artnum last))
+ (setq artnum (1+ artnum))
+ (setq header (gnus-read-header artnum)))
+ header)))
+
+(defun gnus-extend-newsgroup (header &optional backward)
+ "Extend newsgroup selection with HEADER.
+Optional argument BACKWARD means extend toward backward."
+ (if header
+ (let ((artnum (mail-header-number header)))
+ (setq gnus-newsgroup-headers
+ (if backward
+ (cons header gnus-newsgroup-headers)
+ (nconc gnus-newsgroup-headers (list header))))
+ (setq gnus-newsgroup-unselected
+ (delq artnum gnus-newsgroup-unselected))
+ (setq gnus-newsgroup-begin (min gnus-newsgroup-begin artnum))
+ (setq gnus-newsgroup-end (max gnus-newsgroup-end artnum)))))
+
+(defun gnus-summary-work-articles (n)
+ "Return a list of articles to be worked upon. The prefix argument,
+the list of process marked articles, and the current article will be
+taken into consideration."
+ (let (articles)
+ (if (and n (numberp n))
+ (let ((backward (< n 0))
+ (n (abs n)))
+ (save-excursion
+ (while (and (> n 0)
+ (setq articles (cons (gnus-summary-article-number)
+ articles))
+ (gnus-summary-search-forward nil nil backward))
+ (setq n (1- n))))
+ (sort articles (function <)))
+ (or (reverse gnus-newsgroup-processable)
+ (list (gnus-summary-article-number))))))
+
+(defun gnus-summary-search-group (&optional backward use-level)
+ "Search for next unread newsgroup.
+If optional argument BACKWARD is non-nil, search backward instead."
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (if (gnus-group-search-forward
+ backward nil (if use-level (gnus-group-group-level) nil))
+ (gnus-group-group-name))))
+
+(defun gnus-summary-best-group (&optional exclude-group)
+ "Find the name of the best unread group.
+If EXCLUDE-GROUP, do not go to this group."
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (save-excursion
+ (gnus-group-best-unread-group exclude-group))))
+
+(defun gnus-subject-equal (s1 s2)
+ (cond
+ ((null gnus-summary-gather-subject-limit)
+ (equal (gnus-simplify-subject-re s1)
+ (gnus-simplify-subject-re s2)))
+ ((eq gnus-summary-gather-subject-limit 'fuzzy)
+ (equal (gnus-simplify-subject-fuzzy s1)
+ (gnus-simplify-subject-fuzzy s2)))
+ ((numberp gnus-summary-gather-subject-limit)
+ (equal (gnus-limit-string s1 gnus-summary-gather-subject-limit)
+ (gnus-limit-string s2 gnus-summary-gather-subject-limit)))
+ (t
+ (equal s1 s2))))
+
+(defun gnus-summary-search-subject (&optional backward unread subject)
+ "Search for article forward.
+If BACKWARD is non-nil, search backward.
+If UNREAD is non-nil, only unread articles are selected.
+If SUBJECT is non-nil, the article which has the same subject will be
+searched for."
+ (let ((func (if backward 'previous-single-property-change
+ 'next-single-property-change))
+ (beg (point))
+ (did t)
+ pos psubject)
+ (beginning-of-line)
+ (and gnus-summary-check-current unread
+ (eq (get-text-property (point) 'gnus-mark) gnus-unread-mark)
+ (setq did nil))
+ (if (not did)
+ ()
+ (forward-char (if backward (if (bobp) 0 -1) (if (eobp) 0 1)))
+ (while
+ (and
+ (setq pos (funcall func (point) 'gnus-number))
+ (goto-char (if backward (1- pos) pos))
+ (setq did
+ (not (and
+ (or (not unread)
+ (eq (get-text-property (point) 'gnus-mark)
+ gnus-unread-mark))
+ (or (not subject)
+ (and (setq psubject
+ (inline (gnus-summary-subject-string)))
+ (inline
+ (gnus-subject-equal subject psubject)))))))
+ (if backward (if (bobp) nil (forward-char -1) t)
+ (if (eobp) nil (forward-char 1) t)))))
+ (if did
+ (progn (goto-char beg) nil)
+ (prog1
+ (get-text-property (point) 'gnus-number)
+ (gnus-summary-show-thread)
+ (gnus-summary-position-cursor)))))
+
+(defun gnus-summary-pseudo-article ()
+ "The thread level of the article on the current line."
+ (get-text-property (gnus-point-at-bol) 'gnus-pseudo))
+
+(defalias 'gnus-summary-score 'gnus-summary-article-score)
+(make-obsolete 'gnus-summary-score 'gnus-summary-article-score)
+(defun gnus-summary-article-score ()
+ "Return current article score."
+ (or (cdr (assq (gnus-summary-article-number) gnus-newsgroup-scored))
+ gnus-summary-default-score 0))
+
+(defun gnus-summary-recenter ()
+ "Center point in the summary window.
+If `gnus-auto-center-summary' is nil, or the article buffer isn't
+displayed, no centering will be performed."
+ ;; Suggested by earle@mahendo.JPL.NASA.GOV (Greg Earle).
+ ;; Recenter only when requested. Suggested by popovich@park.cs.columbia.edu.
+ (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)))
+ (window (get-buffer-window (current-buffer))))
+ (and
+ ;; The user has to want it,
+ gnus-auto-center-summary
+ ;; the article buffer must be displayed,
+ (get-buffer-window gnus-article-buffer)
+ ;; 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
+ window (min bottom (save-excursion (forward-line (- top)) (point)))))))
+
+;; Function written by Stainless Steel Rat <ratinox@ccs.neu.edu>.
+(defun gnus-short-group-name (group &optional levels)
+ "Collapse GROUP name LEVELS."
+ (let* ((name "") (foreign "") (depth -1) (skip 1)
+ (levels (or levels
+ (progn
+ (while (string-match "\\." group skip)
+ (setq skip (match-end 0)
+ depth (+ depth 1)))
+ depth))))
+ (if (string-match ":" group)
+ (setq foreign (substring group 0 (match-end 0))
+ group (substring group (match-end 0))))
+ (while group
+ (if (and (string-match "\\." group) (> levels 0))
+ (setq name (concat name (substring group 0 1))
+ group (substring group (match-end 0))
+ levels (- levels 1)
+ name (concat name "."))
+ (setq name (concat foreign name group)
+ group nil)))
+ name))
+
+(defun gnus-summary-jump-to-group (newsgroup)
+ "Move point to NEWSGROUP in group mode buffer."
+ ;; Keep update point of group mode buffer if visible.
+ (if (eq (current-buffer) (get-buffer gnus-group-buffer))
+ (save-window-excursion
+ ;; Take care of tree window mode.
+ (if (get-buffer-window gnus-group-buffer)
+ (pop-to-buffer gnus-group-buffer))
+ (gnus-group-jump-to-group newsgroup))
+ (save-excursion
+ ;; Take care of tree window mode.
+ (if (get-buffer-window gnus-group-buffer)
+ (pop-to-buffer gnus-group-buffer)
+ (set-buffer gnus-group-buffer))
+ (gnus-group-jump-to-group newsgroup))))
+
+;; This function returns a list of article numbers based on the
+;; difference between the ranges of read articles in this group and
+;; the range of active articles.
+(defun gnus-list-of-unread-articles (group)
+ (let* ((read (nth 2 (nth 2 (gnus-gethash group gnus-newsrc-hashtb))))
+ (active (gnus-gethash group gnus-active-hashtb))
+ (last (cdr active))
+ first nlast unread)
+ ;; If none are read, then all are unread.
+ (if (not read)
+ (setq first (car active))
+ ;; If the range of read articles is a single range, then the
+ ;; first unread article is the article after the last read
+ ;; article. Sounds logical, doesn't it?
+ (if (not (listp (cdr read)))
+ (setq first (1+ (cdr read)))
+ ;; `read' is a list of ranges.
+ (if (/= (setq nlast (or (and (numberp (car read)) (car read))
+ (car (car read)))) 1)
+ (setq first 1))
+ (while read
+ (if first
+ (while (< first nlast)
+ (setq unread (cons first unread))
+ (setq first (1+ first))))
+ (setq first (1+ (if (atom (car read)) (car read) (cdr (car read)))))
+ (setq nlast (if (atom (car (cdr read)))
+ (car (cdr read))
+ (car (car (cdr read)))))
+ (setq read (cdr read)))))
+ ;; And add the last unread articles.
+ (while (<= first last)
+ (setq unread (cons first unread))
+ (setq first (1+ first)))
+ ;; Return the list of unread articles.
+ (nreverse unread)))
+
+(defun gnus-list-of-read-articles (group)
+ (let ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
+ (active (gnus-gethash group gnus-active-hashtb)))
+ (and info active
+ (gnus-sorted-complement
+ (gnus-uncompress-range active)
+ (gnus-list-of-unread-articles group)))))
+
+;; Various summary commands
+
+(defun gnus-summary-universal-argument ()
+ "Perform any operation on all articles marked with the process mark."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((articles (reverse gnus-newsgroup-processable))
+ func)
+ (or articles (error "No articles marked"))
+ (or (setq func (key-binding (read-key-sequence "C-c C-u")))
+ (error "Undefined key"))
+ (while articles
+ (gnus-summary-goto-subject (car articles))
+ (command-execute func)
+ (gnus-summary-remove-process-mark (car articles))
+ (setq articles (cdr articles)))))
+
+(defun gnus-summary-toggle-truncation (&optional arg)
+ "Toggle truncation of summary lines.
+With arg, turn line truncation on iff arg is positive."
+ (interactive "P")
+ (setq truncate-lines
+ (if (null arg) (not truncate-lines)
+ (> (prefix-numeric-value arg) 0)))
+ (redraw-display))
+
+(defun gnus-summary-reselect-current-group (&optional all)
+ "Once exit and then reselect the current newsgroup.
+The prefix argument ALL means to select all articles."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((current-subject (gnus-summary-article-number))
+ (group gnus-newsgroup-name))
+ (setq gnus-newsgroup-begin nil)
+ (gnus-summary-exit t)
+ ;; We have to adjust the point of group mode buffer because the
+ ;; current point was moved to the next unread newsgroup by
+ ;; exiting.
+ (gnus-summary-jump-to-group group)
+ (gnus-group-read-group all t)
+ (gnus-summary-goto-subject current-subject)))
+
+(defun gnus-summary-rescan-group (&optional all)
+ "Exit the newsgroup, ask for new articles, and select the newsgroup."
+ (interactive "P")
+ (gnus-set-global-variables)
+ ;; Fix by Ilja Weis <kult@uni-paderborn.de>.
+ (let ((group gnus-newsgroup-name))
+ (gnus-summary-exit)
+ (gnus-summary-jump-to-group group)
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (gnus-group-get-new-news-this-group 1))
+ (gnus-summary-jump-to-group group)
+ (gnus-group-read-group all)))
+
+(defun gnus-summary-update-info ()
+ (let* ((group gnus-newsgroup-name))
+ (if gnus-newsgroup-kill-headers
+ (setq gnus-newsgroup-killed
+ (gnus-compress-sequence
+ (nconc
+ (gnus-set-sorted-intersection
+ (gnus-uncompress-range gnus-newsgroup-killed)
+ (setq gnus-newsgroup-unselected
+ (sort gnus-newsgroup-unselected '<)))
+ (setq gnus-newsgroup-unreads
+ (sort gnus-newsgroup-unreads '<))) t)))
+ (or (listp (cdr gnus-newsgroup-killed))
+ (setq gnus-newsgroup-killed (list gnus-newsgroup-killed)))
+ (let ((headers gnus-newsgroup-headers))
+ (gnus-close-group group)
+ (run-hooks 'gnus-exit-group-hook)
+ (gnus-update-read-articles
+ group gnus-newsgroup-unreads gnus-newsgroup-unselected
+ gnus-newsgroup-marked
+ t gnus-newsgroup-replied gnus-newsgroup-expirable
+ gnus-newsgroup-killed gnus-newsgroup-dormant
+ gnus-newsgroup-bookmarks
+ (and gnus-save-score gnus-newsgroup-scored))
+ (and gnus-use-cross-reference
+ (gnus-mark-xrefs-as-read
+ group headers gnus-newsgroup-unreads gnus-newsgroup-expirable))
+ ;; Do adaptive scoring, and possibly save score files.
+ (and gnus-newsgroup-adaptive
+ (gnus-score-adaptive))
+ (and gnus-use-scoring
+ (fboundp 'gnus-score-save)
+ (funcall 'gnus-score-save))
+ ;; Do not switch windows but change the buffer to work.
+ (set-buffer gnus-group-buffer)
+ (or (gnus-ephemeral-group-p gnus-newsgroup-name)
+ (gnus-group-update-group group)))))
+
+(defun gnus-summary-exit (&optional temporary)
+ "Exit reading current newsgroup, and then return to group selection mode.
+gnus-exit-group-hook is called with no arguments if that value is non-nil."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-kill-save-kill-buffer)
+ (let* ((group gnus-newsgroup-name)
+ (quit-config (gnus-group-quit-config gnus-newsgroup-name))
+ (mode major-mode)
+ (buf (current-buffer)))
+ (run-hooks 'gnus-summary-prepare-exit-hook)
+ ;; Make all changes in this group permanent.
+ (gnus-summary-update-info)
+ (set-buffer buf)
+ (and gnus-use-cache (gnus-cache-possibly-remove-articles))
+ ;; Make sure where I was, and go to next newsgroup.
+ (set-buffer gnus-group-buffer)
+ (or quit-config
+ (progn
+ (gnus-group-jump-to-group group)
+ (gnus-group-next-unread-group 1)))
+ (if temporary
+ nil ;Nothing to do.
+ ;; We set all buffer-local variables to nil. It is unclear why
+ ;; this is needed, but if we don't, buffer-local variables are
+ ;; not garbage-collected, it seems. This would the lead to en
+ ;; ever-growing Emacs.
+ (set-buffer buf)
+ (gnus-summary-clear-local-variables)
+ ;; We clear the global counterparts of the buffer-local
+ ;; variables as well, just to be on the safe side.
+ (gnus-configure-windows 'group 'force)
+ (gnus-summary-clear-local-variables)
+ ;; Return to group mode buffer.
+ (if (eq mode 'gnus-summary-mode)
+ (gnus-kill-buffer buf))
+ (if (get-buffer gnus-article-buffer)
+ (bury-buffer gnus-article-buffer))
+ (setq gnus-current-select-method gnus-select-method)
+ (pop-to-buffer gnus-group-buffer)
+ (if (not quit-config)
+ (progn
+ (gnus-group-jump-to-group group)
+ (gnus-group-next-unread-group 1))
+ (if (not (buffer-name (car quit-config)))
+ (gnus-configure-windows 'group 'force)
+ (set-buffer (car quit-config))
+ (and (eq major-mode 'gnus-summary-mode)
+ (gnus-set-global-variables))
+ (gnus-configure-windows (cdr quit-config))))
+ (run-hooks 'gnus-summary-exit-hook))))
+
+(defalias 'gnus-summary-quit 'gnus-summary-exit-no-update)
+(defun gnus-summary-exit-no-update (&optional no-questions)
+ "Quit reading current newsgroup without updating read article info."
+ (interactive)
+ (gnus-set-global-variables)
+ (let* ((group gnus-newsgroup-name)
+ (quit-config (gnus-group-quit-config group)))
+ (if (or no-questions
+ gnus-expert-user
+ (gnus-y-or-n-p "Do you really wanna quit reading this group? "))
+ (progn
+ (gnus-close-group group)
+ (gnus-summary-clear-local-variables)
+ (set-buffer gnus-group-buffer)
+ (gnus-summary-clear-local-variables)
+ ;; Return to group selection mode.
+ (gnus-configure-windows 'group 'force)
+ (if (get-buffer gnus-summary-buffer)
+ (kill-buffer gnus-summary-buffer))
+ (if (get-buffer gnus-article-buffer)
+ (bury-buffer gnus-article-buffer))
+ (if (equal (gnus-group-group-name) group)
+ (gnus-group-next-unread-group 1))
+ (if quit-config
+ (progn
+ (if (not (buffer-name (car quit-config)))
+ (gnus-configure-windows 'group 'force)
+ (set-buffer (car quit-config))
+ (and (eq major-mode 'gnus-summary-mode)
+ (gnus-set-global-variables))
+ (gnus-configure-windows (cdr quit-config)))))))))
+
+;; Suggested by Andrew Eskilsson <pi92ae@pt.hk-r.se>.
+(defun gnus-summary-fetch-faq (group)
+ "Fetch the FAQ for the current group."
+ (interactive (list gnus-newsgroup-name))
+ (let (gnus-faq-buffer)
+ (and (setq gnus-faq-buffer (gnus-group-fetch-faq group))
+ (gnus-configure-windows 'summary-faq))))
+
+;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defun gnus-summary-describe-group (&optional force)
+ "Describe the current newsgroup."
+ (interactive "P")
+ (gnus-group-describe-group force gnus-newsgroup-name))
+
+(defun gnus-summary-describe-briefly ()
+ "Describe summary mode commands briefly."
+ (interactive)
+ (gnus-message 6
+ (substitute-command-keys "\\<gnus-summary-mode-map>\\[gnus-summary-next-page]:Select \\[gnus-summary-next-unread-article]:Forward \\[gnus-summary-prev-unread-article]:Backward \\[gnus-summary-exit]:Exit \\[gnus-info-find-node]:Run Info \\[gnus-summary-describe-briefly]:This help")))
+
+;; Walking around group mode buffer from summary mode.
+
+(defun gnus-summary-next-group (&optional no-article target-group backward)
+ "Exit current newsgroup and then select next unread newsgroup.
+If prefix argument NO-ARTICLE is non-nil, no article is selected
+initially. If NEXT-GROUP, go to this group. If BACKWARD, go to
+previous group instead."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((current-group gnus-newsgroup-name)
+ (current-buffer (current-buffer))
+ entered)
+ ;; First we semi-exit this group to update Xrefs and all variables.
+ ;; We can't do a real exit, because the window conf must remain
+ ;; the same in case the user is prompted for info, and we don't
+ ;; want the window conf to change before that...
+ (gnus-summary-exit t)
+ (while (not entered)
+ ;; Then we find what group we are supposed to enter.
+ (set-buffer gnus-group-buffer)
+ (gnus-group-jump-to-group current-group)
+ (setq target-group
+ (or target-group
+ (if (eq gnus-keep-same-level 'best)
+ (gnus-summary-best-group gnus-newsgroup-name)
+ (gnus-summary-search-group backward gnus-keep-same-level))))
+ (if (not target-group)
+ ;; There are no further groups, so we return to the group
+ ;; buffer.
+ (progn
+ (gnus-message 5 "Returning to the group buffer")
+ (setq entered t)
+ (set-buffer current-buffer)
+ (gnus-summary-exit))
+ ;; We try to enter the target group.
+ (gnus-group-jump-to-group target-group)
+ (let ((unreads (gnus-group-group-unread)))
+ (if (and (or (eq t unreads)
+ (and unreads (not (zerop unreads))))
+ (gnus-summary-read-group
+ target-group nil no-article current-buffer))
+ (setq entered t)
+ (setq current-group target-group
+ target-group nil)))))))
+
+(defun gnus-summary-next-group-old (&optional no-article group backward)
+ "Exit current newsgroup and then select next unread newsgroup.
+If prefix argument NO-ARTICLE is non-nil, no article is selected initially.
+If BACKWARD, go to previous group instead."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((ingroup gnus-newsgroup-name)
+ (sumbuf (current-buffer))
+ num)
+ (set-buffer gnus-group-buffer)
+ (if (and group
+ (or (and (numberp (setq num (car (gnus-gethash
+ group gnus-newsrc-hashtb))))
+ (< num 1))
+ (null num)))
+ (progn
+ (gnus-group-jump-to-group group)
+ (setq group nil))
+ (gnus-group-jump-to-group ingroup))
+ (gnus-summary-search-group backward)
+ (let ((group (or group (gnus-summary-search-group backward))))
+ (set-buffer sumbuf)
+ (gnus-summary-exit t) ;Update all information.
+ (if (null group)
+ (gnus-summary-exit-no-update t)
+ (gnus-group-jump-to-group ingroup)
+ (setq group (gnus-summary-search-group backward))
+ (gnus-message 5 "Selecting %s..." group)
+ (set-buffer gnus-group-buffer)
+ ;; We are now in group mode buffer.
+ ;; Make sure group mode buffer point is on GROUP.
+ (gnus-group-jump-to-group group)
+ (if (not (eq gnus-auto-select-next 'quietly))
+ (progn
+ (gnus-summary-read-group group nil no-article sumbuf)
+ (and (string= gnus-newsgroup-name ingroup)
+ (bufferp sumbuf) (buffer-name sumbuf)
+ (progn
+ (set-buffer (setq gnus-summary-buffer sumbuf))
+ (gnus-summary-exit-no-update t))))
+ (let ((prevgroup group))
+ (gnus-group-jump-to-group ingroup)
+ (setq group (gnus-summary-search-group backward))
+ (gnus-summary-read-group group nil no-article sumbuf)
+ (while (and (string= gnus-newsgroup-name ingroup)
+ (bufferp sumbuf)
+ (buffer-name sumbuf)
+ (not (string= prevgroup (gnus-group-group-name))))
+ (set-buffer gnus-group-buffer)
+ (gnus-summary-read-group
+ (setq prevgroup (gnus-group-group-name))
+ nil no-article sumbuf))
+ (and (string= prevgroup (gnus-group-group-name))
+ ;; We have reached the final group in the group
+ ;; buffer.
+ (progn
+ (if (buffer-name sumbuf)
+ (progn
+ (set-buffer sumbuf)
+ (gnus-summary-exit)))))))))))
+
+(defun gnus-summary-prev-group (&optional no-article)
+ "Exit current newsgroup and then select previous unread newsgroup.
+If prefix argument NO-ARTICLE is non-nil, no article is selected initially."
+ (interactive "P")
+ (gnus-summary-next-group no-article nil t))
+
+;; Walking around summary lines.
+
+(defun gnus-summary-first-subject (&optional unread)
+ "Go to the first unread subject.
+If UNREAD is non-nil, go to the first unread article.
+Returns nil if there are no unread articles."
+ (interactive "P")
+ (prog1
+ (cond ((not unread)
+ (goto-char (point-min)))
+ ((gnus-goto-char
+ (text-property-any
+ (point-min) (point-max) 'gnus-mark gnus-unread-mark))
+ t)
+ (t
+ ;; There are no unread articles.
+ (gnus-message 3 "No more unread articles")
+ nil))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-next-subject (n &optional unread dont-display)
+ "Go to next N'th summary line.
+If N is negative, go to the previous N'th subject line.
+If UNREAD is non-nil, only unread articles are selected.
+The difference between N and the actual number of steps taken is
+returned."
+ (interactive "p")
+ (let ((backward (< n 0))
+ (n (abs n)))
+ (while (and (> n 0)
+ (gnus-summary-search-forward unread nil backward))
+ (setq n (1- n)))
+ (if (/= 0 n) (gnus-message 7 "No more%s articles"
+ (if unread " unread" "")))
+ (or dont-display
+ (progn
+ (gnus-summary-recenter)
+ (gnus-summary-position-cursor)))
+ n))
+
+(defun gnus-summary-next-unread-subject (n)
+ "Go to next N'th unread summary line."
+ (interactive "p")
+ (gnus-summary-next-subject n t))
+
+(defun gnus-summary-prev-subject (n &optional unread)
+ "Go to previous N'th summary line.
+If optional argument UNREAD is non-nil, only unread article is selected."
+ (interactive "p")
+ (gnus-summary-next-subject (- n) unread))
+
+(defun gnus-summary-prev-unread-subject (n)
+ "Go to previous N'th unread summary line."
+ (interactive "p")
+ (gnus-summary-next-subject (- n) t))
+
+(defun gnus-summary-goto-subject (article)
+ "Go the subject line of ARTICLE."
+ (interactive
+ (list
+ (string-to-int
+ (completing-read "Article number: "
+ (mapcar
+ (lambda (headers)
+ (list
+ (int-to-string (mail-header-number headers))))
+ gnus-newsgroup-headers)
+ nil 'require-match))))
+ (or article (error "No article number"))
+ (let ((b (point)))
+ (if (not (gnus-goto-char (text-property-any (point-min) (point-max)
+ 'gnus-number article)))
+ ()
+ (gnus-summary-show-thread)
+ ;; Skip dummy articles.
+ (if (eq (gnus-summary-article-mark) gnus-dummy-mark)
+ (forward-line 1))
+ (prog1
+ (if (not (eobp))
+ article
+ (goto-char b)
+ nil)
+ (gnus-summary-position-cursor)))))
+
+;; Walking around summary lines with displaying articles.
+
+(defun gnus-summary-expand-window (&optional arg)
+ "Make the summary buffer take up the entire Emacs frame.
+Given a prefix, will force an `article' buffer configuration."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (if arg
+ (gnus-configure-windows 'article 'force)
+ (gnus-configure-windows 'summary 'force)))
+
+(defun gnus-summary-display-article (article &optional all-header)
+ "Display ARTICLE in article buffer."
+ (gnus-set-global-variables)
+ (if (null article)
+ nil
+ (prog1
+ (gnus-article-prepare article all-header)
+ (gnus-summary-show-thread)
+ (if (eq (gnus-summary-article-mark) gnus-dummy-mark)
+ (progn
+ (forward-line 1)
+ (gnus-summary-position-cursor)))
+ (run-hooks 'gnus-select-article-hook)
+ (gnus-summary-recenter)
+ (gnus-summary-goto-subject article)
+ ;; Successfully display article.
+ (gnus-summary-update-line)
+ (gnus-article-set-window-start
+ (cdr (assq article gnus-newsgroup-bookmarks)))
+ t)))
+
+(defun gnus-summary-select-article (&optional all-headers force pseudo article)
+ "Select the current article.
+If ALL-HEADERS is non-nil, show all header fields. If FORCE is
+non-nil, the article will be re-fetched even if it already present in
+the article buffer. If PSEUDO is non-nil, pseudo-articles will also
+be displayed."
+ (and (not pseudo) (gnus-summary-pseudo-article)
+ (error "This is a pseudo-article."))
+ (let ((article (or article (gnus-summary-article-number)))
+ (all-headers (not (not all-headers))) ;Must be T or NIL.
+ did)
+ (prog1
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (if (or (null gnus-current-article)
+ (null gnus-article-current)
+ (null (get-buffer gnus-article-buffer))
+ (not (eq article (cdr gnus-article-current)))
+ (not (equal (car gnus-article-current) gnus-newsgroup-name))
+ force)
+ ;; The requested article is different from the current article.
+ (progn
+ (gnus-summary-display-article article all-headers)
+ (setq did article))
+ (if (or all-headers gnus-show-all-headers)
+ (gnus-article-show-all-headers))
+ nil))
+ (if did
+ (gnus-article-set-window-start
+ (cdr (assq article gnus-newsgroup-bookmarks)))))))
+
+(defun gnus-summary-set-current-mark (&optional current-mark)
+ "Obsolete function."
+ nil)
+
+(defun gnus-summary-next-article (&optional unread subject backward)
+ "Select the next article.
+If UNREAD, only unread articles are selected.
+If SUBJECT, only articles with SUBJECT are selected.
+If BACKWARD, the previous article is selected instead of the next."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let (header)
+ (cond
+ ;; Is there such an article?
+ ((and (gnus-summary-search-forward unread subject backward)
+ (or (gnus-summary-display-article (gnus-summary-article-number))
+ (eq (gnus-summary-article-mark) gnus-canceled-mark)))
+ (gnus-summary-position-cursor))
+ ;; If not, we try the first unread, if that is wanted.
+ ((and subject
+ gnus-auto-select-same
+ (or (gnus-summary-first-unread-article)
+ (eq (gnus-summary-article-mark) gnus-canceled-mark)))
+ (gnus-summary-position-cursor)
+ (gnus-message 6 "Wrapped"))
+ ;; Try to get next/previous article not displayed in this group.
+ ((and gnus-auto-extend-newsgroup
+ (not unread) (not subject)
+ (setq header (gnus-more-header-forward backward)))
+ (gnus-extend-newsgroup header backward)
+ (let ((buffer-read-only nil))
+ (goto-char (if backward (point-min) (point-max)))
+ (gnus-summary-prepare-threads (list header)))
+ (gnus-summary-goto-article (if backward gnus-newsgroup-begin
+ gnus-newsgroup-end)))
+ ;; Go to next/previous group.
+ (t
+ (or (gnus-ephemeral-group-p gnus-newsgroup-name)
+ (gnus-summary-jump-to-group gnus-newsgroup-name))
+ (let ((cmd last-command-char)
+ (group
+ (if (eq gnus-keep-same-level 'best)
+ (gnus-summary-best-group gnus-newsgroup-name)
+ (gnus-summary-search-group backward gnus-keep-same-level))))
+ ;; For some reason, the group window gets selected. We change
+ ;; it back.
+ (select-window (get-buffer-window (current-buffer)))
+ ;; Keep just the event type of CMD.
+ ;(and (listp cmd) (setq cmd (car cmd)))
+ ;; Select next unread newsgroup automagically.
+ (cond
+ ((not gnus-auto-select-next)
+ (gnus-message 7 "No more%s articles" (if unread " unread" "")))
+ ((eq gnus-auto-select-next 'quietly)
+ ;; Select quietly.
+ (if (gnus-ephemeral-group-p gnus-newsgroup-name)
+ (gnus-summary-exit)
+ (gnus-message 7 "No more%s articles (%s)..."
+ (if unread " unread" "")
+ (if group (concat "selecting " group)
+ "exiting"))
+ (gnus-summary-next-group nil group backward)))
+ (t
+ (let ((keystrokes '(?\C-n ?\C-p))
+ key)
+ (while (or (null key) (memq key keystrokes))
+ (gnus-message
+ 7 "No more%s articles%s" (if unread " unread" "")
+ (if (and group
+ (not (gnus-ephemeral-group-p gnus-newsgroup-name)))
+ (format " (Type %s for %s [%s])"
+ (single-key-description cmd) group
+ (car (gnus-gethash group gnus-newsrc-hashtb)))
+ (format " (Type %s to exit %s)"
+ (single-key-description cmd)
+ gnus-newsgroup-name)))
+ ;; Confirm auto selection.
+ (let* ((event (read-char)))
+ (setq key (if (listp event) (car event) event))
+ (if (memq key keystrokes)
+ (let ((obuf (current-buffer)))
+ (switch-to-buffer gnus-group-buffer)
+ (and group
+ (gnus-group-jump-to-group group))
+ (condition-case ()
+ (execute-kbd-macro (char-to-string key))
+ (error (ding) nil))
+ (setq group (gnus-group-group-name))
+ (switch-to-buffer obuf)))))
+ (if (equal key cmd)
+ (if (or (not group)
+ (gnus-ephemeral-group-p gnus-newsgroup-name))
+ (gnus-summary-exit)
+ (gnus-summary-next-group nil group backward))
+ (execute-kbd-macro (char-to-string key)))))))))))
+
+(defun gnus-summary-next-unread-article ()
+ "Select unread article after current one."
+ (interactive)
+ (gnus-summary-next-article t (and gnus-auto-select-same
+ (gnus-summary-subject-string))))
+
+(defun gnus-summary-prev-article (&optional unread subject)
+ "Select the article after the current one.
+If UNREAD is non-nil, only unread articles are selected."
+ (interactive "P")
+ (gnus-summary-next-article unread subject t))
+
+(defun gnus-summary-prev-unread-article ()
+ "Select unred article before current one."
+ (interactive)
+ (gnus-summary-prev-article t (and gnus-auto-select-same
+ (gnus-summary-subject-string))))
+
+(defun gnus-summary-next-page (&optional lines circular)
+ "Show next page of selected article.
+If end of article, select next article.
+Argument LINES specifies lines to be scrolled up.
+If CIRCULAR is non-nil, go to the start of the article instead of
+instead of selecting the next article when reaching the end of the
+current article."
+ (interactive "P")
+ (setq gnus-summary-buffer (current-buffer))
+ (gnus-set-global-variables)
+ (let ((article (gnus-summary-article-number))
+ (endp nil))
+ (gnus-configure-windows 'article)
+ (if (or (null gnus-current-article)
+ (null gnus-article-current)
+ (/= article (cdr gnus-article-current))
+ (not (equal (car gnus-article-current) gnus-newsgroup-name)))
+ ;; Selected subject is different from current article's.
+ (gnus-summary-display-article article)
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (setq endp (gnus-article-next-page lines)))
+ (if endp
+ (cond (circular
+ (gnus-summary-beginning-of-article))
+ (lines
+ (gnus-message 3 "End of message"))
+ ((null lines)
+ (gnus-summary-next-unread-article)))))
+ (gnus-summary-recenter)
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-prev-page (&optional lines)
+ "Show previous page of selected article.
+Argument LINES specifies lines to be scrolled down."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((article (gnus-summary-article-number)))
+ (gnus-configure-windows 'article)
+ (if (or (null gnus-current-article)
+ (null gnus-article-current)
+ (/= article (cdr gnus-article-current))
+ (not (equal (car gnus-article-current) gnus-newsgroup-name)))
+ ;; Selected subject is different from current article's.
+ (gnus-summary-display-article article)
+ (gnus-summary-recenter)
+ (gnus-eval-in-buffer-window gnus-article-buffer
+ (gnus-article-prev-page lines))))
+ (gnus-summary-position-cursor))
+
+(defun gnus-summary-scroll-up (lines)
+ "Scroll up (or down) one line current article.
+Argument LINES specifies lines to be scrolled up (or down if negative)."
+ (interactive "p")
+ (gnus-set-global-variables)
+ (gnus-configure-windows 'article)
+ (or (gnus-summary-select-article nil nil 'pseudo)
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (cond ((> lines 0)
+ (if (gnus-article-next-page lines)
+ (gnus-message 3 "End of message")))
+ ((< lines 0)
+ (gnus-article-prev-page (- lines))))))
+ (gnus-summary-recenter)
+ (gnus-summary-position-cursor))
+
+(defun gnus-summary-next-same-subject ()
+ "Select next article which has the same subject as current one."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-next-article nil (gnus-summary-subject-string)))
+
+(defun gnus-summary-prev-same-subject ()
+ "Select previous article which has the same subject as current one."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-prev-article nil (gnus-summary-subject-string)))
+
+(defun gnus-summary-next-unread-same-subject ()
+ "Select next unread article which has the same subject as current one."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-next-article t (gnus-summary-subject-string)))
+
+(defun gnus-summary-prev-unread-same-subject ()
+ "Select previous unread article which has the same subject as current one."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-prev-article t (gnus-summary-subject-string)))
+
+(defun gnus-summary-first-unread-article ()
+ "Select the first unread article.
+Return nil if there are no unread articles."
+ (interactive)
+ (gnus-set-global-variables)
+ (prog1
+ (if (gnus-summary-first-subject t)
+ (progn
+ (gnus-summary-show-thread)
+ (gnus-summary-first-subject t)
+ (gnus-summary-display-article (gnus-summary-article-number))))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-best-unread-article ()
+ "Select the unread article with the highest score."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((best -1000000)
+ article score)
+ (save-excursion
+ (or (gnus-summary-first-subject t)
+ (error "No unread articles"))
+ (while
+ (and
+ (progn
+ (and (> (setq score (gnus-summary-article-score)) best)
+ (setq best score
+ article (gnus-summary-article-number)))
+ t)
+ (gnus-summary-search-subject nil t))))
+ (if (not article)
+ (error "No unread articles")
+ (gnus-summary-goto-article article))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-goto-article (article &optional all-headers)
+ "Fetch ARTICLE and display it if it exists.
+If ALL-HEADERS is non-nil, no header lines are hidden."
+ (interactive
+ (list
+ (string-to-int
+ (completing-read
+ "Article number: "
+ (mapcar (lambda (headers)
+ (list (int-to-string (mail-header-number headers))))
+ gnus-newsgroup-headers)
+ nil 'require-match))))
+ (prog1
+ (and (gnus-summary-goto-subject article)
+ (gnus-summary-display-article article all-headers))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-goto-last-article ()
+ "Go to the previously read article."
+ (interactive)
+ (prog1
+ (and gnus-last-article
+ (gnus-summary-goto-article gnus-last-article))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-pop-article (number)
+ "Pop one article off the history and go to the previous.
+NUMBER articles will be popped off."
+ (interactive "p")
+ (let (to)
+ (setq gnus-newsgroup-history
+ (cdr (setq to (nthcdr number gnus-newsgroup-history))))
+ (if to
+ (gnus-summary-goto-article (car to))
+ (error "Article history empty")))
+ (gnus-summary-position-cursor))
+
+;; Summary article oriented commands
+
+(defun gnus-summary-refer-parent-article (n)
+ "Refer parent article N times.
+The difference between N and the number of articles fetched is returned."
+ (interactive "p")
+ (gnus-set-global-variables)
+ (while
+ (and
+ (> n 0)
+ (let ((ref (mail-header-references (gnus-get-header-by-num
+ (gnus-summary-article-number)))))
+ (if (and ref (not (equal ref ""))
+ (string-match "<[^<>]*>[ \t]*$" ref))
+ (gnus-summary-refer-article
+ (substring ref (match-beginning 0) (match-end 0)))
+ (gnus-message 1 "No references in article %d"
+ (gnus-summary-article-number))
+ nil)))
+ (setq n (1- n)))
+ (gnus-summary-position-cursor)
+ n)
+
+(defun gnus-summary-refer-article (message-id)
+ "Refer article specified by MESSAGE-ID.
+NOTE: This command only works with newsgroups that use real or simulated NNTP."
+ (interactive "sMessage-ID: ")
+ (if (or (not (stringp message-id))
+ (zerop (length message-id)))
+ ()
+ ;; Construct the correct Message-ID if necessary.
+ ;; Suggested by tale@pawl.rpi.edu.
+ (or (string-match "^<" message-id)
+ (setq message-id (concat "<" message-id)))
+ (or (string-match ">$" message-id)
+ (setq message-id (concat message-id ">")))
+ (let ((header (car (gnus-gethash (downcase message-id)
+ gnus-newsgroup-dependencies))))
+ (if header
+ (or (gnus-summary-goto-article (mail-header-number header))
+ ;; The header has been read, but the article had been
+ ;; expunged, so we insert it again.
+ (progn
+ (gnus-summary-insert-line
+ nil header 0 nil gnus-read-mark nil nil
+ (mail-header-subject header))
+ (forward-line -1)
+ (mail-header-number header)))
+ (let ((gnus-override-method gnus-refer-article-method)
+ (gnus-ancient-mark gnus-read-mark)
+ (tmp-point (window-start
+ (get-buffer-window gnus-article-buffer)))
+ number tmp-buf)
+ (and gnus-refer-article-method
+ (gnus-check-server gnus-refer-article-method))
+ ;; Save the old article buffer.
+ (save-excursion
+ (set-buffer (gnus-article-setup-buffer))
+ (gnus-kill-buffer " *temp Article*")
+ (setq tmp-buf (rename-buffer " *temp Article*")))
+ (prog1
+ (if (gnus-article-prepare
+ message-id nil (gnus-read-header message-id))
+ (progn
+ (setq number (mail-header-number gnus-current-headers))
+ (gnus-rebuild-thread message-id)
+ (gnus-summary-goto-subject number)
+ (if (null gnus-use-full-window)
+ (progn
+ (delete-windows-on tmp-buf)
+ (gnus-configure-windows 'article 'force)))
+ (gnus-summary-recenter)
+ (gnus-article-set-window-start
+ (cdr (assq number gnus-newsgroup-bookmarks)))
+ (and gnus-visual
+ (run-hooks 'gnus-visual-mark-article-hook))
+ message-id)
+ ;; We restore the old article buffer.
+ (save-excursion
+ (kill-buffer gnus-article-buffer)
+ (set-buffer tmp-buf)
+ (rename-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (and tmp-point
+ (set-window-start (get-buffer-window (current-buffer))
+ tmp-point)))))))))))
+
+(defun gnus-summary-enter-digest-group ()
+ "Enter a digest group based on the current article."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-select-article)
+ ;; We do not want a narrowed article.
+ (gnus-summary-stop-page-breaking)
+ (let ((name (format "%s-%d"
+ (gnus-group-prefixed-name
+ gnus-newsgroup-name (list 'nndoc ""))
+ gnus-current-article))
+ (ogroup gnus-newsgroup-name)
+ (buf (current-buffer)))
+ (if (gnus-group-read-ephemeral-group
+ name (list 'nndoc name
+ (list 'nndoc-address (get-buffer gnus-article-buffer))
+ '(nndoc-article-type digest))
+ t)
+ (setcdr (nthcdr 4 (nth 2 (gnus-gethash name gnus-newsrc-hashtb)))
+ (list (list (cons 'to-group ogroup))))
+ (switch-to-buffer buf)
+ (gnus-set-global-variables)
+ (gnus-configure-windows 'summary)
+ (gnus-message 3 "Article not a digest?"))))
+
+(defun gnus-summary-isearch-article ()
+ "Do incremental search forward on current article."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-select-article)
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer (isearch-forward)))
+
+(defun gnus-summary-search-article-forward (regexp &optional backward)
+ "Search for an article containing REGEXP forward.
+If BACKWARD, search backward instead."
+ (interactive
+ (list (read-string
+ (format "Search article %s (regexp%s): "
+ (if current-prefix-arg "backward" "forward")
+ (if gnus-last-search-regexp
+ (concat ", default " gnus-last-search-regexp)
+ "")))
+ current-prefix-arg))
+ (gnus-set-global-variables)
+ (if (string-equal regexp "")
+ (setq regexp (or gnus-last-search-regexp ""))
+ (setq gnus-last-search-regexp regexp))
+ (if (gnus-summary-search-article regexp backward)
+ (gnus-article-set-window-start
+ (cdr (assq (gnus-summary-article-number) gnus-newsgroup-bookmarks)))
+ (error "Search failed: \"%s\"" regexp)))
+
+(defun gnus-summary-search-article-backward (regexp)
+ "Search for an article containing REGEXP backward."
+ (interactive
+ (list (read-string
+ (format "Search article backward (regexp%s): "
+ (if gnus-last-search-regexp
+ (concat ", default " gnus-last-search-regexp)
+ "")))))
+ (gnus-summary-search-article-forward regexp 'backward))
+
+(defun gnus-summary-search-article (regexp &optional backward)
+ "Search for an article containing REGEXP.
+Optional argument BACKWARD means do search for backward.
+gnus-select-article-hook is not called during the search."
+ (let ((gnus-select-article-hook nil) ;Disable hook.
+ (gnus-mark-article-hook nil) ;Inhibit marking as read.
+ (re-search
+ (if backward
+ (function re-search-backward) (function re-search-forward)))
+ (found nil)
+ (last nil))
+ ;; Hidden thread subtrees must be searched for ,too.
+ (gnus-summary-show-all-threads)
+ (if (eobp) (forward-line -1))
+ ;; First of all, search current article.
+ ;; We don't want to read article again from NNTP server nor reset
+ ;; current point.
+ (gnus-summary-select-article)
+ (gnus-message 9 "Searching article: %d..." gnus-current-article)
+ (setq last gnus-current-article)
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (save-restriction
+ (widen)
+ ;; Begin search from current point.
+ (setq found (funcall re-search regexp nil t))))
+ ;; Then search next articles.
+ (while (and (not found)
+ (gnus-summary-display-article
+ (gnus-summary-search-subject backward nil nil)))
+ (gnus-message 9 "Searching article: %d..." gnus-current-article)
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (save-restriction
+ (widen)
+ (goto-char (if backward (point-max) (point-min)))
+ (setq found (funcall re-search regexp nil t)))))
+ (message "")
+ ;; Adjust article pointer.
+ (or (eq last gnus-current-article)
+ (setq gnus-last-article last))
+ ;; Return T if found such article.
+ found))
+
+(defun gnus-summary-execute-command (header regexp command &optional backward)
+ "Search forward for an article whose HEADER matches REGEXP and execute COMMAND.
+If HEADER is an empty string (or nil), the match is done on the entire
+article. If BACKWARD (the prefix) is non-nil, search backward instead."
+ (interactive
+ (list (let ((completion-ignore-case t))
+ (completing-read
+ "Header name: "
+ (mapcar (lambda (string) (list string))
+ '("Number" "Subject" "From" "Lines" "Date"
+ "Message-ID" "Xref" "References"))
+ nil 'require-match))
+ (read-string "Regexp: ")
+ (read-key-sequence "Command: ")
+ current-prefix-arg))
+ (gnus-set-global-variables)
+ ;; Hidden thread subtrees must be searched as well.
+ (gnus-summary-show-all-threads)
+ ;; We don't want to change current point nor window configuration.
+ (save-excursion
+ (save-window-excursion
+ (gnus-message 6 "Executing %s..." (key-description command))
+ ;; We'd like to execute COMMAND interactively so as to give arguments.
+ (gnus-execute header regexp
+ (` (lambda ()
+ (call-interactively '(, (key-binding command)))))
+ backward)
+ (gnus-message 6 "Executing %s...done" (key-description command)))))
+
+(defun gnus-summary-beginning-of-article ()
+ "Scroll the article back to the beginning."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-select-article)
+ (gnus-configure-windows 'article)
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (widen)
+ (goto-char (point-min))
+ (and gnus-break-pages (gnus-narrow-to-page))))
+
+(defun gnus-summary-end-of-article ()
+ "Scroll to the end of the article."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-select-article)
+ (gnus-configure-windows 'article)
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (widen)
+ (goto-char (point-max))
+ (recenter -3)
+ (and gnus-break-pages (gnus-narrow-to-page))))
+
+(defun gnus-summary-show-article ()
+ "Force re-fetching of the current article."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-select-article nil 'force)
+ (gnus-configure-windows 'article)
+ (gnus-summary-position-cursor))
+
+(defun gnus-summary-verbose-headers (&optional arg)
+ "Toggle permanent full header display.
+If ARG is a positive number, turn header display on.
+If ARG is a negative number, turn header display off."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-toggle-header arg)
+ (setq gnus-show-all-headers
+ (cond ((or (not (numberp arg))
+ (zerop arg))
+ (not gnus-show-all-headers))
+ ((natnump arg)
+ t))))
+
+(defun gnus-summary-toggle-header (&optional arg)
+ "Show the headers if they are hidden, or hide them if they are shown.
+If ARG is a positive number, show the entire header.
+If ARG is a negative number, hide the unwanted header lines."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (if (numberp arg)
+ (if (> arg 0) (remove-text-properties (point-min) (point-max)
+ gnus-hidden-properties)
+ (if (< arg 0) (run-hooks 'gnus-article-display-hook)))
+ (if (text-property-any (point-min) (point-max) 'invisible t)
+ (remove-text-properties
+ (point-min) (point-max) gnus-hidden-properties)
+ ;; We hide the headers. This song and dance act below is
+ ;; done because `gnus-have-all-headers' is buffer-local to
+ ;; the summary buffer, and we only want to temporarily
+ ;; change it in that buffer. Ugh.
+ (let ((have gnus-have-all-headers))
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (setq gnus-have-all-headers nil)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (run-hooks 'gnus-article-display-hook))
+ (setq gnus-have-all-headers have)))))
+ (set-window-point (get-buffer-window (current-buffer)) (point-min)))))
+
+(defun gnus-summary-show-all-headers ()
+ "Make all header lines visible."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-article-show-all-headers))
+
+(defun gnus-summary-toggle-mime (&optional arg)
+ "Toggle MIME processing.
+If ARG is a positive number, turn MIME processing on."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (setq gnus-show-mime
+ (if (null arg) (not gnus-show-mime)
+ (> (prefix-numeric-value arg) 0)))
+ (gnus-summary-select-article t 'force))
+
+(defun gnus-summary-caesar-message (&optional arg)
+ "Caesar rotate the current article by 13.
+The numerical prefix specifies how manu places to rotate each letter
+forward."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-select-article)
+ (let ((mail-header-separator ""))
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (save-restriction
+ (widen)
+ (let ((start (window-start)))
+ (news-caesar-buffer-body arg)
+ (set-window-start (get-buffer-window (current-buffer)) start))))))
+
+(defun gnus-summary-stop-page-breaking ()
+ "Stop page breaking in the current article."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-select-article)
+ (gnus-eval-in-buffer-window gnus-article-buffer (widen)))
+
+;; Suggested by Brian Edmonds <bedmonds@prodigy.bc.ca>.
+
+(defun gnus-summary-move-article (&optional n to-newsgroup select-method)
+ "Move the current article to a different newsgroup.
+If N is a positive number, move the N next articles.
+If N is a negative number, move the N previous articles.
+If N is nil and any articles have been marked with the process mark,
+move those articles instead.
+If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to.
+If SELECT-METHOD is symbol, do not move to a specific newsgroup, but
+re-spool using this method.
+For this function to work, both the current newsgroup and the
+newsgroup that you want to move to have to support the `request-move'
+and `request-accept' functions. (Ie. mail newsgroups at present.)"
+ (interactive "P")
+ (gnus-set-global-variables)
+ (or (gnus-check-backend-function 'request-move-article gnus-newsgroup-name)
+ (error "The current newsgroup does not support article moving"))
+ (let ((articles (gnus-summary-work-articles n))
+ (prefix (gnus-group-real-prefix gnus-newsgroup-name))
+ art-group to-method sel-met)
+ (if (and (not to-newsgroup) (not select-method))
+ (setq to-newsgroup
+ (completing-read
+ (format "Where do you want to move %s? %s"
+ (if (> (length articles) 1)
+ (format "these %d articles" (length articles))
+ "this article")
+ (if gnus-current-move-group
+ (format "(%s default) " gnus-current-move-group)
+ ""))
+ gnus-active-hashtb nil nil prefix)))
+ (if to-newsgroup
+ (progn
+ (if (or (string= to-newsgroup "") (string= to-newsgroup prefix))
+ (setq to-newsgroup (or gnus-current-move-group "")))
+ (or (gnus-gethash to-newsgroup gnus-active-hashtb)
+ (gnus-activate-group to-newsgroup)
+ (error "No such group: %s" to-newsgroup))
+ (setq gnus-current-move-group to-newsgroup)))
+ (setq to-method (if select-method (list select-method "")
+ (gnus-find-method-for-group to-newsgroup)))
+ (or (gnus-check-backend-function 'request-accept-article (car to-method))
+ (error "%s does not support article copying" (car to-method)))
+ (or (gnus-check-server to-method)
+ (error "Can't open server %s" (car to-method)))
+ (gnus-message 6 "Moving to %s: %s..."
+ (or select-method to-newsgroup) articles)
+ (while articles
+ (if (setq art-group
+ (gnus-request-move-article
+ (car articles) ; Article to move
+ gnus-newsgroup-name ; From newsgrouo
+ (nth 1 (gnus-find-method-for-group
+ gnus-newsgroup-name)) ; Server
+ (list 'gnus-request-accept-article
+ (if select-method
+ (list 'quote select-method)
+ to-newsgroup)
+ (not (cdr articles))) ; Accept form
+ (not (cdr articles)))) ; Only save nov last time
+ (let* ((buffer-read-only nil)
+ (entry
+ (or
+ (gnus-gethash (car art-group) gnus-newsrc-hashtb)
+ (gnus-gethash
+ (gnus-group-prefixed-name
+ (car art-group)
+ (if select-method (list select-method "")
+ (gnus-find-method-for-group to-newsgroup)))
+ gnus-newsrc-hashtb)))
+ (info (nth 2 entry))
+ (article (car articles)))
+ (gnus-summary-goto-subject article)
+ (beginning-of-line)
+ (delete-region (point) (progn (forward-line 1) (point)))
+ ;; Update the group that has been moved to.
+ (if (not info)
+ () ; This group does not exist yet.
+ (if (not (memq article gnus-newsgroup-unreads))
+ (setcar (cdr (cdr info))
+ (gnus-add-to-range (nth 2 info)
+ (list (cdr art-group)))))
+ ;; Copy any marks over to the new group.
+ (let ((marks '((tick . gnus-newsgroup-marked)
+ (dormant . gnus-newsgroup-dormant)
+ (expire . gnus-newsgroup-expirable)
+ (bookmark . gnus-newsgroup-bookmarks)
+ (reply . gnus-newsgroup-replied)))
+ (to-article (cdr art-group)))
+ (while marks
+ (if (memq article (symbol-value (cdr (car marks))))
+ (gnus-add-marked-articles
+ (car info) (car (car marks)) (list to-article) info))
+ (setq marks (cdr marks)))))
+ ;; Update marks.
+ (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
+ (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-dormant
+ (delq article gnus-newsgroup-dormant))
+ (setq gnus-newsgroup-reads
+ (cons (cons article gnus-canceled-mark)
+ gnus-newsgroup-reads)))
+ (gnus-message 1 "Couldn't move article %s" (car articles)))
+ (gnus-summary-remove-process-mark (car articles))
+ (setq articles (cdr articles)))
+ (gnus-set-mode-line 'summary)))
+
+(defun gnus-summary-respool-article (&optional n respool-method)
+ "Respool the current article.
+The article will be squeezed through the mail spooling process again,
+which means that it will be put in some mail newsgroup or other
+depending on `nnmail-split-methods'.
+If N is a positive number, respool the N next articles.
+If N is a negative number, respool the N previous articles.
+If N is nil and any articles have been marked with the process mark,
+respool those articles instead.
+
+Respooling can be done both from mail groups and \"real\" newsgroups.
+In the former case, the articles in question will be moved from the
+current group into whatever groups they are destined to. In the
+latter case, they will be copied into the relevant groups."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((respool-methods (gnus-methods-using 'respool))
+ (methname
+ (symbol-name (car (gnus-find-method-for-group gnus-newsgroup-name)))))
+ (or respool-method
+ (setq respool-method
+ (completing-read
+ "What method do you want to use when respooling? "
+ respool-methods nil t methname)))
+ (or (string= respool-method "")
+ (if (assoc (symbol-name
+ (car (gnus-find-method-for-group gnus-newsgroup-name)))
+ respool-methods)
+ (gnus-summary-move-article n nil (intern respool-method))
+ (gnus-summary-copy-article n nil (intern respool-method))))))
+
+;; Suggested by gregj@unidata.com (Gregory J. Grubbs).
+(defun gnus-summary-copy-article (&optional n to-newsgroup select-method)
+ "Move the current article to a different newsgroup.
+If N is a positive number, move the N next articles.
+If N is a negative number, move the N previous articles.
+If N is nil and any articles have been marked with the process mark,
+move those articles instead.
+If TO-NEWSGROUP is string, do not prompt for a newsgroup to move to.
+If SELECT-METHOD is symbol, do not move to a specific newsgroup, but
+re-spool using this method.
+For this function to work, the newsgroup that you want to move to have
+to support the `request-move' and `request-accept'
+functions. (Ie. mail newsgroups at present.)"
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((articles (gnus-summary-work-articles n))
+ (copy-buf (get-buffer-create "*copy work*"))
+ (prefix (gnus-group-real-prefix gnus-newsgroup-name))
+ art-group to-method)
+ (buffer-disable-undo copy-buf)
+ (if (and (not to-newsgroup) (not select-method))
+ (setq to-newsgroup
+ (completing-read
+ (format "Where do you want to copy %s? %s"
+ (if (> (length articles) 1)
+ (format "these %d articles" (length articles))
+ "this article")
+ (if gnus-current-move-group
+ (format "(%s default) " gnus-current-move-group)
+ ""))
+ gnus-active-hashtb nil nil prefix)))
+ (if to-newsgroup
+ (progn
+ (if (or (string= to-newsgroup "") (string= to-newsgroup prefix))
+ (setq to-newsgroup (or gnus-current-move-group "")))
+ (or (gnus-gethash to-newsgroup gnus-active-hashtb)
+ (gnus-activate-group to-newsgroup)
+ (error "No such group: %s" to-newsgroup))
+ (setq gnus-current-move-group to-newsgroup)))
+ (setq to-method (if select-method (list select-method "")
+ (gnus-find-method-for-group to-newsgroup)))
+ (or (gnus-check-backend-function 'request-accept-article (car to-method))
+ (error "%s does not support article copying" (car to-method)))
+ (or (gnus-check-server to-method)
+ (error "Can't open server %s" (car to-method)))
+ (while articles
+ (gnus-message 6 "Copying to %s: %s..."
+ (or select-method to-newsgroup) articles)
+ (if (setq art-group
+ (save-excursion
+ (set-buffer copy-buf)
+ (gnus-request-article-this-buffer
+ (car articles) gnus-newsgroup-name)
+ (gnus-request-accept-article
+ (if select-method (quote select-method) to-newsgroup)
+ (not (cdr articles)))))
+ (let* ((entry
+ (or
+ (gnus-gethash (car art-group) gnus-newsrc-hashtb)
+ (gnus-gethash
+ (gnus-group-prefixed-name
+ (car art-group)
+ (if select-method (list select-method "")
+ (gnus-find-method-for-group to-newsgroup)))
+ gnus-newsrc-hashtb)))
+ (info (nth 2 entry))
+ (article (car articles)))
+ ;; We copy the info over to the new group.
+ (if (not info)
+ () ; This group does not exist (yet).
+ (if (not (memq article gnus-newsgroup-unreads))
+ (setcar (cdr (cdr info))
+ (gnus-add-to-range (nth 2 info)
+ (list (cdr art-group)))))
+ ;; Copy any marks over to the new group.
+ (let ((marks '((tick . gnus-newsgroup-marked)
+ (dormant . gnus-newsgroup-dormant)
+ (expire . gnus-newsgroup-expirable)
+ (bookmark . gnus-newsgroup-bookmarks)
+ (reply . gnus-newsgroup-replied)))
+ (to-article (cdr art-group)))
+ (while marks
+ (if (memq article (symbol-value (cdr (car marks))))
+ (gnus-add-marked-articles
+ (car info) (car (car marks)) (list to-article) info))
+ (setq marks (cdr marks))))))
+ (gnus-message 1 "Couldn't copy article %s" (car articles)))
+ (gnus-summary-remove-process-mark (car articles))
+ (setq articles (cdr articles)))
+ (kill-buffer copy-buf)))
+
+(defun gnus-summary-import-article (file)
+ "Import a random file into a mail newsgroup."
+ (interactive "fImport file: ")
+ (let ((group gnus-newsgroup-name)
+ atts)
+ (or (gnus-check-backend-function 'request-accept-article group)
+ (error "%s does not support article importing" group))
+ (or (file-readable-p file)
+ (not (file-regular-p file))
+ (error "Can't read %s" file))
+ (save-excursion
+ (set-buffer (get-buffer-create " *import file*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-file-contents file)
+ (goto-char (point-min))
+ (if (nnheader-article-p)
+ ()
+ (setq atts (file-attributes file))
+ (insert "From: " (read-string "From: ") "\n"
+ "Subject: " (read-string "Subject: ") "\n"
+ "Date: " (current-time-string (nth 5 atts)) "\n"
+ "Chars: " (int-to-string (nth 7 atts)) "\n\n"))
+ (gnus-request-accept-article group t)
+ (kill-buffer (current-buffer)))))
+
+(defun gnus-summary-expire-articles ()
+ "Expire all articles that are marked as expirable in the current group."
+ (interactive)
+ (if (not (gnus-check-backend-function
+ 'request-expire-articles gnus-newsgroup-name))
+ ()
+ (let* ((info (nth 2 (gnus-gethash gnus-newsgroup-name
+ gnus-newsrc-hashtb)))
+ (total (memq 'total-expire (nth 5 info)))
+ (expirable (if total
+ (gnus-list-of-read-articles gnus-newsgroup-name)
+ (setq gnus-newsgroup-expirable
+ (sort gnus-newsgroup-expirable '<))))
+ es)
+ (if (not expirable)
+ ()
+ (gnus-message 6 "Expiring articles...")
+ ;; The list of articles that weren't expired is returned.
+ (setq es (gnus-request-expire-articles expirable gnus-newsgroup-name))
+ (or total (setq gnus-newsgroup-expirable es))
+ ;; We go through the old list of expirable, and mark all
+ ;; really expired articles as non-existant.
+ (or (eq es expirable) ;If nothing was expired, we don't mark.
+ (let ((gnus-use-cache nil))
+ (while expirable
+ (or (memq (car expirable) es)
+ (gnus-summary-mark-article
+ (car expirable) gnus-canceled-mark))
+ (setq expirable (cdr expirable)))))
+ (gnus-message 6 "Expiring articles...done")))))
+
+(defun gnus-summary-expire-articles-now ()
+ "Expunge all expirable articles in the current group.
+This means that *all* articles that are marked as expirable will be
+deleted forever, right now."
+ (interactive)
+ (or gnus-expert-user
+ (gnus-y-or-n-p
+ "Are you really, really, really sure you want to expunge? ")
+ (error "Phew!"))
+ (let ((nnmail-expiry-wait -1)
+ (nnmail-expiry-wait-function nil))
+ (gnus-summary-expire-articles)))
+
+;; Suggested by Jack Vinson <vinson@unagi.cis.upenn.edu>.
+(defun gnus-summary-delete-article (&optional n)
+ "Delete the N next (mail) articles.
+This command actually deletes articles. This is not a marking
+command. The article will disappear forever from you life, never to
+return.
+If N is negative, delete backwards.
+If N is nil and articles have been marked with the process mark,
+delete these instead."
+ (interactive "P")
+ (or (gnus-check-backend-function 'request-expire-articles
+ gnus-newsgroup-name)
+ (error "The current newsgroup does not support article deletion."))
+ ;; Compute the list of articles to delete.
+ (let ((articles (gnus-summary-work-articles n))
+ not-deleted)
+ (if (and gnus-novice-user
+ (not (gnus-y-or-n-p
+ (format "Do you really want to delete %s forever? "
+ (if (> (length articles) 1) "these articles"
+ "this article")))))
+ ()
+ ;; Delete the articles.
+ (setq not-deleted (gnus-request-expire-articles
+ articles gnus-newsgroup-name 'force))
+ (while articles
+ (gnus-summary-remove-process-mark (car articles))
+ ;; The backend might not have been able to delete the article
+ ;; after all.
+ (or (memq (car articles) not-deleted)
+ (gnus-summary-mark-article (car articles) gnus-canceled-mark))
+ (setq articles (cdr articles))))
+ (gnus-summary-position-cursor)
+ (gnus-set-mode-line 'summary)
+ not-deleted))
+
+(defun gnus-summary-edit-article (&optional force)
+ "Enter into a buffer and edit the current article.
+This will have permanent effect only in mail groups.
+If FORCE is non-nil, allow editing of articles even in read-only
+groups."
+ (interactive "P")
+ (or force
+ (not (gnus-group-read-only-p))
+ (error "The current newsgroup does not support article editing."))
+ (gnus-summary-select-article t)
+ (gnus-configure-windows 'article)
+ (select-window (get-buffer-window gnus-article-buffer))
+ (gnus-message 6 "C-c C-c to end edits")
+ (setq buffer-read-only nil)
+ (text-mode)
+ (use-local-map (copy-keymap (current-local-map)))
+ (local-set-key "\C-c\C-c" 'gnus-summary-edit-article-done)
+ (buffer-enable-undo)
+ (widen)
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t))
+
+(defun gnus-summary-edit-article-done ()
+ "Make edits to the current article permanent."
+ (interactive)
+ (if (gnus-group-read-only-p)
+ (progn
+ (gnus-summary-edit-article-postpone)
+ (message "The current newsgroup does not support article editing.")
+ (ding))
+ (let ((buf (buffer-substring-no-properties (point-min) (point-max))))
+ (erase-buffer)
+ (insert buf)
+ (if (not (gnus-request-replace-article
+ (cdr gnus-article-current) (car gnus-article-current)
+ (current-buffer)))
+ (error "Couldn't replace article.")
+ (gnus-article-mode)
+ (use-local-map gnus-article-mode-map)
+ (setq buffer-read-only t)
+ (buffer-disable-undo (current-buffer))
+ (gnus-configure-windows 'summary))
+ (and gnus-visual (run-hooks 'gnus-visual-mark-article-hook)))))
+
+(defun gnus-summary-edit-article-postpone ()
+ "Postpone changes to the current article."
+ (interactive)
+ (gnus-article-mode)
+ (use-local-map gnus-article-mode-map)
+ (setq buffer-read-only t)
+ (buffer-disable-undo (current-buffer))
+ (gnus-configure-windows 'summary)
+ (and gnus-visual (run-hooks 'gnus-visual-mark-article-hook)))
+
+(defun gnus-summary-fancy-query ()
+ "Query where the fancy respool algorithm would put this article."
+ (interactive)
+ (gnus-summary-select-article)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (narrow-to-region (point-min) (point))
+ (pp-eval-expression (list 'quote (nnmail-split-fancy))))))
+
+;; Summary score commands.
+
+;; Suggested by boubaker@cenatls.cena.dgac.fr.
+
+(defun gnus-summary-raise-score (n)
+ "Raise the score of the current article by N."
+ (interactive "p")
+ (gnus-summary-set-score (+ (gnus-summary-article-score) n)))
+
+(defun gnus-summary-set-score (n)
+ "Set the score of the current article to N."
+ (interactive "p")
+ ;; Skip dummy header line.
+ (save-excursion
+ (gnus-summary-show-thread)
+ (if (eq (gnus-summary-article-mark) gnus-dummy-mark)
+ (forward-line 1))
+ (let ((buffer-read-only nil))
+ ;; Set score.
+ (gnus-summary-update-mark
+ (if (= n (or gnus-summary-default-score 0)) ?
+ (if (< n (or gnus-summary-default-score 0))
+ gnus-score-below-mark gnus-score-over-mark)) 'score))
+ (let* ((article (gnus-summary-article-number))
+ (score (assq article gnus-newsgroup-scored)))
+ (if score (setcdr score n)
+ (setq gnus-newsgroup-scored
+ (cons (cons article n) gnus-newsgroup-scored))))
+ (gnus-summary-update-line)))
+
+(defun gnus-summary-current-score ()
+ "Return the score of the current article."
+ (interactive)
+ (message "%s" (gnus-summary-article-score)))
+
+;; Summary marking commands.
+
+(defun gnus-summary-raise-same-subject-and-select (score)
+ "Raise articles which has the same subject with SCORE and select the next."
+ (interactive "p")
+ (let ((subject (gnus-summary-subject-string)))
+ (gnus-summary-raise-score score)
+ (while (gnus-summary-search-subject nil nil subject)
+ (gnus-summary-raise-score score))
+ (gnus-summary-next-article t)))
+
+(defun gnus-summary-raise-same-subject (score)
+ "Raise articles which has the same subject with SCORE."
+ (interactive "p")
+ (let ((subject (gnus-summary-subject-string)))
+ (gnus-summary-raise-score score)
+ (while (gnus-summary-search-subject nil nil subject)
+ (gnus-summary-raise-score score))
+ (gnus-summary-next-subject 1 t)))
+
+(defun gnus-score-default (level)
+ (if level (prefix-numeric-value level)
+ gnus-score-interactive-default-score))
+
+(defun gnus-summary-raise-thread (&optional score)
+ "Raise the score of the articles in the current thread with SCORE."
+ (interactive "P")
+ (setq score (gnus-score-default score))
+ (let (e)
+ (save-excursion
+ (let ((level (gnus-summary-thread-level)))
+ (gnus-summary-raise-score score)
+ (while (and (zerop (gnus-summary-next-subject 1 nil t))
+ (> (gnus-summary-thread-level) level))
+ (gnus-summary-raise-score score))
+ (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-cursor)
+ (gnus-set-mode-line 'summary))
+
+(defun gnus-summary-lower-same-subject-and-select (score)
+ "Raise articles which has the same subject with SCORE and select the next."
+ (interactive "p")
+ (gnus-summary-raise-same-subject-and-select (- score)))
+
+(defun gnus-summary-lower-same-subject (score)
+ "Raise articles which has the same subject with SCORE."
+ (interactive "p")
+ (gnus-summary-raise-same-subject (- score)))
+
+(defun gnus-summary-lower-thread (&optional score)
+ "Lower score of articles in the current thread with SCORE."
+ (interactive "P")
+ (gnus-summary-raise-thread (- (1- (gnus-score-default score)))))
+
+(defun gnus-summary-kill-same-subject-and-select (&optional unmark)
+ "Mark articles which has the same subject as read, and then select the next.
+If UNMARK is positive, remove any kind of mark.
+If UNMARK is negative, tick articles."
+ (interactive "P")
+ (if unmark
+ (setq unmark (prefix-numeric-value unmark)))
+ (let ((count
+ (gnus-summary-mark-same-subject
+ (gnus-summary-subject-string) unmark)))
+ ;; Select next unread article. If auto-select-same mode, should
+ ;; select the first unread article.
+ (gnus-summary-next-article t (and gnus-auto-select-same
+ (gnus-summary-subject-string)))
+ (gnus-message 7 "%d article%s marked as %s"
+ count (if (= count 1) " is" "s are")
+ (if unmark "unread" "read"))))
+
+(defun gnus-summary-kill-same-subject (&optional unmark)
+ "Mark articles which has the same subject as read.
+If UNMARK is positive, remove any kind of mark.
+If UNMARK is negative, tick articles."
+ (interactive "P")
+ (if unmark
+ (setq unmark (prefix-numeric-value unmark)))
+ (let ((count
+ (gnus-summary-mark-same-subject
+ (gnus-summary-subject-string) unmark)))
+ ;; If marked as read, go to next unread subject.
+ (if (null unmark)
+ ;; Go to next unread subject.
+ (gnus-summary-next-subject 1 t))
+ (gnus-message 7 "%d articles are marked as %s"
+ count (if unmark "unread" "read"))))
+
+(defun gnus-summary-mark-same-subject (subject &optional unmark)
+ "Mark articles with same SUBJECT as read, and return marked number.
+If optional argument UNMARK is positive, remove any kinds of marks.
+If optional argument UNMARK is negative, mark articles as unread instead."
+ (let ((count 1))
+ (save-excursion
+ (cond
+ ((null unmark) ; Mark as read.
+ (while (and
+ (progn
+ (gnus-summary-mark-article-as-read gnus-killed-mark)
+ (gnus-summary-show-thread) t)
+ (gnus-summary-search-forward nil subject))
+ (setq count (1+ count))))
+ ((> unmark 0) ; Tick.
+ (while (and
+ (progn
+ (gnus-summary-mark-article-as-unread gnus-ticked-mark)
+ (gnus-summary-show-thread) t)
+ (gnus-summary-search-forward nil subject))
+ (setq count (1+ count))))
+ (t ; Mark as unread.
+ (while (and
+ (progn
+ (gnus-summary-mark-article-as-unread gnus-unread-mark)
+ (gnus-summary-show-thread) t)
+ (gnus-summary-search-forward nil subject))
+ (setq count (1+ count)))))
+ (gnus-set-mode-line 'summary)
+ ;; Return the number of marked articles.
+ count)))
+
+(defun gnus-summary-mark-as-processable (n &optional unmark)
+ "Set the process mark on the next N articles.
+If N is negative, mark backward instead. If UNMARK is non-nil, remove
+the process mark instead. The difference between N and the actual
+number of articles marked is returned."
+ (interactive "p")
+ (let ((backward (< n 0))
+ (n (abs n)))
+ (while (and
+ (> n 0)
+ (if unmark
+ (gnus-summary-remove-process-mark
+ (gnus-summary-article-number))
+ (gnus-summary-set-process-mark (gnus-summary-article-number)))
+ (zerop (gnus-summary-next-subject (if backward -1 1) nil t)))
+ (setq n (1- n)))
+ (if (/= 0 n) (gnus-message 7 "No more articles"))
+ (gnus-summary-recenter)
+ (gnus-summary-position-cursor)
+ n))
+
+(defun gnus-summary-unmark-as-processable (n)
+ "Remove the process mark from the next N articles.
+If N is negative, mark backward instead. The difference between N and
+the actual number of articles marked is returned."
+ (interactive "p")
+ (gnus-summary-mark-as-processable n t))
+
+(defun gnus-summary-unmark-all-processable ()
+ "Remove the process mark from all articles."
+ (interactive)
+ (save-excursion
+ (while gnus-newsgroup-processable
+ (gnus-summary-remove-process-mark (car gnus-newsgroup-processable))))
+ (gnus-summary-position-cursor))
+
+(defun gnus-summary-mark-as-expirable (n)
+ "Mark N articles forward as expirable.
+If N is negative, mark backward instead. The difference between N and
+the actual number of articles marked is returned."
+ (interactive "p")
+ (gnus-summary-mark-forward n gnus-expirable-mark))
+
+(defun gnus-summary-mark-article-as-replied (article)
+ "Mark ARTICLE replied and update the summary line."
+ (setq gnus-newsgroup-replied (cons article gnus-newsgroup-replied))
+ (let ((buffer-read-only nil))
+ (if (gnus-summary-goto-subject article)
+ (progn
+ (gnus-summary-update-mark gnus-replied-mark 'replied)
+ t))))
+
+(defun gnus-summary-set-bookmark (article)
+ "Set a bookmark in current article."
+ (interactive (list (gnus-summary-article-number)))
+ (if (or (not (get-buffer gnus-article-buffer))
+ (not gnus-current-article)
+ (not gnus-article-current)
+ (not (equal gnus-newsgroup-name (car gnus-article-current))))
+ (error "No current article selected"))
+ ;; Remove old bookmark, if one exists.
+ (let ((old (assq article gnus-newsgroup-bookmarks)))
+ (if old (setq gnus-newsgroup-bookmarks
+ (delq old gnus-newsgroup-bookmarks))))
+ ;; Set the new bookmark, which is on the form
+ ;; (article-number . line-number-in-body).
+ (setq gnus-newsgroup-bookmarks
+ (cons
+ (cons article
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (count-lines
+ (min (point)
+ (save-excursion
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (point)))
+ (point))))
+ gnus-newsgroup-bookmarks))
+ (gnus-message 6 "A bookmark has been added to the current article."))
+
+(defun gnus-summary-remove-bookmark (article)
+ "Remove the bookmark from the current article."
+ (interactive (list (gnus-summary-article-number)))
+ ;; Remove old bookmark, if one exists.
+ (let ((old (assq article gnus-newsgroup-bookmarks)))
+ (if old
+ (progn
+ (setq gnus-newsgroup-bookmarks
+ (delq old gnus-newsgroup-bookmarks))
+ (gnus-message 6 "Removed bookmark."))
+ (gnus-message 6 "No bookmark in current article."))))
+
+;; Suggested by Daniel Quinlan <quinlan@best.com>.
+(defun gnus-summary-mark-as-dormant (n)
+ "Mark N articles forward as dormant.
+If N is negative, mark backward instead. The difference between N and
+the actual number of articles marked is returned."
+ (interactive "p")
+ (gnus-summary-mark-forward n gnus-dormant-mark))
+
+(defun gnus-summary-set-process-mark (article)
+ "Set the process mark on ARTICLE and update the summary line."
+ (setq gnus-newsgroup-processable (cons article gnus-newsgroup-processable))
+ (let ((buffer-read-only nil))
+ (if (gnus-summary-goto-subject article)
+ (progn
+ (gnus-summary-show-thread)
+ (and (eq (gnus-summary-article-mark) gnus-dummy-mark)
+ (forward-line 1))
+ (gnus-summary-update-mark gnus-process-mark 'replied)
+ t))))
+
+(defun gnus-summary-remove-process-mark (article)
+ "Remove the process mark from ARTICLE and update the summary line."
+ (setq gnus-newsgroup-processable (delq article gnus-newsgroup-processable))
+ (let ((buffer-read-only nil))
+ (if (gnus-summary-goto-subject article)
+ (progn
+ (gnus-summary-show-thread)
+ (and (eq (gnus-summary-article-mark) gnus-dummy-mark)
+ (forward-line 1))
+ (gnus-summary-update-mark ? 'replied)
+ (if (memq article gnus-newsgroup-replied)
+ (gnus-summary-update-mark gnus-replied-mark 'replied))
+ t))))
+
+(defun gnus-summary-mark-forward (n &optional mark no-expire)
+ "Mark N articles as read forwards.
+If N is negative, mark backwards instead.
+Mark with MARK. If MARK is ? , ?! or ??, articles will be
+marked as unread.
+The difference between N and the actual number of articles marked is
+returned."
+ (interactive "p")
+ (gnus-set-global-variables)
+ (let ((backward (< n 0))
+ (gnus-summary-goto-unread
+ (and gnus-summary-goto-unread
+ (not (memq mark (list gnus-unread-mark
+ gnus-ticked-mark gnus-dormant-mark)))))
+ (n (abs n))
+ (mark (or mark gnus-del-mark)))
+ (while (and (> n 0)
+ (gnus-summary-mark-article nil mark no-expire)
+ (zerop (gnus-summary-next-subject
+ (if backward -1 1) gnus-summary-goto-unread t)))
+ (setq n (1- n)))
+ (if (/= 0 n) (gnus-message 7 "No more %sarticles" (if mark "" "unread ")))
+ (gnus-summary-recenter)
+ (gnus-summary-position-cursor)
+ (gnus-set-mode-line 'summary)
+ n))
+
+(defun gnus-summary-mark-article-as-read (mark)
+ "Mark the current article quickly as read with MARK."
+ (let ((article (gnus-summary-article-number)))
+ (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
+ (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
+ (setq gnus-newsgroup-reads
+ (cons (cons article mark) gnus-newsgroup-reads))
+ ;; Possibly remove from cache, if that is used.
+ (and gnus-use-cache (gnus-cache-enter-remove-article article))
+ (and gnus-newsgroup-auto-expire
+ (or (= mark gnus-killed-mark) (= mark gnus-del-mark)
+ (= mark gnus-catchup-mark) (= mark gnus-low-score-mark)
+ (= mark gnus-read-mark))
+ (progn
+ (setq mark gnus-expirable-mark)
+ (setq gnus-newsgroup-expirable
+ (cons article gnus-newsgroup-expirable))))
+ (while (eq (gnus-summary-article-mark) gnus-dummy-mark)
+ (forward-line 1))
+ ;; Fix the mark.
+ (gnus-summary-update-mark mark 'unread)
+ t))
+
+(defun gnus-summary-mark-article-as-unread (mark)
+ "Mark the current article quickly as unread with MARK."
+ (let ((article (gnus-summary-article-number)))
+ (or (memq article gnus-newsgroup-unreads)
+ (setq gnus-newsgroup-unreads (cons article gnus-newsgroup-unreads)))
+ (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
+ (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
+ (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))
+ (setq gnus-newsgroup-reads
+ (delq (assq article gnus-newsgroup-reads)
+ gnus-newsgroup-reads))
+ (if (= mark gnus-ticked-mark)
+ (setq gnus-newsgroup-marked (cons article gnus-newsgroup-marked)))
+ (if (= mark gnus-dormant-mark)
+ (setq gnus-newsgroup-dormant (cons article gnus-newsgroup-dormant)))
+
+ ;; See whether the article is to be put in the cache.
+ (and gnus-use-cache
+ (vectorp (gnus-get-header-by-num article))
+ (save-excursion
+ (gnus-cache-possibly-enter-article
+ gnus-newsgroup-name article
+ (gnus-get-header-by-num article)
+ (= mark gnus-ticked-mark)
+ (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
+
+ (while (eq (gnus-summary-article-mark) gnus-dummy-mark)
+ (forward-line 1))
+ ;; Fix the mark.
+ (gnus-summary-update-mark mark 'unread)
+ t))
+
+(defun gnus-summary-mark-article (&optional article mark no-expire)
+ "Mark ARTICLE with MARK. MARK can be any character.
+Four MARK strings are reserved: `? ' (unread), `?!' (ticked), `??'
+(dormant) and `?E' (expirable).
+If MARK is nil, then the default character `?D' is used.
+If ARTICLE is nil, then the article on the current line will be
+marked."
+ (and (stringp mark)
+ (setq mark (aref mark 0)))
+ ;; If no mark is given, then we check auto-expiring.
+ (and (not no-expire)
+ gnus-newsgroup-auto-expire
+ (or (not mark)
+ (and (numberp mark)
+ (or (= mark gnus-killed-mark) (= mark gnus-del-mark)
+ (= mark gnus-catchup-mark) (= mark gnus-low-score-mark)
+ (= mark gnus-read-mark))))
+ (setq mark gnus-expirable-mark))
+ (let* ((mark (or mark gnus-del-mark))
+ (article (or article (gnus-summary-article-number))))
+ (or article (error "No article on current line"))
+ (if (or (= mark gnus-unread-mark)
+ (= mark gnus-ticked-mark)
+ (= mark gnus-dormant-mark))
+ (gnus-mark-article-as-unread article mark)
+ (gnus-mark-article-as-read article mark))
+
+ ;; See whether the article is to be put in the cache.
+ (and gnus-use-cache
+ (not (= mark gnus-canceled-mark))
+ (vectorp (gnus-get-header-by-num article))
+ (save-excursion
+ (gnus-cache-possibly-enter-article
+ gnus-newsgroup-name article
+ (gnus-get-header-by-num article)
+ (= mark gnus-ticked-mark)
+ (= mark gnus-dormant-mark) (= mark gnus-unread-mark))))
+
+ (if (gnus-summary-goto-subject article)
+ (let ((buffer-read-only nil))
+ (gnus-summary-show-thread)
+ (and (eq (gnus-summary-article-mark) gnus-dummy-mark)
+ (forward-line 1))
+ ;; Fix the mark.
+ (gnus-summary-update-mark mark 'unread)
+ t))))
+
+(defun gnus-summary-update-mark (mark type)
+ (beginning-of-line)
+ (let ((forward (cdr (assq type gnus-summary-mark-positions)))
+ (buffer-read-only nil)
+ plist)
+ (if (not forward)
+ ()
+ (forward-char forward)
+ (setq plist (text-properties-at (point)))
+ (delete-char 1)
+ (insert mark)
+ (and plist (add-text-properties (1- (point)) (point) plist))
+ (and (eq type 'unread)
+ (progn
+ (add-text-properties (1- (point)) (point) (list 'gnus-mark mark))
+ (gnus-summary-update-line (eq mark gnus-unread-mark)))))))
+
+(defun gnus-mark-article-as-read (article &optional mark)
+ "Enter ARTICLE in the pertinent lists and remove it from others."
+ ;; Make the article expirable.
+ (let ((mark (or mark gnus-del-mark)))
+ (if (= mark gnus-expirable-mark)
+ (setq gnus-newsgroup-expirable (cons article gnus-newsgroup-expirable))
+ (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable)))
+ ;; Remove from unread and marked lists.
+ (setq gnus-newsgroup-unreads (delq article gnus-newsgroup-unreads))
+ (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
+ (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
+ (setq gnus-newsgroup-reads
+ (cons (cons article mark) gnus-newsgroup-reads))
+ ;; Possibly remove from cache, if that is used.
+ (and gnus-use-cache (gnus-cache-enter-remove-article article))))
+
+(defun gnus-mark-article-as-unread (article &optional mark)
+ "Enter ARTICLE in the pertinent lists and remove it from others."
+ (let ((mark (or mark gnus-ticked-mark)))
+ ;; Add to unread list.
+ (or (memq article gnus-newsgroup-unreads)
+ (setq gnus-newsgroup-unreads (cons article gnus-newsgroup-unreads)))
+ (setq gnus-newsgroup-marked (delq article gnus-newsgroup-marked))
+ (setq gnus-newsgroup-dormant (delq article gnus-newsgroup-dormant))
+ (setq gnus-newsgroup-expirable (delq article gnus-newsgroup-expirable))
+ (setq gnus-newsgroup-reads
+ (delq (assq article gnus-newsgroup-reads)
+ gnus-newsgroup-reads))
+ (if (= mark gnus-ticked-mark)
+ (setq gnus-newsgroup-marked (cons article gnus-newsgroup-marked)))
+ (if (= mark gnus-dormant-mark)
+ (setq gnus-newsgroup-dormant (cons article gnus-newsgroup-dormant)))))
+
+(defalias 'gnus-summary-mark-as-unread-forward
+ 'gnus-summary-tick-article-forward)
+(make-obsolete 'gnus-summary-mark-as-unread-forward
+ 'gnus-summary-tick-article-forward)
+(defun gnus-summary-tick-article-forward (n)
+ "Tick N articles forwards.
+If N is negative, tick backwards instead.
+The difference between N and the number of articles ticked is returned."
+ (interactive "p")
+ (gnus-summary-mark-forward n gnus-ticked-mark))
+
+(defalias 'gnus-summary-mark-as-unread-backward
+ 'gnus-summary-tick-article-backward)
+(make-obsolete 'gnus-summary-mark-as-unread-backward
+ 'gnus-summary-tick-article-backward)
+(defun gnus-summary-tick-article-backward (n)
+ "Tick N articles backwards.
+The difference between N and the number of articles ticked is returned."
+ (interactive "p")
+ (gnus-summary-mark-forward (- n) gnus-ticked-mark))
+
+(defalias 'gnus-summary-mark-as-unread 'gnus-summary-tick-article)
+(make-obsolete 'gnus-summary-mark-as-unread 'gnus-summary-tick-article)
+(defun gnus-summary-tick-article (&optional article clear-mark)
+ "Mark current article as unread.
+Optional 1st argument ARTICLE specifies article number to be marked as unread.
+Optional 2nd argument CLEAR-MARK remove any kinds of mark."
+ (gnus-summary-mark-article article (if clear-mark gnus-unread-mark
+ gnus-ticked-mark)))
+
+(defun gnus-summary-mark-as-read-forward (n)
+ "Mark N articles as read forwards.
+If N is negative, mark backwards instead.
+The difference between N and the actual number of articles marked is
+returned."
+ (interactive "p")
+ (gnus-summary-mark-forward n gnus-del-mark t))
+
+(defun gnus-summary-mark-as-read-backward (n)
+ "Mark the N articles as read backwards.
+The difference between N and the actual number of articles marked is
+returned."
+ (interactive "p")
+ (gnus-summary-mark-forward (- n) gnus-del-mark t))
+
+(defun gnus-summary-mark-as-read (&optional article mark)
+ "Mark current article as read.
+ARTICLE specifies the article to be marked as read.
+MARK specifies a string to be inserted at the beginning of the line."
+ (gnus-summary-mark-article article mark))
+
+(defun gnus-summary-clear-mark-forward (n)
+ "Clear marks from N articles forward.
+If N is negative, clear backward instead.
+The difference between N and the number of marks cleared is returned."
+ (interactive "p")
+ (gnus-summary-mark-forward n gnus-unread-mark))
+
+(defun gnus-summary-clear-mark-backward (n)
+ "Clear marks from N articles backward.
+The difference between N and the number of marks cleared is returned."
+ (interactive "p")
+ (gnus-summary-mark-forward (- n) gnus-unread-mark))
+
+(defun gnus-summary-mark-unread-as-read ()
+ "Intended to be used by `gnus-summary-mark-article-hook'."
+ (or (memq gnus-current-article gnus-newsgroup-marked)
+ (memq gnus-current-article gnus-newsgroup-dormant)
+ (memq gnus-current-article gnus-newsgroup-expirable)
+ (gnus-summary-mark-article gnus-current-article gnus-read-mark)))
+
+(defun gnus-summary-mark-region-as-read (point mark all)
+ "Mark all unread articles between point and mark as read.
+If given a prefix, mark all articles between point and mark as read,
+even ticked and dormant ones."
+ (interactive "r\nP")
+ (save-excursion
+ (goto-char point)
+ (beginning-of-line)
+ (while (and
+ (< (point) mark)
+ (progn
+ (and
+ (or all
+ (and
+ (not (memq (gnus-summary-article-number)
+ gnus-newsgroup-marked))
+ (not (memq (gnus-summary-article-number)
+ gnus-newsgroup-dormant))))
+ (gnus-summary-mark-article
+ (gnus-summary-article-number) gnus-del-mark))
+ t)
+ (zerop (forward-line 1))))))
+
+;; Fix by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defalias 'gnus-summary-delete-marked-as-read
+ 'gnus-summary-remove-lines-marked-as-read)
+(make-obsolete 'gnus-summary-delete-marked-as-read
+ 'gnus-summary-remove-lines-marked-as-read)
+(defun gnus-summary-remove-lines-marked-as-read ()
+ "Remove lines that are marked as read."
+ (interactive)
+ (gnus-summary-remove-lines-marked-with
+ (concat (mapconcat
+ (lambda (char) (char-to-string (symbol-value char)))
+ '(gnus-del-mark gnus-read-mark gnus-ancient-mark
+ gnus-killed-mark gnus-kill-file-mark
+ gnus-low-score-mark gnus-expirable-mark
+ gnus-canceled-mark gnus-catchup-mark)
+ ""))))
+
+(defalias 'gnus-summary-delete-marked-with
+ 'gnus-summary-remove-lines-marked-with)
+(make-obsolete 'gnus-summary-delete-marked-with
+ 'gnus-summary-remove-lines-marked-with)
+;; Rewrite by Daniel Quinlan <quinlan@best.com>.
+(defun gnus-summary-remove-lines-marked-with (marks)
+ "Remove lines that are marked with MARKS (e.g. \"DK\")."
+ (interactive "sMarks: ")
+ ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
+ (gnus-set-global-variables)
+ (let ((buffer-read-only nil)
+ (orig-article (gnus-summary-article-number))
+ (marks (concat "^[" marks "]")))
+ (goto-char (point-min))
+ (if gnus-newsgroup-adaptive
+ (gnus-score-remove-lines-adaptive marks)
+ (while (re-search-forward marks nil t)
+ (gnus-delete-line)))
+ ;; If we use dummy roots, we have to do an additional sweep over
+ ;; the buffer.
+ (if (not (eq gnus-summary-make-false-root 'dummy))
+ ()
+ (goto-char (point-min))
+ (setq marks (concat "^[" (char-to-string gnus-dummy-mark) "]"))
+ (while (re-search-forward marks nil t)
+ (if (gnus-subject-equal
+ (gnus-summary-subject-string)
+ (progn
+ (forward-line 1)
+ (gnus-summary-subject-string)))
+ ()
+ (forward-line -1)
+ (gnus-delete-line))))
+ (or (zerop (buffer-size))
+ (gnus-summary-goto-subject orig-article)
+ (if (eobp)
+ (gnus-summary-prev-subject 1)
+ (gnus-summary-position-cursor)))))
+
+(defun gnus-summary-expunge-below (&optional score)
+ "Remove articles with score less than SCORE."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (setq score (if score
+ (prefix-numeric-value score)
+ (or gnus-summary-default-score 0)))
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (goto-char (point-min))
+ (let ((buffer-read-only nil)
+ beg)
+ (while (not (eobp))
+ (if (< (gnus-summary-article-score) score)
+ (progn
+ (setq beg (point))
+ (forward-line 1)
+ (delete-region beg (point)))
+ (forward-line 1)))
+ ;; Adjust point.
+ (or (zerop (buffer-size))
+ (if (eobp)
+ (gnus-summary-prev-subject 1)
+ (gnus-summary-position-cursor))))))
+
+(defun gnus-summary-mark-below (score mark)
+ "Mark articles with score less than SCORE with MARK."
+ (interactive "P\ncMark: ")
+ (gnus-set-global-variables)
+ (setq score (if score
+ (prefix-numeric-value score)
+ (or gnus-summary-default-score 0)))
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (and (< (gnus-summary-article-score) score)
+ (gnus-summary-mark-article nil mark))
+ (forward-line 1))))
+
+(defun gnus-summary-kill-below (&optional score)
+ "Mark articles with score below SCORE as read."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-mark-below score gnus-killed-mark))
+
+(defun gnus-summary-clear-above (&optional score)
+ "Clear all marks from articles with score above SCORE."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-mark-above score gnus-unread-mark))
+
+(defun gnus-summary-tick-above (&optional score)
+ "Tick all articles with score above SCORE."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-mark-above score gnus-ticked-mark))
+
+(defun gnus-summary-mark-above (score mark)
+ "Mark articles with score over SCORE with MARK."
+ (interactive "P\ncMark: ")
+ (gnus-set-global-variables)
+ (setq score (if score
+ (prefix-numeric-value score)
+ (or gnus-summary-default-score 0)))
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (if (> (gnus-summary-article-score) score)
+ (progn
+ (gnus-summary-mark-article nil mark)
+ (forward-line 1))
+ (forward-line 1)))))
+
+;; Suggested by Daniel Quinlan <quinlan@best.com>.
+(defun gnus-summary-show-all-expunged ()
+ "Display all the hidden articles that were expunged for low scores."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((buffer-read-only nil))
+ (let ((scored gnus-newsgroup-scored)
+ headers h)
+ (while scored
+ (or (gnus-summary-goto-subject (car (car scored)))
+ (and (setq h (gnus-get-header-by-num (car (car scored))))
+ (< (cdr (car scored)) gnus-summary-expunge-below)
+ (setq headers (cons h headers))))
+ (setq scored (cdr scored)))
+ (or headers (error "No expunged articles hidden."))
+ (goto-char (point-min))
+ (save-excursion
+ (gnus-summary-update-lines
+ (point)
+ (progn
+ (gnus-summary-prepare-unthreaded (nreverse headers))
+ (point)))))
+ (goto-char (point-min))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-show-all-dormant ()
+ "Display all the hidden articles that are marked as dormant."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((buffer-read-only nil))
+ (let ((dormant gnus-newsgroup-dormant)
+ headers h)
+ (while dormant
+ (or (gnus-summary-goto-subject (car dormant))
+ (and (setq h (gnus-get-header-by-num (car dormant)))
+ (setq headers (cons h headers))))
+ (setq dormant (cdr dormant)))
+ (or headers (error "No dormant articles hidden."))
+ (goto-char (point-min))
+ (save-excursion
+ (gnus-summary-update-lines
+ (point)
+ (progn
+ (gnus-summary-prepare-unthreaded (nreverse headers))
+ (point)))))
+ (goto-char (point-min))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-hide-all-dormant ()
+ "Hide all dormant articles."
+ (interactive)
+ (gnus-set-global-variables)
+ (gnus-summary-remove-lines-marked-with (char-to-string gnus-dormant-mark))
+ (gnus-summary-position-cursor))
+
+(defun gnus-summary-catchup (&optional all quietly to-here not-mark)
+ "Mark all articles not marked as unread in this newsgroup as read.
+If prefix argument ALL is non-nil, all articles are marked as read.
+If QUIETLY is non-nil, no questions will be asked.
+If TO-HERE is non-nil, it should be a point in the buffer. All
+articles before this point will be marked as read.
+The number of articles marked as read is returned."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (prog1
+ (if (or quietly
+ (not gnus-interactive-catchup) ;Without confirmation?
+ gnus-expert-user
+ (gnus-y-or-n-p
+ (if all
+ "Mark absolutely all articles as read? "
+ "Mark all unread articles as read? ")))
+ (if (and not-mark
+ (not gnus-newsgroup-adaptive)
+ (not gnus-newsgroup-auto-expire))
+ (progn
+ (and all (setq gnus-newsgroup-marked nil
+ gnus-newsgroup-dormant nil))
+ (setq gnus-newsgroup-unreads
+ (append gnus-newsgroup-marked gnus-newsgroup-dormant)))
+ ;; We actually mark all articles as canceled, which we
+ ;; have to do when using auto-expiry or adaptive scoring.
+ (gnus-summary-show-all-threads)
+ (if (gnus-summary-first-subject (not all))
+ (while (and
+ (if to-here (< (point) to-here) t)
+ (gnus-summary-mark-article-as-read gnus-catchup-mark)
+ (gnus-summary-search-subject nil (not all)))))
+ (or to-here
+ (setq gnus-newsgroup-unreads
+ (append gnus-newsgroup-marked
+ gnus-newsgroup-dormant)))))
+ (let ((method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (if (and (not to-here) (eq 'nnvirtual (car method)))
+ (nnvirtual-catchup-group
+ (gnus-group-real-name gnus-newsgroup-name) (nth 1 method) all)))
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-catchup-to-here (&optional all)
+ "Mark all unticked articles before the current one as read.
+If ALL is non-nil, also mark ticked and dormant articles as read."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (save-excursion
+ (and (zerop (forward-line -1))
+ (progn
+ (end-of-line)
+ (gnus-summary-catchup all t (point))
+ (gnus-set-mode-line 'summary))))
+ (gnus-summary-position-cursor))
+
+(defun gnus-summary-catchup-all (&optional quietly)
+ "Mark all articles in this newsgroup as read."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-catchup t quietly))
+
+(defun gnus-summary-catchup-and-exit (&optional all quietly)
+ "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")
+ (gnus-set-global-variables)
+ (gnus-summary-catchup all quietly nil 'fast)
+ ;; Select next newsgroup or exit.
+ (if (and (eq gnus-auto-select-next 'quietly)
+ (not (gnus-ephemeral-group-p gnus-newsgroup-name)))
+ (gnus-summary-next-group nil)
+ (gnus-summary-exit)))
+
+(defun gnus-summary-catchup-all-and-exit (&optional quietly)
+ "Mark all articles in this newsgroup as read, and then exit."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-catchup-and-exit t quietly))
+
+;; Suggested by "Arne Eofsson" <arne@hodgkin.mbi.ucla.edu>.
+(defun gnus-summary-catchup-and-goto-next-group (&optional all)
+ "Mark all articles in this group as read and select the next group.
+If given a prefix, mark all articles, unread as well as ticked, as
+read."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-catchup all)
+ (gnus-summary-next-group))
+
+;; Thread-based commands.
+
+(defun gnus-summary-toggle-threads (&optional arg)
+ "Toggle showing conversation threads.
+If ARG is positive number, turn showing conversation threads on."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((current (or (gnus-summary-article-number) gnus-newsgroup-end)))
+ (setq gnus-show-threads
+ (if (null arg) (not gnus-show-threads)
+ (> (prefix-numeric-value arg) 0)))
+ (gnus-summary-prepare)
+ (gnus-summary-goto-subject current)
+ (gnus-summary-position-cursor)))
+
+(defun gnus-summary-show-all-threads ()
+ "Show all threads."
+ (interactive)
+ (gnus-set-global-variables)
+ (save-excursion
+ (let ((buffer-read-only nil))
+ (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)))
+ (gnus-summary-position-cursor))
+
+(defun gnus-summary-show-thread ()
+ "Show thread subtrees.
+Returns nil if no thread was there to be shown."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((buffer-read-only nil)
+ (orig (prog1 (point) (gnus-summary-hide-thread)))
+ ;; first goto end then to beg, to have point at beg after let
+ (end (progn (end-of-line) (point)))
+ (beg (progn (beginning-of-line) (point))))
+ (prog1
+ ;; Any hidden lines here?
+ (search-forward "\r" end t)
+ (subst-char-in-region beg end ?\^M ?\n t)
+ (goto-char orig)
+ (gnus-summary-position-cursor))))
+
+(defun gnus-summary-hide-all-threads ()
+ "Hide all thread subtrees."
+ (interactive)
+ (gnus-set-global-variables)
+ (save-excursion
+ (goto-char (point-min))
+ (gnus-summary-hide-thread)
+ (while (and (not (eobp)) (zerop (forward-line 1)))
+ (gnus-summary-hide-thread)))
+ (gnus-summary-position-cursor))
+
+(defun gnus-summary-hide-thread ()
+ "Hide thread subtrees.
+Returns nil if no threads were there to be hidden."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((buffer-read-only nil)
+ (start (point))
+ (level (gnus-summary-thread-level))
+ (end (point)))
+ ;; Go forward until either the buffer ends or the subthread
+ ;; ends.
+ (if (eobp)
+ ()
+ (while (and (zerop (forward-line 1))
+ (> (gnus-summary-thread-level) level))
+ (setq end (point)))
+ (prog1
+ (save-excursion
+ (goto-char end)
+ (search-backward "\n" start t))
+ (subst-char-in-region start end ?\n ?\^M t)
+ (forward-line -1)
+ (gnus-summary-position-cursor)))))
+
+(defun gnus-summary-go-to-next-thread (&optional previous)
+ "Go to the same level (or less) next thread.
+If PREVIOUS is non-nil, go to previous thread instead.
+Return the article number moved to, or nil if moving was impossible."
+ (let ((level (gnus-summary-thread-level))
+ (article (gnus-summary-article-number)))
+ (if previous
+ (while (and (zerop (forward-line -1))
+ (> (gnus-summary-thread-level) level)))
+ (while (and (save-excursion
+ (forward-line 1)
+ (not (eobp)))
+ (zerop (forward-line 1))
+ (> (gnus-summary-thread-level) level))))
+ (gnus-summary-recenter)
+ (gnus-summary-position-cursor)
+ (let ((oart (gnus-summary-article-number)))
+ (and (/= oart article) oart))))
+
+(defun gnus-summary-next-thread (n)
+ "Go to the same level next N'th thread.
+If N is negative, search backward instead.
+Returns the difference between N and the number of skips actually
+done."
+ (interactive "p")
+ (gnus-set-global-variables)
+ (let ((backward (< n 0))
+ (n (abs n)))
+ (while (and (> n 0)
+ (gnus-summary-go-to-next-thread backward))
+ (setq n (1- n)))
+ (gnus-summary-position-cursor)
+ (if (/= 0 n) (gnus-message 7 "No more threads"))
+ n))
+
+(defun gnus-summary-prev-thread (n)
+ "Go to the same level previous N'th thread.
+Returns the difference between N and the number of skips actually
+done."
+ (interactive "p")
+ (gnus-set-global-variables)
+ (gnus-summary-next-thread (- n)))
+
+(defun gnus-summary-go-down-thread (&optional same)
+ "Go down one level in the current thread.
+If SAME is non-nil, also move to articles of the same level."
+ (let ((level (gnus-summary-thread-level))
+ (start (point)))
+ (if (and (zerop (forward-line 1))
+ (> (gnus-summary-thread-level) level))
+ t
+ (goto-char start)
+ nil)))
+
+(defun gnus-summary-go-up-thread ()
+ "Go up one level in the current thread."
+ (let ((level (gnus-summary-thread-level))
+ (start (point)))
+ (while (and (zerop (forward-line -1))
+ (>= (gnus-summary-thread-level) level)))
+ (if (>= (gnus-summary-thread-level) level)
+ (progn
+ (goto-char start)
+ nil)
+ t)))
+
+(defun gnus-summary-down-thread (n)
+ "Go down thread N steps.
+If N is negative, go up instead.
+Returns the difference between N and how many steps down that were
+taken."
+ (interactive "p")
+ (gnus-set-global-variables)
+ (let ((up (< n 0))
+ (n (abs n)))
+ (while (and (> n 0)
+ (if up (gnus-summary-go-up-thread)
+ (gnus-summary-go-down-thread)))
+ (setq n (1- n)))
+ (gnus-summary-position-cursor)
+ (if (/= 0 n) (gnus-message 7 "Can't go further"))
+ n))
+
+(defun gnus-summary-up-thread (n)
+ "Go up thread N steps.
+If N is negative, go up instead.
+Returns the difference between N and how many steps down that were
+taken."
+ (interactive "p")
+ (gnus-set-global-variables)
+ (gnus-summary-down-thread (- n)))
+
+(defun gnus-summary-kill-thread (&optional unmark)
+ "Mark articles under current thread as read.
+If the prefix argument is positive, remove any kinds of marks.
+If the prefix argument is negative, tick articles instead."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (if unmark
+ (setq unmark (prefix-numeric-value unmark)))
+ (let ((killing t)
+ (level (gnus-summary-thread-level)))
+ (save-excursion
+ ;; Expand the thread.
+ (gnus-summary-show-thread)
+ (while killing
+ ;; Mark the article...
+ (cond ((null unmark) (gnus-summary-mark-article-as-read
+ gnus-killed-mark))
+ ((> unmark 0) (gnus-summary-mark-article-as-unread
+ gnus-unread-mark))
+ (t (gnus-summary-mark-article-as-unread gnus-ticked-mark)))
+ ;; ...and go forward until either the buffer ends or the subtree
+ ;; ends.
+ (if (not (and (zerop (forward-line 1))
+ (> (gnus-summary-thread-level) level)))
+ (setq killing nil))))
+ ;; Hide killed subtrees.
+ (and (null unmark)
+ gnus-thread-hide-killed
+ (gnus-summary-hide-thread))
+ ;; If marked as read, go to next unread subject.
+ (if (null unmark)
+ ;; Go to next unread subject.
+ (gnus-summary-next-subject 1 t)))
+ (gnus-set-mode-line 'summary))
+
+;; Summary sorting commands
+
+(defun gnus-summary-sort-by-number (&optional reverse)
+ "Sort summary buffer by article number.
+Argument REVERSE means reverse order."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-sort
+ ;; `gnus-summary-article-number' is a macro, and `sort-subr' wants
+ ;; a function, so we wrap it.
+ (cons (lambda () (gnus-summary-article-number))
+ 'gnus-thread-sort-by-number) reverse))
+
+(defun gnus-summary-sort-by-author (&optional reverse)
+ "Sort summary buffer by author name alphabetically.
+If case-fold-search is non-nil, case of letters is ignored.
+Argument REVERSE means reverse order."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-sort
+ (cons
+ (lambda ()
+ (let* ((header (gnus-get-header-by-num (gnus-summary-article-number)))
+ (extract (funcall
+ gnus-extract-address-components
+ (mail-header-from header))))
+ (concat (or (car extract) (cdr extract))
+ "\r" (int-to-string (mail-header-number header))
+ "\r" (mail-header-subject header))))
+ 'gnus-thread-sort-by-author)
+ reverse))
+
+(defun gnus-summary-sort-by-subject (&optional reverse)
+ "Sort summary buffer by subject alphabetically. `Re:'s are ignored.
+If case-fold-search is non-nil, case of letters is ignored.
+Argument REVERSE means reverse order."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-sort
+ (cons
+ (lambda ()
+ (let* ((header (gnus-get-header-by-num (gnus-summary-article-number)))
+ (extract (funcall
+ gnus-extract-address-components
+ (mail-header-from header))))
+ (concat
+ (downcase (gnus-simplify-subject (gnus-summary-subject-string) t))
+ "\r" (int-to-string (mail-header-number header))
+ "\r" (or (car extract) (cdr extract)))))
+ 'gnus-thread-sort-by-subject)
+ reverse))
+
+(defun gnus-summary-sort-by-date (&optional reverse)
+ "Sort summary buffer by date.
+Argument REVERSE means reverse order."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-sort
+ (cons
+ (lambda ()
+ (gnus-sortable-date
+ (mail-header-date
+ (gnus-get-header-by-num (gnus-summary-article-number)))))
+ 'gnus-thread-sort-by-date)
+ reverse))
+
+(defun gnus-summary-sort-by-score (&optional reverse)
+ "Sort summary buffer by score.
+Argument REVERSE means reverse order."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (gnus-summary-sort
+ (cons (lambda () (gnus-summary-article-score))
+ 'gnus-thread-sort-by-score)
+ (not reverse)))
+
+(defvar gnus-summary-already-sorted nil)
+(defun gnus-summary-sort (predicate reverse)
+ ;; Sort summary buffer by PREDICATE. REVERSE means reverse order.
+ (if gnus-summary-already-sorted
+ ()
+ (let (buffer-read-only)
+ (if (not gnus-show-threads)
+ ;; We do untreaded sorting...
+ (progn
+ (goto-char (point-min))
+ (sort-subr reverse 'forward-line 'end-of-line (car predicate)))
+ ;; ... or we do threaded sorting.
+ (let ((gnus-thread-sort-functions (list (cdr predicate)))
+ (gnus-summary-prepare-hook nil)
+ (gnus-summary-already-sorted nil))
+ ;; We do that by simply regenerating the threads.
+ (gnus-summary-prepare)
+ (and gnus-show-threads
+ gnus-thread-hide-subtree
+ (gnus-summary-hide-all-threads))
+ ;; If in async mode, we send some info to the backend.
+ (and gnus-newsgroup-async
+ (setq gnus-newsgroup-threads (nreverse gnus-newsgroup-threads))
+ (gnus-request-asynchronous
+ gnus-newsgroup-name
+ (if (and gnus-asynchronous-article-function
+ (fboundp gnus-asynchronous-article-function))
+ (funcall gnus-asynchronous-article-function
+ gnus-newsgroup-threads)
+ gnus-newsgroup-threads))))))))
+
+
+(defun gnus-sortable-date (date)
+ "Make sortable string by string-lessp from DATE.
+Timezone package is used."
+ (let* ((date (timezone-fix-time date nil nil)) ;[Y M D H M S]
+ (year (aref date 0))
+ (month (aref date 1))
+ (day (aref date 2)))
+ (timezone-make-sortable-date
+ year month day
+ (timezone-make-time-string
+ (aref date 3) (aref date 4) (aref date 5)))))
+
+
+;; Summary saving commands.
+
+(defun gnus-summary-save-article (&optional n)
+ "Save the current article using the default saver function.
+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.
+The variable `gnus-default-article-saver' specifies the saver function."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((articles (gnus-summary-work-articles n)))
+ (while articles
+ (let ((header (gnus-get-header-by-num (car articles))))
+ (if (vectorp header)
+ (progn
+ (save-window-excursion
+ (gnus-summary-select-article t nil nil (car articles)))
+ (or gnus-save-all-headers
+ (gnus-article-hide-headers t))
+ ;; Remove any X-Gnus lines.
+ (save-excursion
+ (save-restriction
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (narrow-to-region (point) (or (search-forward "\n\n" nil t)
+ (point-max)))
+ (while (re-search-forward "^X-Gnus" nil t)
+ (beginning-of-line)
+ (delete-region (point)
+ (progn (forward-line 1) (point))))
+ (widen))))
+ (save-window-excursion
+ (if gnus-default-article-saver
+ (funcall gnus-default-article-saver)
+ (error "No default saver is defined."))))
+ (if (assq 'name header)
+ (gnus-copy-file (cdr (assq 'name header)))
+ (gnus-message 1 "Article %d is unsaveable" (car articles)))))
+ (gnus-summary-remove-process-mark (car articles))
+ (setq articles (cdr articles)))
+ (gnus-summary-position-cursor)
+ n))
+
+(defun gnus-summary-pipe-output (&optional arg)
+ "Pipe the current article to a subprocess.
+If N is a positive number, pipe the N next articles.
+If N is a negative number, pipe the N previous articles.
+If N is nil and any articles have been marked with the process mark,
+pipe those articles instead."
+ (interactive "P")
+ (gnus-set-global-variables)
+ (let ((gnus-default-article-saver 'gnus-summary-save-in-pipe))
+ (gnus-summary-save-article arg)))
+
+(defun gnus-summary-save-article-mail (&optional arg)
+ "Append the current article to an mail file.
+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")
+ (gnus-set-global-variables)
+ (let ((gnus-default-article-saver 'gnus-summary-save-in-mail))
+ (gnus-summary-save-article arg)))
+
+(defun gnus-summary-save-article-rmail (&optional arg)
+ "Append the current article to an rmail file.
+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")
+ (gnus-set-global-variables)
+ (let ((gnus-default-article-saver 'gnus-summary-save-in-rmail))
+ (gnus-summary-save-article arg)))
+
+(defun gnus-summary-save-article-file (&optional arg)
+ "Append the current article to a file.
+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")
+ (gnus-set-global-variables)
+ (let ((gnus-default-article-saver 'gnus-summary-save-in-file))
+ (gnus-summary-save-article arg)))
+
+(defun gnus-read-save-file-name (prompt default-name)
+ (let ((methods gnus-split-methods)
+ split-name)
+ (if (not gnus-split-methods)
+ ()
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (gnus-narrow-to-headers)
+ (while methods
+ (goto-char (point-min))
+ (and (condition-case ()
+ (re-search-forward (car (car methods)) nil t)
+ (error nil))
+ (setq split-name (cons (nth 1 (car methods)) split-name)))
+ (setq methods (cdr methods)))
+ (widen)))
+ (cond ((null split-name)
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ((= 1 (length split-name))
+ (read-file-name
+ (concat prompt " (default " (car split-name) ") ")
+ gnus-article-save-directory
+ (concat gnus-article-save-directory (car split-name))))
+ (t
+ (setq split-name (mapcar (lambda (el) (list el))
+ (nreverse split-name)))
+ (let ((result (completing-read
+ (concat prompt " ")
+ split-name nil nil)))
+ (concat gnus-article-save-directory
+ (if (string= result "")
+ (car (car split-name))
+ result)))))))
+
+(defun gnus-summary-save-in-rmail (&optional filename)
+ "Append this article to Rmail file.
+Optional argument FILENAME specifies file name.
+Directory to save to is default to `gnus-article-save-directory' which
+is initialized from the SAVEDIR environment variable."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((default-name
+ (funcall gnus-rmail-save-name gnus-newsgroup-name
+ gnus-current-headers gnus-newsgroup-last-rmail)))
+ (or filename
+ (setq filename (gnus-read-save-file-name
+ "Save in rmail file:" default-name)))
+ (gnus-make-directory (file-name-directory filename))
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (gnus-output-to-rmail filename))))
+ ;; Remember the directory name to save articles
+ (setq gnus-newsgroup-last-rmail filename)))
+
+(defun gnus-summary-save-in-mail (&optional filename)
+ "Append this article to Unix mail file.
+Optional argument FILENAME specifies file name.
+Directory to save to is default to `gnus-article-save-directory' which
+is initialized from the SAVEDIR environment variable."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((default-name
+ (funcall gnus-mail-save-name gnus-newsgroup-name
+ gnus-current-headers gnus-newsgroup-last-mail)))
+ (or filename
+ (setq filename (gnus-read-save-file-name
+ "Save in Unix mail file:" default-name)))
+ (setq filename
+ (expand-file-name filename
+ (and default-name
+ (file-name-directory default-name))))
+ (gnus-make-directory (file-name-directory filename))
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (if (and (file-readable-p filename) (mail-file-babyl-p filename))
+ (gnus-output-to-rmail filename)
+ (rmail-output filename 1 t t)))))
+ ;; Remember the directory name to save articles.
+ (setq gnus-newsgroup-last-mail filename)))
+
+(defun gnus-summary-save-in-file (&optional filename)
+ "Append this article to file.
+Optional argument FILENAME specifies file name.
+Directory to save to is default to `gnus-article-save-directory' which
+is initialized from the SAVEDIR environment variable."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((default-name
+ (funcall gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers gnus-newsgroup-last-file)))
+ (or filename
+ (setq filename (gnus-read-save-file-name
+ "Save in file:" default-name)))
+ (gnus-make-directory (file-name-directory filename))
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (save-excursion
+ (save-restriction
+ (widen)
+ (gnus-output-to-file filename))))
+ ;; Remember the directory name to save articles.
+ (setq gnus-newsgroup-last-file filename)))
+
+(defun gnus-summary-save-in-pipe (&optional command)
+ "Pipe this article to subprocess."
+ (interactive)
+ (gnus-set-global-variables)
+ (let ((command (read-string "Shell command on article: "
+ gnus-last-shell-command)))
+ (if (string-equal command "")
+ (setq command gnus-last-shell-command))
+ (gnus-eval-in-buffer-window
+ gnus-article-buffer
+ (save-restriction
+ (widen)
+ (shell-command-on-region (point-min) (point-max) command nil)))
+ (setq gnus-last-shell-command command)))
+
+;; Summary extract commands
+
+(defun gnus-summary-insert-pseudos (pslist &optional not-view)
+ (let ((buffer-read-only nil)
+ (article (gnus-summary-article-number))
+ b)
+ (or (gnus-summary-goto-subject article)
+ (error (format "No such article: %d" article)))
+ (gnus-summary-position-cursor)
+ ;; If all commands are to be bunched up on one line, we collect
+ ;; them here.
+ (if gnus-view-pseudos-separately
+ ()
+ (let ((ps (setq pslist (sort pslist 'gnus-pseudos<)))
+ files action)
+ (while ps
+ (setq action (cdr (assq 'action (car ps))))
+ (setq files (list (cdr (assq 'name (car ps)))))
+ (while (and ps (cdr ps)
+ (string= (or action "1")
+ (or (cdr (assq 'action (car (cdr ps)))) "2")))
+ (setq files (cons (cdr (assq 'name (car (cdr ps)))) files))
+ (setcdr ps (cdr (cdr ps))))
+ (if (not files)
+ ()
+ (if (not (string-match "%s" action))
+ (setq files (cons " " files)))
+ (setq files (cons " " files))
+ (and (assq 'execute (car ps))
+ (setcdr (assq 'execute (car ps))
+ (funcall (if (string-match "%s" action)
+ 'format 'concat)
+ action
+ (mapconcat (lambda (f) f) files " ")))))
+ (setq ps (cdr ps)))))
+ (if (and gnus-view-pseudos (not not-view))
+ (while pslist
+ (and (assq 'execute (car pslist))
+ (gnus-execute-command (cdr (assq 'execute (car pslist)))
+ (eq gnus-view-pseudos 'not-confirm)))
+ (setq pslist (cdr pslist)))
+ (save-excursion
+ (while pslist
+ (gnus-summary-goto-subject (or (cdr (assq 'article (car pslist)))
+ (gnus-summary-article-number)))
+ (forward-line 1)
+ (setq b (point))
+ (insert " " (file-name-nondirectory
+ (cdr (assq 'name (car pslist))))
+ ": " (or (cdr (assq 'execute (car pslist))) "") "\n")
+ (add-text-properties
+ b (1+ b) (list 'gnus-number gnus-reffed-article-number
+ 'gnus-mark gnus-unread-mark
+ 'gnus-level 0
+ 'gnus-pseudo (car pslist)))
+ (forward-line -1)
+ (gnus-sethash (int-to-string gnus-reffed-article-number)
+ (car pslist) gnus-newsgroup-headers-hashtb-by-number)
+ (setq gnus-newsgroup-unreads
+ (cons gnus-reffed-article-number gnus-newsgroup-unreads))
+ (setq gnus-reffed-article-number (1- gnus-reffed-article-number))
+ (setq pslist (cdr pslist)))))))
+
+(defun gnus-pseudos< (p1 p2)
+ (let ((c1 (cdr (assq 'action p1)))
+ (c2 (cdr (assq 'action p2))))
+ (and c1 c2 (string< c1 c2))))
+
+(defun gnus-request-pseudo-article (props)
+ (cond ((assq 'execute props)
+ (gnus-execute-command (cdr (assq 'execute props)))))
+ (let ((gnus-current-article (gnus-summary-article-number)))
+ (run-hooks 'gnus-mark-article-hook)))
+
+(defun gnus-execute-command (command &optional automatic)
+ (save-excursion
+ (gnus-article-setup-buffer)
+ (set-buffer gnus-article-buffer)
+ (let ((command (if automatic command (read-string "Command: " command)))
+ (buffer-read-only nil))
+ (erase-buffer)
+ (insert "$ " command "\n\n")
+ (if gnus-view-pseudo-asynchronously
+ (start-process "gnus-execute" nil "sh" "-c" command)
+ (call-process "sh" nil t nil "-c" command)))))
+
+(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)))
+ (gnus-set-global-variables)
+ (or to (setq to (read-file-name "Copy file to: " default-directory)))
+ (and (file-directory-p to)
+ (setq to (concat (file-name-as-directory to)
+ (file-name-nondirectory file))))
+ (copy-file file to))
+
+;; Summary kill commands.
+
+(defun gnus-summary-edit-global-kill (article)
+ "Edit the \"global\" kill file."
+ (interactive (list (gnus-summary-article-number)))
+ (gnus-set-global-variables)
+ (gnus-group-edit-global-kill article))
+
+(defun gnus-summary-edit-local-kill ()
+ "Edit a local kill file applied to the current newsgroup."
+ (interactive)
+ (gnus-set-global-variables)
+ (setq gnus-current-headers
+ (gnus-gethash
+ (int-to-string (gnus-summary-article-number))
+ gnus-newsgroup-headers-hashtb-by-number))
+ (gnus-set-global-variables)
+ (gnus-group-edit-local-kill
+ (gnus-summary-article-number) gnus-newsgroup-name))
+
+
+;;;
+;;; Gnus article mode
+;;;
+
+(put 'gnus-article-mode 'mode-class 'special)
+
+(defvar gnus-boogaboo nil)
+
+(if gnus-article-mode-map
+ nil
+ (setq gnus-article-mode-map (make-keymap))
+ (suppress-keymap gnus-article-mode-map)
+ (define-key gnus-article-mode-map " " 'gnus-article-next-page)
+ (define-key gnus-article-mode-map "\177" 'gnus-article-prev-page)
+ (define-key gnus-article-mode-map "\C-c^" 'gnus-article-refer-article)
+ (define-key gnus-article-mode-map "h" 'gnus-article-show-summary)
+ (define-key gnus-article-mode-map "s" 'gnus-article-show-summary)
+ (define-key gnus-article-mode-map "\C-c\C-m" 'gnus-article-mail)
+ (define-key gnus-article-mode-map "?" 'gnus-article-describe-briefly)
+ (define-key gnus-article-mode-map gnus-mouse-2 'gnus-article-push-button)
+ (define-key gnus-article-mode-map "\r" 'gnus-article-press-button)
+ (define-key gnus-article-mode-map "\t" 'gnus-article-next-button)
+ (define-key gnus-article-mode-map "\C-c\C-b" 'gnus-bug)
+
+ ;; Duplicate almost all summary keystrokes in the article mode map.
+ (let ((commands
+ (list
+ "p" "N" "P" "\M-\C-n" "\M-\C-p"
+ "\M-n" "\M-p" "." "," "\M-s" "\M-r" "<" ">" "j"
+ "u" "!" "U" "d" "D" "E" "\M-u" "\M-U" "k" "\C-k" "\M-\C-k"
+ "\M-\C-l" "e" "#" "\M-#" "\M-\C-t" "\M-\C-s" "\M-\C-h"
+ "\M-\C-f" "\M-\C-b" "\M-\C-u" "\M-\C-d" "&" "\C-w"
+ "\C-t" "?" "\C-c\M-\C-s" "\C-c\C-s\C-n" "\C-c\C-s\C-a"
+ "\C-c\C-s\C-s" "\C-c\C-s\C-d" "\C-c\C-s\C-i" "\C-x\C-s"
+ "\M-g" "w" "\C-c\C-r" "\M-t" "C"
+ "o" "\C-o" "|" "\M-k" "\M-K" "V" "\C-c\C-d"
+ "\C-c\C-i" "x" "X" "t" "g" "?" "l"
+ "\C-c\C-v\C-v" "\C-d" "v"
+;; "Mt" "M!" "Md" "Mr"
+;; "Mc" "M " "Me" "Mx" "M?" "Mb" "MB" "M#" "M\M-#" "M\M-r"
+;; "M\M-\C-r" "MD" "M\M-D" "MS" "MC" "MH" "M\C-c" "Mk" "MK"
+;; "Ms" "Mc" "Mu" "Mm" "Mk" "Gn" "Gp" "GN" "GP" "G\C-n" "G\C-p"
+;; "G\M-n" "G\M-p" "Gf" "Gb" "Gg" "Gl" "Gp" "Tk" "Tl" "Ti" "TT"
+;; "Ts" "TS" "Th" "TH" "Tn" "Tp" "Tu" "Td" "T#" "A " "An" "A\177" "Ap"
+;; "A\r" "A<" "A>" "Ab" "Ae" "A^" "Ar" "Aw" "Ac" "Ag" "At" "Am"
+;; "As" "Wh" "Ws" "Wc" "Wo" "Ww" "Wd" "Wq" "Wf" "Wt" "W\C-t"
+;; "WT" "WA" "Wa" "WH" "WC" "WS" "Wb" "Hv" "Hf" "Hd" "Hh" "Hi"
+;; "Be" "B\177" "Bm" "Br" "Bw" "Bc" "Bq" "Bi" "Oo" "Om" "Or"
+;; "Of" "Oh" "Ov" "Op" "Vu" "V\C-s" "V\C-r" "Vr" "V&" "VT" "Ve"
+;; "VD" "Vk" "VK" "Vsn" "Vsa" "Vss" "Vsd" "Vsi"
+ )))
+ (while (and gnus-boogaboo commands) ; disabled
+ (define-key gnus-article-mode-map (car commands)
+ 'gnus-article-summary-command)
+ (setq commands (cdr commands))))
+
+ (let ((commands (list "q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
+;; "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
+ "=" "n" "^" "\M-^")))
+ (while (and gnus-boogaboo commands) ; disabled
+ (define-key gnus-article-mode-map (car commands)
+ 'gnus-article-summary-command-nosave)
+ (setq commands (cdr commands)))))
+
+
+(defun gnus-article-mode ()
+ "Major mode for displaying an article.
+
+All normal editing commands are switched off.
+
+The following commands are available:
+
+\\<gnus-article-mode-map>
+\\[gnus-article-next-page]\t Scroll the article one page forwards
+\\[gnus-article-prev-page]\t Scroll the article one page backwards
+\\[gnus-article-refer-article]\t Go to the article referred to by an article id near point
+\\[gnus-article-show-summary]\t Display the summary buffer
+\\[gnus-article-mail]\t Send a reply to the address near point
+\\[gnus-article-describe-briefly]\t Describe the current mode briefly
+\\[gnus-info-find-node]\t Go to the Gnus info node"
+ (interactive)
+ (if gnus-visual (gnus-article-make-menu-bar))
+ (kill-all-local-variables)
+ (setq mode-line-modified "-- ")
+ (make-local-variable 'mode-line-format)
+ (setq mode-line-format (copy-sequence mode-line-format))
+ (and (equal (nth 3 mode-line-format) " ")
+ (setcar (nthcdr 3 mode-line-format) ""))
+ (setq mode-name "Article")
+ (setq major-mode 'gnus-article-mode)
+ (make-local-variable 'minor-mode-alist)
+ (or (assq 'gnus-show-mime minor-mode-alist)
+ (setq minor-mode-alist
+ (cons (list 'gnus-show-mime " MIME") minor-mode-alist)))
+ (use-local-map gnus-article-mode-map)
+ (make-local-variable 'page-delimiter)
+ (setq page-delimiter gnus-page-delimiter)
+ (buffer-disable-undo (current-buffer))
+ (setq buffer-read-only t) ;Disable modification
+ (run-hooks 'gnus-article-mode-hook))
+
+(defun gnus-article-setup-buffer ()
+ "Initialize article mode buffer."
+ ;; Returns the article buffer.
+ (if (get-buffer gnus-article-buffer)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (buffer-disable-undo (current-buffer))
+ (setq buffer-read-only t)
+ (gnus-add-current-to-buffer-list)
+ (or (eq major-mode 'gnus-article-mode)
+ (gnus-article-mode))
+ (current-buffer))
+ (save-excursion
+ (set-buffer (get-buffer-create gnus-article-buffer))
+ (gnus-add-current-to-buffer-list)
+ (gnus-article-mode)
+ (current-buffer))))
+
+;; Set article window start at LINE, where LINE is the number of lines
+;; from the head of the article.
+(defun gnus-article-set-window-start (&optional line)
+ (set-window-start
+ (get-buffer-window gnus-article-buffer)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (goto-char (point-min))
+ (if (not line)
+ (point-min)
+ (gnus-message 6 "Moved to bookmark")
+ (search-forward "\n\n" nil t)
+ (forward-line line)
+ (point)))))
+
+(defun gnus-request-article-this-buffer (article group)
+ "Get an article and insert it into this buffer."
+ (setq group (or group gnus-newsgroup-name))
+
+ ;; Open server if it has closed.
+ (gnus-check-server (gnus-find-method-for-group group))
+
+ ;; Using `gnus-request-article' directly will insert the article into
+ ;; `nntp-server-buffer' - so we'll save some time by not having to
+ ;; copy it from the server buffer into the article buffer.
+
+ ;; We only request an article by message-id when we do not have the
+ ;; headers for it, so we'll have to get those.
+ (and (stringp article)
+ (let ((gnus-override-method gnus-refer-article-method))
+ (gnus-read-header article)))
+
+ ;; If the article number is negative, that means that this article
+ ;; doesn't belong in this newsgroup (possibly), so we find its
+ ;; message-id and request it by id instead of number.
+ (if (not (numberp article))
+ ()
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (let ((header (gnus-get-header-by-num article)))
+ (if (< article 0)
+ (if (vectorp header)
+ ;; It's a real article.
+ (setq article (mail-header-id header))
+ ;; It is an extracted pseudo-article.
+ (setq article 'pseudo)
+ (gnus-request-pseudo-article header)))
+
+ (let ((method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (if (not (eq (car method) 'nneething))
+ ()
+ (let ((dir (concat (file-name-as-directory (nth 1 method))
+ (mail-header-subject header))))
+ (if (file-directory-p dir)
+ (progn
+ (setq article 'nneething)
+ (gnus-group-enter-directory dir)))))))))
+
+ ;; Check the cache.
+ (if (and gnus-use-cache
+ (numberp article)
+ (gnus-cache-request-article article group))
+ 'article
+ ;; Get the article and put into the article buffer.
+ (if (or (stringp article) (numberp article))
+ (progn
+ (erase-buffer)
+ ;; There may be some overlays that we have to kill...
+ (insert "i")
+ (let ((overlays (overlays-at (point-min))))
+ (while overlays
+ (delete-overlay (car overlays))
+ (setq overlays (cdr overlays))))
+ (erase-buffer)
+ (let ((gnus-override-method
+ (and (stringp article) gnus-refer-article-method)))
+ (and (gnus-request-article article group (current-buffer))
+ 'article)))
+ article)))
+
+(defun gnus-read-header (id)
+ "Read the headers of article ID and enter them into the Gnus system."
+ (let (header)
+ (if (not (setq header
+ (car (if (let ((gnus-nov-is-evil t))
+ (gnus-retrieve-headers
+ (list id) gnus-newsgroup-name))
+ (gnus-get-newsgroup-headers)))))
+ nil
+ (if (stringp id)
+ (mail-header-set-number header gnus-reffed-article-number))
+ (setq gnus-newsgroup-headers (cons header gnus-newsgroup-headers))
+ (gnus-sethash (int-to-string (mail-header-number header)) header
+ gnus-newsgroup-headers-hashtb-by-number)
+ (if (stringp id)
+ (setq gnus-reffed-article-number (1- gnus-reffed-article-number)))
+ (setq gnus-current-headers header)
+ header)))
+
+(defun gnus-article-prepare (article &optional all-headers header)
+ "Prepare ARTICLE in article mode buffer.
+ARTICLE should either be an article number or a Message-ID.
+If ARTICLE is an id, HEADER should be the article headers.
+If ALL-HEADERS is non-nil, no headers are hidden."
+ (save-excursion
+ ;; Make sure we start in a summary buffer.
+ (or (eq major-mode 'gnus-summary-mode)
+ (set-buffer gnus-summary-buffer))
+ (setq gnus-summary-buffer (current-buffer))
+ ;; Make sure the connection to the server is alive.
+ (or (gnus-server-opened (gnus-find-method-for-group gnus-newsgroup-name))
+ (progn
+ (gnus-check-server
+ (gnus-find-method-for-group gnus-newsgroup-name))
+ (gnus-request-group gnus-newsgroup-name t)))
+ (let* ((article (if header (mail-header-number header) article))
+ (summary-buffer (current-buffer))
+ (internal-hook gnus-article-internal-prepare-hook)
+ (group gnus-newsgroup-name)
+ result)
+ (save-excursion
+ (gnus-article-setup-buffer)
+ (set-buffer gnus-article-buffer)
+ (if (not (setq result (let ((buffer-read-only nil))
+ (gnus-request-article-this-buffer
+ article group))))
+ ;; There is no such article.
+ (save-excursion
+ (if (not (numberp article))
+ ()
+ (setq gnus-article-current
+ (cons gnus-newsgroup-name article))
+ (set-buffer gnus-summary-buffer)
+ (setq gnus-current-article article)
+ (gnus-summary-mark-article article gnus-canceled-mark))
+ (gnus-message 1 "No such article (may be canceled)")
+ (ding)
+ nil)
+ (if (or (eq result 'pseudo) (eq result 'nneething))
+ (progn
+ (save-excursion
+ (set-buffer summary-buffer)
+ (setq gnus-last-article gnus-current-article
+ gnus-newsgroup-history (cons gnus-current-article
+ gnus-newsgroup-history)
+ gnus-current-article 0
+ gnus-current-headers nil
+ gnus-article-current nil)
+ (if (eq result 'nneething)
+ (gnus-configure-windows 'summary)
+ (gnus-configure-windows 'article))
+ (gnus-set-global-variables))
+ (gnus-set-mode-line 'article))
+ ;; The result from the `request' was an actual article -
+ ;; or at least some text that is now displayed in the
+ ;; article buffer.
+ (if (and (numberp article)
+ (not (eq article gnus-current-article)))
+ ;; Seems like a new article has been selected.
+ ;; `gnus-current-article' must be an article number.
+ (save-excursion
+ (set-buffer summary-buffer)
+ (setq gnus-last-article gnus-current-article
+ gnus-newsgroup-history (cons gnus-current-article
+ gnus-newsgroup-history)
+ gnus-current-article article
+ gnus-current-headers
+ (gnus-get-header-by-num gnus-current-article)
+ gnus-article-current
+ (cons gnus-newsgroup-name gnus-current-article))
+ (gnus-summary-show-thread)
+ (run-hooks 'gnus-mark-article-hook)
+ (gnus-set-mode-line 'summary)
+ (and gnus-visual
+ (run-hooks 'gnus-visual-mark-article-hook))
+ ;; Set the global newsgroup variables here.
+ ;; Suggested by Jim Sisolak
+ ;; <sisolak@trans4.neep.wisc.edu>.
+ (gnus-set-global-variables)
+ (setq gnus-have-all-headers
+ (or all-headers gnus-show-all-headers))
+ (and gnus-use-cache
+ (vectorp (gnus-get-header-by-number article))
+ (gnus-cache-possibly-enter-article
+ group article
+ (gnus-get-header-by-number article)
+ (memq article gnus-newsgroup-marked)
+ (memq article gnus-newsgroup-dormant)
+ (memq article gnus-newsgroup-unreads)))))
+ ;; Hooks for getting information from the article.
+ ;; This hook must be called before being narrowed.
+ (let (buffer-read-only)
+ (run-hooks 'internal-hook)
+ (run-hooks 'gnus-article-prepare-hook)
+ ;; Decode MIME message.
+ (if (and gnus-show-mime
+ (or (not gnus-strict-mime)
+ (gnus-fetch-field "Mime-Version")))
+ (funcall gnus-show-mime-method))
+ ;; Perform the article display hooks.
+ (run-hooks 'gnus-article-display-hook))
+ ;; Do page break.
+ (goto-char (point-min))
+ (and gnus-break-pages (gnus-narrow-to-page))
+ (gnus-set-mode-line 'article)
+ (gnus-configure-windows 'article)
+ (goto-char (point-min))
+ t))))))
+
+(defun gnus-article-show-all-headers ()
+ "Show all article headers in article mode buffer."
+ (save-excursion
+ (gnus-article-setup-buffer)
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (remove-text-properties (point-min) (point-max)
+ gnus-hidden-properties))))
+
+(defun gnus-article-hide-headers-if-wanted ()
+ "Hide unwanted headers if `gnus-have-all-headers' is nil.
+Provided for backwards compatability."
+ (or (save-excursion (set-buffer gnus-summary-buffer) gnus-have-all-headers)
+ (gnus-article-hide-headers)))
+
+(defun gnus-article-hide-headers (&optional delete)
+ "Hide unwanted headers and possibly sort them as well."
+ (interactive "P")
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (let ((sorted gnus-sorted-header-list)
+ (buffer-read-only nil)
+ want-list beg want-l)
+ ;; First we narrow to just the headers.
+ (widen)
+ (goto-char (point-min))
+ ;; Hide any "From " lines at the beginning of (mail) articles.
+ (while (looking-at "From ")
+ (forward-line 1))
+ (or (bobp)
+ (add-text-properties (point-min) (point) gnus-hidden-properties))
+ ;; Then treat the rest of the header lines.
+ (narrow-to-region
+ (point)
+ (progn (search-forward "\n\n" nil t) (forward-line -1) (point)))
+ ;; Then we use the two regular expressions
+ ;; `gnus-ignored-headers' and `gnus-visible-headers' to
+ ;; select which header lines is to remain visible in the
+ ;; article buffer.
+ (goto-char (point-min))
+ (while (re-search-forward "^[^ \t]*:" nil t)
+ (beginning-of-line)
+ ;; We add the headers we want to keep to a list and delete
+ ;; them from the buffer.
+ (if (or (and (stringp gnus-visible-headers)
+ (looking-at gnus-visible-headers))
+ (and (not (stringp gnus-visible-headers))
+ (stringp gnus-ignored-headers)
+ (not (looking-at gnus-ignored-headers))))
+ (progn
+ (setq beg (point))
+ (forward-line 1)
+ ;; Be sure to get multi-line headers...
+ (re-search-forward "^[^ \t]*:" nil t)
+ (beginning-of-line)
+ (setq want-list
+ (cons (buffer-substring beg (point)) want-list))
+ (delete-region beg (point))
+ (goto-char beg))
+ (forward-line 1)))
+ ;; Next we perform the sorting by looking at
+ ;; `gnus-sorted-header-list'.
+ (goto-char (point-min))
+ (while (and sorted want-list)
+ (setq want-l want-list)
+ (while (and want-l
+ (not (string-match (car sorted) (car want-l))))
+ (setq want-l (cdr want-l)))
+ (if want-l
+ (progn
+ (insert (car want-l))
+ (setq want-list (delq (car want-l) want-list))))
+ (setq sorted (cdr sorted)))
+ ;; Any headers that were not matched by the sorted list we
+ ;; just tack on the end of the visible header list.
+ (while want-list
+ (insert (car want-list))
+ (setq want-list (cdr want-list)))
+ ;; And finally we make the unwanted headers invisible.
+ (if delete
+ (delete-region (point) (point-max))
+ ;; Suggested by Sudish Joseph <joseph@cis.ohio-state.edu>.
+ (add-text-properties (point) (point-max) gnus-hidden-properties))))))
+
+;; Written by Per Abrahamsen <amanda@iesd.auc.dk>.
+(defun gnus-article-treat-overstrike ()
+ "Translate overstrikes into bold text."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (while (search-forward "\b" nil t)
+ (let ((next (following-char))
+ (previous (char-after (- (point) 2))))
+ (cond ((eq next previous)
+ (put-text-property (- (point) 2) (point)
+ 'invisible t)
+ (put-text-property (point) (1+ (point))
+ 'face 'bold))
+ ((eq next ?_)
+ (put-text-property (1- (point)) (1+ (point))
+ 'invisible t)
+ (put-text-property (1- (point)) (point)
+ 'face 'underline))
+ ((eq previous ?_)
+ (put-text-property (- (point) 2) (point)
+ 'invisible t)
+ (put-text-property (point) (1+ (point))
+ 'face 'underline))))))))
+
+(defun gnus-article-word-wrap ()
+ "Format too long lines."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (end-of-line 1)
+ (let ((paragraph-start "^[>|#:<;* ]*[ \t]*$")
+ (adaptive-fill-regexp "[ \t]*\\([|#:<;>*]+ *\\)?")
+ (adaptive-fill-mode t))
+ (while (not (eobp))
+ (and (>= (current-column) (min fill-column (window-width)))
+ (/= (preceding-char) ?:)
+ (fill-paragraph nil))
+ (end-of-line 2))))))
+
+(defun gnus-article-remove-cr ()
+ "Remove carriage returns from an article."
+ (interactive)
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (while (search-forward "\r" nil t)
+ (replace-match "" t t)))))
+
+(defun gnus-article-display-x-face (&optional force)
+ "Look for an X-Face header and display it if present."
+ (interactive (list 'force))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((inhibit-point-motion-hooks t)
+ (case-fold-search nil)
+ from)
+ (save-restriction
+ (goto-char (point-min))
+ (search-forward "\n\n")
+ (narrow-to-region (point-min) (point))
+ (goto-char (point-min))
+ (setq from (mail-fetch-field "from"))
+ (if (not (and gnus-article-x-face-command
+ (or force
+ (not gnus-article-x-face-too-ugly)
+ (and gnus-article-x-face-too-ugly from
+ (not (string-match gnus-article-x-face-too-ugly
+ from))))
+ (progn
+ (goto-char (point-min))
+ (re-search-forward "^X-Face: " nil t))))
+ nil
+ (let ((beg (point))
+ (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
+ (if (symbolp gnus-article-x-face-command)
+ (and (or (fboundp gnus-article-x-face-command)
+ (error "%s is not a function"
+ gnus-article-x-face-command))
+ (funcall gnus-article-x-face-command beg end))
+ (call-process-region beg end "sh" nil 0 nil
+ "-c" gnus-article-x-face-command))))))))
+
+(defun gnus-article-de-quoted-unreadable (&optional force)
+ "Do a naive translation of a quoted-printable-encoded article.
+This is in no way, shape or form meant as a replacement for real MIME
+processing, but is simply a stop-gap measure until MIME support is
+written.
+If FORCE, decode the article whether it is marked as quoted-printable
+or not."
+ (interactive (list 'force))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((case-fold-search t)
+ (buffer-read-only nil)
+ (type (gnus-fetch-field "content-transfer-encoding")))
+ (if (or force (and type (string-match "quoted-printable" type)))
+ (progn
+ (goto-char (point-min))
+ (search-forward "\n\n" nil 'move)
+ (gnus-mime-decode-quoted-printable (point) (point-max)))))))
+
+(defun gnus-mime-decode-quoted-printable (from to)
+ ;; Decode quoted-printable from region between FROM and TO.
+ (save-excursion
+ (goto-char from)
+ (while (search-forward "=" to t)
+ (cond ((eq (following-char) ?\n)
+ (delete-char -1)
+ (delete-char 1))
+ ((looking-at "[0-9A-F][0-9A-F]")
+ (delete-char -1)
+ (insert (hexl-hex-string-to-integer
+ (buffer-substring (point) (+ 2 (point)))))
+ (delete-char 2))
+ ((looking-at "=")
+ (delete-char 1))
+ ((gnus-message 3 "Malformed MIME quoted-printable message"))))))
+
+(defvar gnus-article-time-units
+ (list (cons 'year (* 365.25 24 60 60))
+ (cons 'week (* 7 24 60 60))
+ (cons 'day (* 24 60 60))
+ (cons 'hour (* 60 60))
+ (cons 'minute 60)
+ (cons 'second 1)))
+
+(defun gnus-article-date-ut (&optional type)
+ "Convert DATE date to universal time in the current article.
+If TYPE is `local', convert to local time; if it is `lapsed', output
+how much time has lapsed since DATE."
+ (interactive (list 'ut))
+ (let ((date (mail-header-date (or gnus-current-headers
+ (gnus-get-header-by-number
+ (gnus-summary-article-number))"")))
+ (date-regexp "^Date: \\|^X-Sent: "))
+ (if (or (not date)
+ (string= date ""))
+ ()
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((buffer-read-only nil))
+ (goto-char (point-min))
+ (if (and (re-search-forward date-regexp nil t)
+ (progn
+ (beginning-of-line)
+ (looking-at date-regexp)))
+ (delete-region (gnus-point-at-bol)
+ (progn (end-of-line) (1+ (point))))
+ (goto-char (point-min))
+ (goto-char (- (search-forward "\n\n") 2)))
+ (insert
+ (cond
+ ((eq type 'local)
+ (concat "Date: " (condition-case ()
+ (timezone-make-date-arpa-standard date)
+ (error date))
+ "\n"))
+ ((eq type 'ut)
+ (concat "Date: "
+ (condition-case ()
+ (timezone-make-date-arpa-standard date nil "UT")
+ (error date))
+ "\n"))
+ ((eq type 'lapsed)
+ ;; If the date is seriously mangled, the timezone
+ ;; functions are liable to bug out, so we condition-case
+ ;; the entire thing.
+ (let* ((real-sec (condition-case ()
+ (- (gnus-seconds-since-epoch
+ (timezone-make-date-arpa-standard
+ (current-time-string)
+ (current-time-zone) "UT"))
+ (gnus-seconds-since-epoch
+ (timezone-make-date-arpa-standard
+ date nil "UT")))
+ (error 0)))
+ (sec (abs real-sec))
+ num prev)
+ (if (zerop sec)
+ "X-Sent: Now\n"
+ (concat
+ "X-Sent: "
+ (mapconcat
+ (lambda (unit)
+ (if (zerop (setq num (ffloor (/ sec (cdr unit)))))
+ ""
+ (setq sec (- sec (* num (cdr unit))))
+ (prog1
+ (concat (if prev ", " "") (int-to-string
+ (floor num))
+ " " (symbol-name (car unit))
+ (if (> num 1) "s" ""))
+ (setq prev t))))
+ gnus-article-time-units "")
+ (if (> real-sec 0)
+ " ago\n"
+ " in the future\n")))))
+ (t
+ (error "Unknown conversion type: %s" type)))))))))
+
+(defun gnus-article-date-local ()
+ "Convert the current article date to the local timezone."
+ (interactive)
+ (gnus-article-date-ut 'local))
+
+(defun gnus-article-date-lapsed ()
+ "Convert the current article date to time lapsed since it was sent."
+ (interactive)
+ (gnus-article-date-ut 'lapsed))
+
+(defun gnus-article-maybe-highlight ()
+ "Do some article highlighting if `gnus-visual' is non-nil."
+ (if gnus-visual (gnus-article-highlight-some)))
+
+;; Article savers.
+
+(defun gnus-output-to-rmail (file-name)
+ "Append the current article to an Rmail file named FILE-NAME."
+ (require 'rmail)
+ ;; Most of these codes are borrowed from rmailout.el.
+ (setq file-name (expand-file-name file-name))
+ (setq rmail-default-rmail-file file-name)
+ (let ((artbuf (current-buffer))
+ (tmpbuf (get-buffer-create " *Gnus-output*")))
+ (save-excursion
+ (or (get-file-buffer file-name)
+ (file-exists-p file-name)
+ (if (gnus-yes-or-no-p
+ (concat "\"" file-name "\" does not exist, create it? "))
+ (let ((file-buffer (create-file-buffer file-name)))
+ (save-excursion
+ (set-buffer file-buffer)
+ (rmail-insert-rmail-file-header)
+ (let ((require-final-newline nil))
+ (write-region (point-min) (point-max) file-name t 1)))
+ (kill-buffer file-buffer))
+ (error "Output file does not exist")))
+ (set-buffer tmpbuf)
+ (buffer-disable-undo (current-buffer))
+ (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 file-name)))
+ (if (not outbuf)
+ (append-to-file (point-min) (point-max) file-name)
+ ;; 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.
+ (if msg
+ (progn (widen)
+ (narrow-to-region (point-max) (point-max))))
+ (insert-buffer-substring tmpbuf)
+ (if msg
+ (progn
+ (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-file (file-name)
+ "Append the current article to a file named FILE-NAME."
+ (setq file-name (expand-file-name file-name))
+ (let ((artbuf (current-buffer))
+ (tmpbuf (get-buffer-create " *Gnus-output*")))
+ (save-excursion
+ (set-buffer tmpbuf)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-buffer-substring artbuf)
+ ;; Append newline at end of the buffer as separator, and then
+ ;; save it to file.
+ (goto-char (point-max))
+ (insert "\n")
+ (append-to-file (point-min) (point-max) file-name))
+ (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.
+ ;; Suggested by Rob Austein <sra@lcs.mit.edu>
+ (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 "\^_")))
+
+(defun gnus-narrow-to-page (&optional arg)
+ "Make text outside current page invisible except for page delimiter.
+A numeric arg specifies to move forward or backward by that many pages,
+thus showing a page other than the one point was originally in."
+ (interactive "P")
+ (setq arg (if arg (prefix-numeric-value arg) 0))
+ (save-excursion
+ (forward-page -1) ;Beginning of current page.
+ (widen)
+ (if (> arg 0)
+ (forward-page arg)
+ (if (< arg 0)
+ (forward-page (1- arg))))
+ ;; Find the end of the page.
+ (forward-page)
+ ;; If we stopped due to end of buffer, stay there.
+ ;; If we stopped after a page delimiter, put end of restriction
+ ;; at the beginning of that line.
+ ;; These are commented out.
+ ;; (if (save-excursion (beginning-of-line)
+ ;; (looking-at page-delimiter))
+ ;; (beginning-of-line))
+ (narrow-to-region (point)
+ (progn
+ ;; Find the top of the page.
+ (forward-page -1)
+ ;; If we found beginning of buffer, stay there.
+ ;; If extra text follows page delimiter on same line,
+ ;; include it.
+ ;; Otherwise, show text starting with following line.
+ (if (and (eolp) (not (bobp)))
+ (forward-line 1))
+ (point)))))
+
+(defun gnus-gmt-to-local ()
+ "Rewrite Date header described in GMT to local in current buffer.
+Intended to be used with gnus-article-prepare-hook."
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (narrow-to-region (point-min)
+ (progn (search-forward "\n\n" nil 'move) (point)))
+ (goto-char (point-min))
+ (if (re-search-forward "^Date:[ \t]\\(.*\\)$" nil t)
+ (let ((buffer-read-only nil)
+ (date (buffer-substring-no-properties
+ (match-beginning 1) (match-end 1))))
+ (delete-region (match-beginning 1) (match-end 1))
+ (insert
+ (timezone-make-date-arpa-standard
+ date nil (current-time-zone))))))))
+
+
+;; Article mode commands
+
+(defun gnus-article-next-page (&optional lines)
+ "Show next page of current article.
+If end of article, return non-nil. Otherwise return nil.
+Argument LINES specifies lines to be scrolled up."
+ (interactive "P")
+ (move-to-window-line -1)
+ ;; Fixed by enami@ptgd.sony.co.jp (enami tsugutomo)
+ (if (save-excursion
+ (end-of-line)
+ (and (pos-visible-in-window-p) ;Not continuation line.
+ (eobp)))
+ ;; Nothing in this page.
+ (if (or (not gnus-break-pages)
+ (save-excursion
+ (save-restriction
+ (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer?
+ t ;Nothing more.
+ (gnus-narrow-to-page 1) ;Go to next page.
+ nil)
+ ;; More in this page.
+ (condition-case ()
+ (scroll-up lines)
+ (end-of-buffer
+ ;; Long lines may cause an end-of-buffer error.
+ (goto-char (point-max))))
+ nil))
+
+(defun gnus-article-prev-page (&optional lines)
+ "Show previous page of current article.
+Argument LINES specifies lines to be scrolled down."
+ (interactive "P")
+ (move-to-window-line 0)
+ (if (and gnus-break-pages
+ (bobp)
+ (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer?
+ (progn
+ (gnus-narrow-to-page -1) ;Go to previous page.
+ (goto-char (point-max))
+ (recenter -1))
+ (scroll-down lines)))
+
+(defun gnus-article-refer-article ()
+ "Read article specified by message-id around point."
+ (interactive)
+ (search-forward ">" nil t) ;Move point to end of "<....>".
+ (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
+ (let ((message-id
+ (buffer-substring (match-beginning 1) (match-end 1))))
+ (set-buffer gnus-summary-buffer)
+ (gnus-summary-refer-article message-id))
+ (error "No references around point")))
+
+(defun gnus-article-show-summary ()
+ "Reconfigure windows to show summary buffer."
+ (interactive)
+ (gnus-configure-windows 'article)
+ (gnus-summary-goto-subject gnus-current-article))
+
+(defun gnus-article-describe-briefly ()
+ "Describe article mode commands briefly."
+ (interactive)
+ (gnus-message 6
+ (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-next-page]:Next page \\[gnus-article-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help")))
+
+(defun gnus-article-summary-command ()
+ "Execute the last keystroke in the summary buffer."
+ (interactive)
+ (let ((obuf (current-buffer))
+ (owin (current-window-configuration))
+ func)
+ (switch-to-buffer gnus-summary-buffer 'norecord)
+ (setq func (lookup-key (current-local-map) (this-command-keys)))
+ (call-interactively func)
+ (set-buffer obuf)
+ (set-window-configuration owin)
+ (set-window-point (get-buffer-window (current-buffer)) (point))))
+
+(defun gnus-article-summary-command-nosave ()
+ "Execute the last keystroke in the summary buffer."
+ (interactive)
+ (let (func)
+ (pop-to-buffer gnus-summary-buffer 'norecord)
+ (setq func (lookup-key (current-local-map) (this-command-keys)))
+ (call-interactively func)))
+
+
+;; Basic ideas by emv@math.lsa.umich.edu (Edward Vielmetti)
+
+;;;###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* ((yes-and-no
+ (gnus-newsrc-parse-options
+ (apply (function concat)
+ (mapcar (lambda (g) (concat g " "))
+ command-line-args-left))))
+ (gnus-expert-user t)
+ (nnmail-spool-file nil)
+ (gnus-use-dribble-file nil)
+ (yes (car yes-and-no))
+ (no (cdr yes-and-no))
+ group newsrc entry
+ ;; Disable verbose message.
+ gnus-novice-user gnus-large-newsgroup)
+ ;; Eat all arguments.
+ (setq command-line-args-left nil)
+ ;; Start Gnus.
+ (gnus)
+ ;; Apply kills to specified newsgroups in command line arguments.
+ (setq newsrc (cdr gnus-newsrc-alist))
+ (while newsrc
+ (setq group (car (car newsrc)))
+ (setq entry (gnus-gethash group gnus-newsrc-hashtb))
+ (if (and (<= (nth 1 (car newsrc)) gnus-level-subscribed)
+ (and (car entry)
+ (or (eq (car entry) t)
+ (not (zerop (car entry)))))
+ (if yes (string-match yes group) t)
+ (or (null no) (not (string-match no group))))
+ (progn
+ (gnus-summary-read-group group nil t)
+ (and (eq (current-buffer) (get-buffer gnus-summary-buffer))
+ (gnus-summary-exit))))
+ (setq newsrc (cdr newsrc)))
+ ;; Exit Emacs.
+ (switch-to-buffer gnus-group-buffer)
+ (gnus-group-save-newsrc)))
+
+(defun gnus-apply-kill-file ()
+ "Apply a kill file to the current newsgroup.
+Returns the number of articles marked as read."
+ (if (or (file-exists-p (gnus-newsgroup-kill-file nil))
+ (file-exists-p (gnus-newsgroup-kill-file gnus-newsgroup-name)))
+ (gnus-apply-kill-file-internal)
+ 0))
+
+(defun gnus-kill-save-kill-buffer ()
+ (save-excursion
+ (let ((file (gnus-newsgroup-kill-file gnus-newsgroup-name)))
+ (if (get-file-buffer file)
+ (progn
+ (set-buffer (get-file-buffer file))
+ (and (buffer-modified-p) (save-buffer))
+ (kill-buffer (current-buffer)))))))
+
+(defvar gnus-kill-file-name "KILL"
+ "Suffix of the kill files.")
+
+(defun gnus-newsgroup-kill-file (newsgroup)
+ "Return the name of a kill file name for NEWSGROUP.
+If NEWSGROUP is nil, return the global kill file name 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
+ (or gnus-kill-files-directory "~/News")))
+ ((gnus-use-long-file-name 'not-kill)
+ ;; Append ".KILL" to newsgroup name.
+ (expand-file-name (concat (gnus-newsgroup-saveable-name newsgroup)
+ "." gnus-kill-file-name)
+ (or gnus-kill-files-directory "~/News")))
+ (t
+ ;; Place "KILL" under the hierarchical directory.
+ (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
+ "/" gnus-kill-file-name)
+ (or gnus-kill-files-directory "~/News")))))
+
+
+;;;
+;;; Dribble file
+;;;
+
+(defvar gnus-dribble-ignore nil)
+(defvar gnus-dribble-eval-file nil)
+
+(defun gnus-dribble-file-name ()
+ (concat gnus-current-startup-file "-dribble"))
+
+(defun gnus-dribble-enter (string)
+ (if (and (not gnus-dribble-ignore)
+ gnus-dribble-buffer
+ (buffer-name gnus-dribble-buffer))
+ (let ((obuf (current-buffer)))
+ (set-buffer gnus-dribble-buffer)
+ (insert string "\n")
+ (set-window-point (get-buffer-window (current-buffer)) (point-max))
+ (set-buffer obuf))))
+
+(defun gnus-dribble-read-file ()
+ (let ((dribble-file (gnus-dribble-file-name)))
+ (save-excursion
+ (set-buffer (setq gnus-dribble-buffer
+ (get-buffer-create
+ (file-name-nondirectory dribble-file))))
+ (gnus-add-current-to-buffer-list)
+ (erase-buffer)
+ (set-visited-file-name dribble-file)
+ (buffer-disable-undo (current-buffer))
+ (bury-buffer (current-buffer))
+ (set-buffer-modified-p nil)
+ (let ((auto (make-auto-save-file-name))
+ (gnus-dribble-ignore t))
+ (if (or (file-exists-p auto) (file-exists-p dribble-file))
+ (progn
+ (if (file-newer-than-file-p auto dribble-file)
+ (setq dribble-file auto))
+ (insert-file-contents dribble-file)
+ (if (not (zerop (buffer-size)))
+ (set-buffer-modified-p t))
+ (if (gnus-y-or-n-p
+ "Auto-save file exists. Do you want to read it? ")
+ (setq gnus-dribble-eval-file t))))))))
+
+(defun gnus-dribble-eval-file ()
+ (if (not gnus-dribble-eval-file)
+ ()
+ (setq gnus-dribble-eval-file nil)
+ (save-excursion
+ (let ((gnus-dribble-ignore t))
+ (set-buffer gnus-dribble-buffer)
+ (eval-buffer (current-buffer))))))
+
+(defun gnus-dribble-delete-file ()
+ (if (file-exists-p (gnus-dribble-file-name))
+ (delete-file (gnus-dribble-file-name)))
+ (if gnus-dribble-buffer
+ (save-excursion
+ (set-buffer gnus-dribble-buffer)
+ (let ((auto (make-auto-save-file-name)))
+ (if (file-exists-p auto)
+ (delete-file auto))
+ (erase-buffer)
+ (set-buffer-modified-p nil)))))
+
+(defun gnus-dribble-save ()
+ (if (and gnus-dribble-buffer
+ (buffer-name gnus-dribble-buffer))
+ (save-excursion
+ (set-buffer gnus-dribble-buffer)
+ (save-buffer))))
+
+(defun gnus-dribble-clear ()
+ (save-excursion
+ (if (gnus-buffer-exists-p gnus-dribble-buffer)
+ (progn
+ (set-buffer gnus-dribble-buffer)
+ (erase-buffer)
+ (set-buffer-modified-p nil)
+ (setq buffer-saved-size (buffer-size))))))
+
+;;;
+;;; 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.
+ (if (null gnus-nntp-service) (setq gnus-nntp-server nil))
+ (if confirm
+ (progn
+ ;; 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))))
+
+ (if (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 open error: '%s'. Continue? "
+ (nth 1 gnus-select-method)
+ (gnus-status-message gnus-select-method)))
+ (progn
+ (gnus-message 1 "Couldn't open server on %s"
+ (nth 1 gnus-select-method))
+ (ding)
+ nil)))))
+
+(defun gnus-check-server (&optional method)
+ "If the news server is down, start it up again."
+ (let ((method (if method method gnus-select-method)))
+ (and (stringp method)
+ (setq method (gnus-server-to-method method)))
+ (if (gnus-server-opened method)
+ ;; Stream is already opened.
+ t
+ ;; Open server.
+ (gnus-message 5 "Opening server %s on %s..." (car method) (nth 1 method))
+ (run-hooks 'gnus-open-server-hook)
+ (prog1
+ (gnus-open-server method)
+ (message "")))))
+
+(defun gnus-nntp-message (&optional message)
+ "Check the status of the NNTP server.
+If the status of the server is clear and MESSAGE is non-nil, MESSAGE
+is returned insted of the status string."
+ (let ((status (gnus-status-message (gnus-find-method-for-group
+ gnus-newsgroup-name)))
+ (message (or message "")))
+ (if (and (stringp status) (> (length status) 0))
+ status message)))
+
+(defun gnus-get-function (method function)
+ (and (stringp method)
+ (setq method (gnus-server-to-method method)))
+ (let ((func (intern (format "%s-%s" (car method) function))))
+ (if (not (fboundp func))
+ (progn
+ (require (car method))
+ (if (not (fboundp func))
+ (error "No such function: %s" func))))
+ func))
+
+;;; Interface functions to the backends.
+
+(defun gnus-open-server (method)
+ (funcall (gnus-get-function method 'open-server)
+ (nth 1 method) (nthcdr 2 method)))
+
+(defun gnus-close-server (method)
+ (funcall (gnus-get-function method 'close-server) (nth 1 method)))
+
+(defun gnus-request-list (method)
+ (funcall (gnus-get-function method 'request-list) (nth 1 method)))
+
+(defun gnus-request-list-newsgroups (method)
+ (funcall (gnus-get-function method 'request-list-newsgroups) (nth 1 method)))
+
+(defun gnus-request-newgroups (date method)
+ (funcall (gnus-get-function method 'request-newgroups)
+ date (nth 1 method)))
+
+(defun gnus-server-opened (method)
+ (funcall (gnus-get-function method 'server-opened) (nth 1 method)))
+
+(defun gnus-status-message (method)
+ (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-group (group &optional dont-check)
+ (let ((method (gnus-find-method-for-group group)))
+ (funcall (gnus-get-function method 'request-group)
+ (gnus-group-real-name group) (nth 1 method) dont-check)))
+
+(defun gnus-request-asynchronous (group &optional articles)
+ (let ((method (gnus-find-method-for-group group)))
+ (funcall (gnus-get-function method 'request-asynchronous)
+ (gnus-group-real-name group) (nth 1 method) articles)))
+
+(defun gnus-list-active-group (group)
+ (let ((method (gnus-find-method-for-group group))
+ (func 'list-active-group))
+ (and (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)
+ (let ((method (gnus-find-method-for-group group))
+ (func 'request-group-description))
+ (and (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)
+ (let ((method (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)
+ (let ((method (gnus-find-method-for-group group)))
+ (if (and gnus-use-cache (numberp (car articles)))
+ (gnus-cache-retrieve-headers articles group)
+ (funcall (gnus-get-function method 'retrieve-headers)
+ articles (gnus-group-real-name group) (nth 1 method)))))
+
+(defun gnus-retrieve-groups (groups method)
+ (funcall (gnus-get-function method 'retrieve-groups) groups (nth 1 method)))
+
+(defun gnus-request-article (article group &optional buffer)
+ (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)
+ (let ((method (gnus-find-method-for-group group)))
+ (funcall (gnus-get-function method 'request-head)
+ article (gnus-group-real-name group) (nth 1 method))))
+
+(defun gnus-request-body (article 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))))
+
+;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
+(defun gnus-request-post-buffer (post group subject header artbuf
+ info follow-to respect-poster)
+ (let* ((info (or info (and group (nth 2 (gnus-gethash
+ group gnus-newsrc-hashtb)))))
+ (method
+ (if (and gnus-post-method
+ ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>.
+ (memq 'post (assoc
+ (format "%s" (car (gnus-find-method-for-group
+ gnus-newsgroup-name)))
+ gnus-valid-select-methods)))
+ gnus-post-method
+ (gnus-find-method-for-group gnus-newsgroup-name))))
+ (or (gnus-check-server method)
+ (error "Can't open server %s:%s" (car method) (nth 1 method)))
+ (let ((mail-self-blind nil)
+ (mail-archive-file-name nil))
+ (funcall (gnus-get-function method 'request-post-buffer)
+ post group subject header artbuf info follow-to
+ respect-poster))))
+
+(defun gnus-request-post (method &optional force)
+ (and (stringp method)
+ (setq method (gnus-server-to-method method)))
+ (and (not force) gnus-post-method
+ (memq 'post (assoc (format "%s" (car method))
+ gnus-valid-select-methods))
+ (setq method gnus-post-method))
+ (funcall (gnus-get-function method 'request-post)
+ (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 &optional last)
+ (let ((func (if (symbolp group) group
+ (car (gnus-find-method-for-group group)))))
+ (funcall (intern (format "%s-request-accept-article" func))
+ (if (stringp group) (gnus-group-real-name group) group)
+ 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-create-group (group)
+ (let ((method (gnus-find-method-for-group group)))
+ (funcall (gnus-get-function method 'request-create-group)
+ (gnus-group-real-name group) (nth 1 method))))
+
+(defun gnus-member-of-valid (symbol group)
+ (memq symbol (assoc
+ (format "%s" (car (gnus-find-method-for-group group)))
+ gnus-valid-select-methods)))
+
+(defun gnus-secondary-method-p (method)
+ (let ((methods gnus-secondary-select-methods)
+ (gmethod (gnus-server-get-method nil method)))
+ (while (and methods
+ (not (equal (gnus-server-get-method nil (car methods))
+ gmethod)))
+ (setq methods (cdr methods)))
+ methods))
+
+(defun gnus-find-method-for-group (group &optional info)
+ (or gnus-override-method
+ (and (not group)
+ gnus-select-method)
+ (let ((info (or info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))))
+ method)
+ (if (or (not info)
+ (not (setq method (nth 4 info))))
+ (setq method gnus-select-method)
+ (setq method
+ (cond ((stringp method)
+ (gnus-server-to-method method))
+ ((stringp (car method))
+ (gnus-server-extend-method group method))
+ (t
+ method))))
+ (gnus-server-add-address method))))
+
+(defun gnus-check-backend-function (func group)
+ (let ((method (if (stringp group) (car (gnus-find-method-for-group group))
+ group)))
+ (fboundp (intern (format "%s-%s" method func)))))
+
+(defun gnus-methods-using (method)
+ (let ((valids gnus-valid-select-methods)
+ outs)
+ (while valids
+ (if (memq method (car valids))
+ (setq outs (cons (car valids) outs)))
+ (setq valids (cdr valids)))
+ outs))
+
+;;;
+;;; Active & Newsrc File Handling
+;;;
+
+;; Newsrc related functions.
+;; Gnus internal format of gnus-newsrc-alist:
+;; (("alt.general" 3 (1 . 1))
+;; ("alt.misc" 3 ((1 . 10) (12 . 15)))
+;; ("alt.test" 7 (1 . 99) (45 57 93)) ...)
+;; The first item is the group name; the second is the subscription
+;; level; the third is either a range of a list of ranges of read
+;; articles, the optional fourth element is a list of marked articles,
+;; the optional fifth element is the select method.
+;;
+;; Gnus internal format of gnus-newsrc-hashtb:
+;; (95 ("alt.general" 3 (1 . 1)) ("alt.misc" 3 ((1 . 10) (12 . 15))) ...)
+;; This is the entry for "alt.misc". The first element is the number
+;; of unread articles in "alt.misc". The cdr of this entry is the
+;; element *before* "alt.misc" in gnus-newsrc-alist, which makes is
+;; trivial to remove or add new elements into gnus-newsrc-alist
+;; without scanning the entire list. So, to get the actual information
+;; of "alt.misc", you'd say something like
+;; (nth 2 (gnus-gethash "alt.misc" gnus-newsrc-hashtb))
+;;
+;; Gnus internal format of gnus-active-hashtb:
+;; ((1 . 1))
+;; (5 . 10))
+;; (67 . 99)) ...)
+;; The only element in each entry in this hash table is a range of
+;; (possibly) available articles. (Articles in this range may have
+;; been expired or canceled.)
+;;
+;; Gnus internal format of gnus-killed-list and gnus-zombie-list:
+;; ("alt.misc" "alt.test" "alt.general" ...)
+
+(defun gnus-setup-news (&optional rawfile level)
+ "Setup news information.
+If RAWFILE is non-nil, the .newsrc file will also be read.
+If LEVEL is non-nil, the news will be set up at level LEVEL."
+ (let ((init (not (and gnus-newsrc-alist gnus-active-hashtb (not rawfile)))))
+ ;; Clear some variables to re-initialize news information.
+ (if init (setq gnus-newsrc-alist nil
+ gnus-active-hashtb nil))
+
+ ;; Read the newsrc file and create `gnus-newsrc-hashtb'.
+ (if init (gnus-read-newsrc-file rawfile))
+
+ ;; If we don't read the complete active file, we fill in the
+ ;; hashtb here.
+ (if (or (null gnus-read-active-file)
+ (eq gnus-read-active-file 'some))
+ (gnus-update-active-hashtb-from-killed))
+
+ ;; Read the active file and create `gnus-active-hashtb'.
+ ;; If `gnus-read-active-file' is nil, then we just create an empty
+ ;; hash table. The partial filling out of the hash table will be
+ ;; done in `gnus-get-unread-articles'.
+ (and gnus-read-active-file
+ (not level)
+ (gnus-read-active-file))
+
+ (or gnus-active-hashtb
+ (setq gnus-active-hashtb (make-vector 4095 0)))
+
+ ;; Possibly eval the dribble file.
+ (and init gnus-use-dribble-file (gnus-dribble-eval-file))
+
+ (gnus-update-format-specifications)
+
+ ;; Find new newsgroups and treat them.
+ (if (and init gnus-check-new-newsgroups gnus-read-active-file (not level)
+ (gnus-server-opened gnus-select-method))
+ (gnus-find-new-newsgroups))
+
+ ;; Find the number of unread articles in each non-dead group.
+ (let ((gnus-read-active-file (and (not level) gnus-read-active-file)))
+ (gnus-get-unread-articles (or level (1+ gnus-level-subscribed))))
+
+ (if (and init gnus-check-bogus-newsgroups
+ gnus-read-active-file (not level)
+ (gnus-server-opened gnus-select-method))
+ (gnus-check-bogus-newsgroups))))
+
+(defun gnus-find-new-newsgroups ()
+ "Search for new newsgroups and add them.
+Each new newsgroup will be treated with `gnus-subscribe-newsgroup-method.'
+The `-n' option line from .newsrc is respected."
+ (interactive)
+ (or (gnus-check-first-time-used)
+ (if (or (consp gnus-check-new-newsgroups)
+ (eq gnus-check-new-newsgroups 'ask-server))
+ (gnus-ask-server-for-new-groups)
+ (let ((groups 0)
+ group new-newsgroups)
+ (gnus-message 5 "Looking for new newsgroups...")
+ (or gnus-have-read-active-file (gnus-read-active-file))
+ (setq gnus-newsrc-last-checked-date (current-time-string))
+ (if (not gnus-killed-hashtb) (gnus-make-hashtable-from-killed))
+ ;; Go though every newsgroup in `gnus-active-hashtb' and compare
+ ;; with `gnus-newsrc-hashtb' and `gnus-killed-hashtb'.
+ (mapatoms
+ (lambda (sym)
+ (if (or (null (setq group (symbol-name sym)))
+ (null (symbol-value sym))
+ (gnus-gethash group gnus-killed-hashtb)
+ (gnus-gethash group gnus-newsrc-hashtb))
+ ()
+ (let ((do-sub (gnus-matches-options-n group)))
+ (cond
+ ((eq do-sub 'subscribe)
+ (setq groups (1+ groups))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (funcall gnus-subscribe-options-newsgroup-method group))
+ ((eq do-sub 'ignore)
+ nil)
+ (t
+ (setq groups (1+ groups))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (if gnus-subscribe-hierarchical-interactive
+ (setq new-newsgroups (cons group new-newsgroups))
+ (funcall gnus-subscribe-newsgroup-method group)))))))
+ gnus-active-hashtb)
+ (if new-newsgroups
+ (gnus-subscribe-hierarchical-interactive new-newsgroups))
+ ;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
+ (if (> groups 0)
+ (gnus-message 6 "%d new newsgroup%s arrived."
+ groups (if (> groups 1) "s have" " has"))
+ (gnus-message 6 "No new newsgroups."))))))
+
+(defun gnus-matches-options-n (group)
+ ;; Returns `subscribe' if the group is to be uncoditionally
+ ;; subscribed, `ignore' if it is to be ignored, and nil if there is
+ ;; no match for the group.
+
+ ;; First we check the two user variables.
+ (cond
+ ((and gnus-options-subscribe
+ (string-match gnus-options-subscribe group))
+ 'subscribe)
+ ((and gnus-options-not-subscribe
+ (string-match gnus-options-not-subscribe group))
+ 'ignore)
+ ;; Then we go through the list that was retrieved from the .newsrc
+ ;; file. This list has elements on the form
+ ;; `(REGEXP . {ignore,subscribe})'. The first match found (the list
+ ;; is in the reverse order of the options line) is returned.
+ (t
+ (let ((regs gnus-newsrc-options-n))
+ (while (and regs
+ (not (string-match (car (car regs)) group)))
+ (setq regs (cdr regs)))
+ (and regs (cdr (car regs)))))))
+
+(defun gnus-ask-server-for-new-groups ()
+ (let* ((date (or gnus-newsrc-last-checked-date (current-time-string)))
+ (methods (cons gnus-select-method
+ (append
+ (and (consp gnus-check-new-newsgroups)
+ gnus-check-new-newsgroups)
+ gnus-secondary-select-methods)))
+ (groups 0)
+ (new-date (current-time-string))
+ (hashtb (gnus-make-hashtable 100))
+ group new-newsgroups got-new method)
+ ;; Go through both primary and secondary select methods and
+ ;; request new newsgroups.
+ (while methods
+ (setq method (gnus-server-get-method nil (car methods)))
+ (and (gnus-check-server method)
+ (gnus-request-newgroups date method)
+ (save-excursion
+ (setq got-new t)
+ (set-buffer nntp-server-buffer)
+ ;; Enter all the new groups in a hashtable.
+ (gnus-active-to-gnus-format method hashtb 'ignore)))
+ (setq methods (cdr methods)))
+ (and got-new (setq gnus-newsrc-last-checked-date new-date))
+ ;; Now all new groups from all select methods are in `hashtb'.
+ (mapatoms
+ (lambda (group-sym)
+ (setq group (symbol-name group-sym))
+ (if (or (null group)
+ (null (symbol-value group-sym))
+ (gnus-gethash group gnus-newsrc-hashtb)
+ (member group gnus-zombie-list)
+ (member group gnus-killed-list))
+ ;; The group is already known.
+ ()
+ (and (symbol-value group-sym)
+ (gnus-sethash group (symbol-value group-sym) gnus-active-hashtb))
+ (let ((do-sub (gnus-matches-options-n group)))
+ (cond ((eq do-sub 'subscribe)
+ (setq groups (1+ groups))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (funcall
+ gnus-subscribe-options-newsgroup-method group))
+ ((eq do-sub 'ignore)
+ nil)
+ (t
+ (setq groups (1+ groups))
+ (gnus-sethash group group gnus-killed-hashtb)
+ (if gnus-subscribe-hierarchical-interactive
+ (setq new-newsgroups (cons group new-newsgroups))
+ (funcall gnus-subscribe-newsgroup-method group)))))))
+ hashtb)
+ (if new-newsgroups
+ (gnus-subscribe-hierarchical-interactive new-newsgroups))
+ ;; Suggested by Per Abrahamsen <amanda@iesd.auc.dk>.
+ (if (> groups 0)
+ (gnus-message 6 "%d new newsgroup%s arrived."
+ groups (if (> groups 1) "s have" " has")))
+ got-new))
+
+(defun gnus-check-first-time-used ()
+ (if (or (> (length gnus-newsrc-alist) 1)
+ (file-exists-p gnus-startup-file)
+ (file-exists-p (concat gnus-startup-file ".el"))
+ (file-exists-p (concat gnus-startup-file ".eld")))
+ nil
+ (gnus-message 6 "First time user; subscribing you to default groups")
+ (or gnus-have-read-active-file (gnus-read-active-file))
+ (setq gnus-newsrc-last-checked-date (current-time-string))
+ (let ((groups gnus-default-subscribed-newsgroups)
+ group)
+ (if (eq groups t)
+ nil
+ (setq groups (or groups gnus-backup-default-subscribed-newsgroups))
+ (mapatoms
+ (lambda (sym)
+ (if (null (setq group (symbol-name sym)))
+ ()
+ (let ((do-sub (gnus-matches-options-n group)))
+ (cond
+ ((eq do-sub 'subscribe)
+ (gnus-sethash group group gnus-killed-hashtb)
+ (funcall gnus-subscribe-options-newsgroup-method group))
+ ((eq do-sub 'ignore)
+ nil)
+ (t
+ (setq gnus-killed-list (cons group gnus-killed-list)))))))
+ gnus-active-hashtb)
+ (while groups
+ (if (gnus-gethash (car groups) gnus-active-hashtb)
+ (gnus-group-change-level
+ (car groups) gnus-level-default-subscribed gnus-level-killed))
+ (setq groups (cdr groups)))
+ (gnus-group-make-help-group)
+ (and gnus-novice-user
+ (gnus-message 7 "`A k' to list killed groups"))))))
+
+(defun gnus-subscribe-group (group previous &optional method)
+ (gnus-group-change-level
+ (if method
+ (list t group gnus-level-default-subscribed nil nil method)
+ group)
+ gnus-level-default-subscribed gnus-level-killed previous t))
+
+;; `gnus-group-change-level' is the fundamental function for changing
+;; subscription levels of newsgroups. This might mean just changing
+;; from level 1 to 2, which is pretty trivial, from 2 to 6 or back
+;; again, which subscribes/unsubscribes a group, which is equally
+;; trivial. Changing from 1-7 to 8-9 means that you kill a group, and
+;; from 8-9 to 1-7 means that you remove the group from the list of
+;; killed (or zombie) groups and add them to the (kinda) subscribed
+;; groups. And last but not least, moving from 8 to 9 and 9 to 8,
+;; which is trivial.
+;; ENTRY can either be a string (newsgroup name) or a list (if
+;; FROMKILLED is t, it's a list on the format (NUM INFO-LIST),
+;; otherwise it's a list in the format of the `gnus-newsrc-hashtb'
+;; entries.
+;; LEVEL is the new level of the group, OLDLEVEL is the old level and
+;; PREVIOUS is the group (in hashtb entry format) to insert this group
+;; after.
+(defun gnus-group-change-level (entry level &optional oldlevel
+ previous fromkilled)
+ (let (group info active num)
+ ;; Glean what info we can from the arguments
+ (if (consp entry)
+ (if fromkilled (setq group (nth 1 entry))
+ (setq group (car (nth 2 entry))))
+ (setq group entry))
+ (if (and (stringp entry)
+ oldlevel
+ (< oldlevel gnus-level-zombie))
+ (setq entry (gnus-gethash entry gnus-newsrc-hashtb)))
+ (if (and (not oldlevel)
+ (consp entry))
+ (setq oldlevel (car (cdr (nth 2 entry)))))
+ (if (stringp previous)
+ (setq previous (gnus-gethash previous gnus-newsrc-hashtb)))
+
+ (if (and (>= oldlevel gnus-level-zombie)
+ (gnus-gethash group gnus-newsrc-hashtb))
+ ;; We are trying to subscribe a group that is already
+ ;; subscribed.
+ () ; Do nothing.
+
+ (or (gnus-ephemeral-group-p group)
+ (gnus-dribble-enter
+ (format "(gnus-group-change-level %S %S %S %S %S)"
+ group level oldlevel (car (nth 2 previous)) fromkilled)))
+
+ ;; Then we remove the newgroup from any old structures, if needed.
+ ;; If the group was killed, we remove it from the killed or zombie
+ ;; list. If not, and it is in fact going to be killed, we remove
+ ;; it from the newsrc hash table and assoc.
+ (cond ((>= oldlevel gnus-level-zombie)
+ (if (= oldlevel gnus-level-zombie)
+ (setq gnus-zombie-list (delete group gnus-zombie-list))
+ (setq gnus-killed-list (delete group gnus-killed-list))))
+ (t
+ (if (and (>= level gnus-level-zombie)
+ entry)
+ (progn
+ (gnus-sethash (car (nth 2 entry)) nil gnus-newsrc-hashtb)
+ (if (nth 3 entry)
+ (setcdr (gnus-gethash (car (nth 3 entry))
+ gnus-newsrc-hashtb)
+ (cdr entry)))
+ (setcdr (cdr entry) (cdr (cdr (cdr entry))))))))
+
+ ;; Finally we enter (if needed) the list where it is supposed to
+ ;; go, and change the subscription level. If it is to be killed,
+ ;; we enter it into the killed or zombie list.
+ (cond ((>= level gnus-level-zombie)
+ ;; Remove from the hash table.
+ (gnus-sethash group nil gnus-newsrc-hashtb)
+ (or (gnus-group-foreign-p group)
+ ;; We do not enter foreign groups into the list of dead
+ ;; groups.
+ (if (= level gnus-level-zombie)
+ (setq gnus-zombie-list (cons group gnus-zombie-list))
+ (setq gnus-killed-list (cons group gnus-killed-list)))))
+ (t
+ ;; If the list is to be entered into the newsrc assoc, and
+ ;; it was killed, we have to create an entry in the newsrc
+ ;; hashtb format and fix the pointers in the newsrc assoc.
+ (if (>= oldlevel gnus-level-zombie)
+ (progn
+ (if (listp entry)
+ (progn
+ (setq info (cdr entry))
+ (setq num (car entry)))
+ (setq active (gnus-gethash group gnus-active-hashtb))
+ (setq num
+ (if active (- (1+ (cdr active)) (car active)) t))
+ ;; Check whether the group is foreign. If so, the
+ ;; foreign select method has to be entered into the
+ ;; info.
+ (let ((method (gnus-group-method-name group)))
+ (if (eq method gnus-select-method)
+ (setq info (list group level nil))
+ (setq info (list group level nil nil method)))))
+ (or previous
+ (setq previous
+ (let ((p gnus-newsrc-alist))
+ (while (cdr (cdr p))
+ (setq p (cdr p)))
+ p)))
+ (setq entry (cons info (cdr (cdr previous))))
+ (if (cdr previous)
+ (progn
+ (setcdr (cdr previous) entry)
+ (gnus-sethash group (cons num (cdr previous))
+ gnus-newsrc-hashtb))
+ (setcdr previous entry)
+ (gnus-sethash group (cons num previous)
+ gnus-newsrc-hashtb))
+ (if (cdr entry)
+ (setcdr (gnus-gethash (car (car (cdr entry)))
+ gnus-newsrc-hashtb)
+ entry)))
+ ;; It was alive, and it is going to stay alive, so we
+ ;; just change the level and don't change any pointers or
+ ;; hash table entries.
+ (setcar (cdr (car (cdr (cdr entry)))) level)))))))
+
+(defun gnus-kill-newsgroup (newsgroup)
+ "Obsolete function. Kills a newsgroup."
+ (gnus-group-change-level
+ (gnus-gethash newsgroup gnus-newsrc-hashtb) gnus-level-killed))
+
+(defun gnus-check-bogus-newsgroups (&optional confirm)
+ "Remove bogus newsgroups.
+If CONFIRM is non-nil, the user has to confirm the deletion of every
+newsgroup."
+ (let ((newsrc (cdr gnus-newsrc-alist))
+ bogus group entry)
+ (gnus-message 5 "Checking bogus newsgroups...")
+ (or gnus-have-read-active-file (gnus-read-active-file))
+ ;; Find all bogus newsgroup that are subscribed.
+ (while newsrc
+ (setq group (car (car newsrc)))
+ (if (or (gnus-gethash group gnus-active-hashtb) ; Active
+ (nth 4 (car newsrc)) ; Foreign
+ (and confirm
+ (not (gnus-y-or-n-p
+ (format "Remove bogus newsgroup: %s " group)))))
+ ;; Don't remove.
+ ()
+ ;; Found a bogus newsgroup.
+ (setq bogus (cons group bogus)))
+ (setq newsrc (cdr newsrc)))
+ ;; Remove all bogus subscribed groups by first killing them, and
+ ;; then removing them from the list of killed groups.
+ (while bogus
+ (and (setq entry (gnus-gethash (car bogus) gnus-newsrc-hashtb))
+ (progn
+ (gnus-group-change-level entry gnus-level-killed)
+ (setq gnus-killed-list (delete (car bogus) gnus-killed-list))))
+ (setq bogus (cdr bogus)))
+ ;; Then we remove all bogus groups from the list of killed and
+ ;; zombie groups. They are are removed without confirmation.
+ (let ((dead-lists '(gnus-killed-list gnus-zombie-list))
+ killed)
+ (while dead-lists
+ (setq killed (symbol-value (car dead-lists)))
+ (while killed
+ (setq group (car killed))
+ (or (gnus-gethash group gnus-active-hashtb)
+ ;; The group is bogus.
+ (set (car dead-lists)
+ (delete group (symbol-value (car dead-lists)))))
+ (setq killed (cdr killed)))
+ (setq dead-lists (cdr dead-lists))))
+ (gnus-message 5 "Checking bogus newsgroups...done")))
+
+(defun gnus-check-duplicate-killed-groups ()
+ "Remove duplicates from the list of killed groups."
+ (interactive)
+ (let ((killed gnus-killed-list))
+ (while killed
+ (gnus-message 9 "%d" (length killed))
+ (setcdr killed (delete (car killed) (cdr killed)))
+ (setq killed (cdr killed)))))
+
+;; Go though `gnus-newsrc-alist' and compare with `gnus-active-hashtb'
+;; and compute how many unread articles there are in each group.
+(defun gnus-get-unread-articles (&optional level)
+ (let* ((newsrc (cdr gnus-newsrc-alist))
+ (level (or level (1+ gnus-level-subscribed)))
+ (foreign-level
+ (min
+ (cond ((and gnus-activate-foreign-newsgroups
+ (not (numberp gnus-activate-foreign-newsgroups)))
+ (1+ gnus-level-subscribed))
+ ((numberp gnus-activate-foreign-newsgroups)
+ gnus-activate-foreign-newsgroups)
+ (t 0))
+ level))
+ info group active virtuals method)
+ (gnus-message 5 "Checking new news...")
+
+ (while newsrc
+ (setq info (car newsrc)
+ group (car info)
+ active (gnus-gethash group gnus-active-hashtb))
+
+ ;; Check newsgroups. If the user doesn't want to check them, or
+ ;; they can't be checked (for instance, if the news server can't
+ ;; be reached) we just set the number of unread articles in this
+ ;; newsgroup to t. This means that Gnus thinks that there are
+ ;; unread articles, but it has no idea how many.
+ (if (and (setq method (nth 4 info))
+ (not (gnus-server-equal gnus-select-method
+ (gnus-server-get-method nil method)))
+ (not (gnus-secondary-method-p method)))
+ ;; These groups are foreign. Check the level.
+ (if (<= (nth 1 info) foreign-level)
+ (if (eq (car (if (stringp method)
+ (gnus-server-to-method method)
+ (nth 4 info))) 'nnvirtual)
+ ;; We have to activate the virtual groups after all
+ ;; the others, so we just pop them on a list for
+ ;; now.
+ (setq virtuals (cons info virtuals))
+ (and (setq active (gnus-activate-group (car info)))
+ ;; Close the groups as we look at them!
+ (gnus-close-group group))))
+
+ ;; These groups are native or secondary.
+ (if (and (not gnus-read-active-file)
+ (<= (nth 1 info) level))
+ (progn
+ (or gnus-read-active-file (gnus-check-server method))
+ (setq active (gnus-activate-group (car info))))))
+
+ (if active
+ (gnus-get-unread-articles-in-group info active)
+ ;; The group couldn't be reached, so we nix out the number of
+ ;; unread articles and stuff.
+ (gnus-sethash group nil gnus-active-hashtb)
+ (setcar (gnus-gethash group gnus-newsrc-hashtb) t))
+
+ (setq newsrc (cdr newsrc)))
+
+ ;; Activate the virtual groups. This has to be done after all the
+ ;; other groups.
+ ;; !!! If one virtual group contains another virtual group, even
+ ;; doing it this way might cause problems.
+ (while virtuals
+ (and (setq active (gnus-activate-group (car (car virtuals))))
+ (gnus-get-unread-articles-in-group (car virtuals) active))
+ (setq virtuals (cdr virtuals)))
+
+ (gnus-message 5 "Checking new news...done")))
+
+;; Create a hash table out of the newsrc alist. The `car's of the
+;; alist elements are used as keys.
+(defun gnus-make-hashtable-from-newsrc-alist ()
+ (let ((alist gnus-newsrc-alist)
+ (ohashtb gnus-newsrc-hashtb)
+ prev)
+ (setq gnus-newsrc-hashtb (gnus-make-hashtable (length alist)))
+ (setq alist
+ (setq prev (setq gnus-newsrc-alist
+ (if (equal (car (car gnus-newsrc-alist))
+ "dummy.group")
+ gnus-newsrc-alist
+ (cons (list "dummy.group" 0 nil) alist)))))
+ (while alist
+ (gnus-sethash (car (car alist))
+ (cons (and ohashtb (car (gnus-gethash
+ (car (car alist)) ohashtb)))
+ prev) gnus-newsrc-hashtb)
+ (setq prev alist
+ alist (cdr alist)))))
+
+(defun gnus-make-hashtable-from-killed ()
+ "Create a hash table from the killed and zombie lists."
+ (let ((lists '(gnus-killed-list gnus-zombie-list))
+ list)
+ (setq gnus-killed-hashtb
+ (gnus-make-hashtable
+ (+ (length gnus-killed-list) (length gnus-zombie-list))))
+ (while lists
+ (setq list (symbol-value (car lists)))
+ (setq lists (cdr lists))
+ (while list
+ (gnus-sethash (car list) (car list) gnus-killed-hashtb)
+ (setq list (cdr list))))))
+
+(defun gnus-get-unread-articles-in-group (info active)
+ (let* ((range (nth 2 info))
+ (num 0)
+ (marked (nth 3 info)))
+ ;; If a cache is present, we may have to alter the active info.
+ (and gnus-use-cache
+ (gnus-cache-possibly-alter-active (car info) active))
+ ;; Modify the list of read articles according to what articles
+ ;; are available; then tally the unread articles and add the
+ ;; number to the group hash table entry.
+ (cond
+ ((zerop (cdr active))
+ (setq num 0))
+ ((not range)
+ (setq num (- (1+ (cdr active)) (car active))))
+ ((not (listp (cdr range)))
+ ;; Fix a single (num . num) range according to the
+ ;; active hash table.
+ ;; Fix by Carsten Bormann <cabo@Informatik.Uni-Bremen.DE>.
+ (and (< (cdr range) (car active)) (setcdr range (1- (car active))))
+ (and (> (cdr range) (cdr active)) (setcdr range (cdr active)))
+ ;; Compute number of unread articles.
+ (setq num (max 0 (- (cdr active) (- (1+ (cdr range)) (car range))))))
+ (t
+ ;; The read list is a list of ranges. Fix them according to
+ ;; the active hash table.
+ ;; First peel off any elements that are below the lower
+ ;; active limit.
+ (while (and (cdr range)
+ (>= (car active)
+ (or (and (atom (car (cdr range))) (car (cdr range)))
+ (car (car (cdr range))))))
+ (if (numberp (car range))
+ (setcar range
+ (cons (car range)
+ (or (and (numberp (car (cdr range)))
+ (car (cdr range)))
+ (cdr (car (cdr range))))))
+ (setcdr (car range)
+ (or (and (numberp (nth 1 range)) (nth 1 range))
+ (cdr (car (cdr range))))))
+ (setcdr range (cdr (cdr range))))
+ ;; Adjust the first element to be the same as the lower limit.
+ (if (and (not (atom (car range)))
+ (< (cdr (car range)) (car active)))
+ (setcdr (car range) (1- (car active))))
+ ;; Then we want to peel off any elements that are higher
+ ;; than the upper active limit.
+ (let ((srange range))
+ ;; Go past all legal elements.
+ (while (and (cdr srange)
+ (<= (or (and (atom (car (cdr srange)))
+ (car (cdr srange)))
+ (car (car (cdr srange)))) (cdr active)))
+ (setq srange (cdr srange)))
+ (if (cdr srange)
+ ;; Nuke all remaining illegal elements.
+ (setcdr srange nil))
+
+ ;; Adjust the final element.
+ (if (and (not (atom (car srange)))
+ (> (cdr (car srange)) (cdr active)))
+ (setcdr (car srange) (cdr active))))
+ ;; Compute the number of unread articles.
+ (while range
+ (setq num (+ num (- (1+ (or (and (atom (car range)) (car range))
+ (cdr (car range))))
+ (or (and (atom (car range)) (car range))
+ (car (car range))))))
+ (setq range (cdr range)))
+ (setq num (max 0 (- (cdr active) num)))))
+ (and info
+ (progn
+ (and (assq 'tick marked)
+ (inline (gnus-remove-illegal-marked-articles
+ (assq 'tick marked) (nth 2 info))))
+ (and (assq 'dormant marked)
+ (inline (gnus-remove-illegal-marked-articles
+ (assq 'dormant marked) (nth 2 info))))
+ (setcar
+ (gnus-gethash (car info) gnus-newsrc-hashtb)
+ (setq num (max 0 (- num (length (cdr (assq 'tick marked)))
+ (length (cdr (assq 'dormant marked)))))))))
+ num))
+
+(defun gnus-remove-illegal-marked-articles (marked ranges)
+ (let ((m (cdr marked)))
+ ;; Make sure that all ticked articles are a subset of the unread
+ ;; articles.
+ (while m
+ (if (gnus-member-of-range (car m) ranges)
+ (setcdr marked (cdr m))
+ (setq marked m))
+ (setq m (cdr m)))))
+
+(defun gnus-activate-group (group)
+ ;; Check whether a group has been activated or not.
+ (let ((method (gnus-find-method-for-group group))
+ active)
+ (and (gnus-check-server method)
+ ;; We escape all bugs and quit here to make it possible to
+ ;; continue if a group is so out-there that it reports bugs
+ ;; and stuff.
+ (condition-case ()
+ (gnus-request-group group)
+ (error nil)
+ (quit nil))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ ;; Parse the result we got from `gnus-request-group'.
+ (and (looking-at "[0-9]+ [0-9]+ \\([0-9]+\\) [0-9]+")
+ (progn
+ (goto-char (match-beginning 1))
+ (gnus-sethash
+ group (setq active (cons (read (current-buffer))
+ (read (current-buffer))))
+ gnus-active-hashtb))
+ ;; Return the new active info.
+ active)))))
+
+(defun gnus-update-read-articles
+ (group unread unselected ticked &optional domarks replied expirable killed
+ dormant bookmark score)
+ "Update the list of read and ticked articles in GROUP using the
+UNREAD and TICKED lists.
+Note: UNSELECTED has to be sorted over `<'.
+Returns whether the updating was successful."
+ (let* ((active (or gnus-newsgroup-active
+ (gnus-gethash group gnus-active-hashtb)))
+ (entry (gnus-gethash group gnus-newsrc-hashtb))
+ (info (nth 2 entry))
+ (marked (nth 3 info))
+ (prev 1)
+ (unread (sort (copy-sequence unread) (function <)))
+ read)
+ (if (or (not info) (not active))
+ ;; There is no info on this group if it was, in fact,
+ ;; killed. Gnus stores no information on killed groups, so
+ ;; there's nothing to be done.
+ ;; One could store the information somewhere temporarily,
+ ;; perhaps... Hmmm...
+ ()
+ ;; Remove any negative articles numbers.
+ (while (and unread (< (car unread) 0))
+ (setq unread (cdr unread)))
+ ;; Remove any expired article numbers
+ (while (and unread (< (car unread) (car active)))
+ (setq unread (cdr unread)))
+ (while (and ticked (< (car ticked) (car active)))
+ (setq ticked (cdr ticked)))
+ (while (and dormant (< (car dormant) (car active)))
+ (setq dormant (cdr dormant)))
+ (setq unread (sort (append unselected unread) '<))
+ ;; Compute the ranges of read articles by looking at the list of
+ ;; unread articles.
+ (while unread
+ (if (/= (car unread) prev)
+ (setq read (cons (if (= prev (1- (car unread))) prev
+ (cons prev (1- (car unread)))) read)))
+ (setq prev (1+ (car unread)))
+ (setq unread (cdr unread)))
+ (if (<= prev (cdr active))
+ (setq read (cons (cons prev (cdr active)) read)))
+ ;; Enter this list into the group info.
+ (setcar (cdr (cdr info))
+ (if (> (length read) 1) (nreverse read) read))
+ ;; Enter the list of ticked articles.
+ (gnus-set-marked-articles
+ info ticked
+ (if domarks replied (cdr (assq 'reply marked)))
+ (if domarks expirable (cdr (assq 'expire marked)))
+ (if domarks killed (cdr (assq 'killed marked)))
+ (if domarks dormant (cdr (assq 'dormant marked)))
+ (if domarks bookmark (cdr (assq 'bookmark marked)))
+ (if domarks score (cdr (assq 'score marked))))
+ ;; Set the number of unread articles in gnus-newsrc-hashtb.
+ (gnus-get-unread-articles-in-group
+ info (gnus-gethash group gnus-active-hashtb))
+ t)))
+
+(defun gnus-make-articles-unread (group articles)
+ "Mark ARTICLES in GROUP as unread."
+ (let* ((info (nth 2 (or (gnus-gethash group gnus-newsrc-hashtb)
+ (gnus-gethash (gnus-group-real-name group)
+ gnus-newsrc-hashtb))))
+ (ranges (nth 2 info))
+ news)
+ (while articles
+ (and (gnus-member-of-range (car articles) ranges)
+ (setq news (cons (car articles) news)))
+ (setq articles (cdr articles)))
+ (if (not news)
+ ()
+ (setcar (nthcdr 2 info)
+ (gnus-remove-from-range (nth 2 info) (nreverse news)))
+ (gnus-group-update-group group t))))
+
+;; Enter all dead groups into the hashtb.
+(defun gnus-update-active-hashtb-from-killed ()
+ (let ((hashtb (setq gnus-active-hashtb (make-vector 4095 0)))
+ (lists (list gnus-killed-list gnus-zombie-list))
+ killed)
+ (while lists
+ (setq killed (car lists))
+ (while killed
+ (gnus-sethash (car killed) nil hashtb)
+ (setq killed (cdr killed)))
+ (setq lists (cdr lists)))))
+
+;; Get the active file(s) from the backend(s).
+(defun gnus-read-active-file ()
+ (gnus-group-set-mode-line)
+ (let ((methods (if (gnus-check-server gnus-select-method)
+ ;; The native server is available.
+ (cons gnus-select-method gnus-secondary-select-methods)
+ ;; The native server is down, so we just do the
+ ;; secondary ones.
+ gnus-secondary-select-methods))
+ list-type)
+ (setq gnus-have-read-active-file nil)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (while methods
+ (let* ((method (gnus-server-get-method nil (car methods)))
+ (where (nth 1 method))
+ (mesg (format "Reading active file%s via %s..."
+ (if (and where (not (zerop (length where))))
+ (concat " from " where) "")
+ (car method))))
+ (gnus-message 5 mesg)
+ (if (not (gnus-check-server method))
+ ()
+ (cond
+ ((and (eq gnus-read-active-file 'some)
+ (gnus-check-backend-function 'retrieve-groups (car method)))
+ (let ((newsrc (cdr gnus-newsrc-alist))
+ (gmethod (gnus-server-get-method nil method))
+ groups)
+ (while newsrc
+ (and (gnus-server-equal
+ (gnus-find-method-for-group
+ (car (car newsrc)) (car newsrc))
+ gmethod)
+ (setq groups (cons (gnus-group-real-name
+ (car (car newsrc))) groups)))
+ (setq newsrc (cdr newsrc)))
+ (gnus-check-server method)
+ (setq list-type (gnus-retrieve-groups groups method))
+ (cond
+ ((not list-type)
+ (gnus-message
+ 1 "Cannot read partial active file from %s server."
+ (car method))
+ (ding)
+ (sit-for 2))
+ ((eq list-type 'active)
+ (gnus-active-to-gnus-format method gnus-active-hashtb))
+ (t
+ (gnus-groups-to-gnus-format method gnus-active-hashtb)))))
+ (t
+ (if (not (gnus-request-list method))
+ (progn
+ (gnus-message 1 "Cannot read active file from %s server."
+ (car method))
+ (ding))
+ (gnus-active-to-gnus-format method)
+ ;; We mark this active file as read.
+ (setq gnus-have-read-active-file
+ (cons method gnus-have-read-active-file))
+ (gnus-message 5 "%sdone" mesg))))))
+ (setq methods (cdr methods))))))
+
+;; Read an active file and place the results in `gnus-active-hashtb'.
+(defun gnus-active-to-gnus-format (method &optional hashtb ignore-errors)
+ (let ((cur (current-buffer))
+ (hashtb (or hashtb
+ (if (and gnus-active-hashtb
+ (not (equal method gnus-select-method)))
+ gnus-active-hashtb
+ (setq gnus-active-hashtb
+ (if (equal method gnus-select-method)
+ (gnus-make-hashtable
+ (count-lines (point-min) (point-max)))
+ (gnus-make-hashtable 4096))))))
+ (flag-hashtb (gnus-make-hashtable 60)))
+ ;; Delete unnecessary lines.
+ (goto-char (point-min))
+ (while (search-forward "\nto." nil t)
+ (delete-region (1+ (match-beginning 0))
+ (progn (forward-line 1) (point))))
+ (or (string= gnus-ignored-newsgroups "")
+ (progn
+ (goto-char (point-min))
+ (delete-matching-lines gnus-ignored-newsgroups)))
+ ;; Make the group names readable as a lisp expression even if they
+ ;; contain special characters.
+ ;; Fix by Luc Van Eycken <Luc.VanEycken@esat.kuleuven.ac.be>.
+ (goto-char (point-max))
+ (while (re-search-backward "[][';?()#]" nil t)
+ (insert ?\\))
+ ;; If these are groups from a foreign select method, we insert the
+ ;; group prefix in front of the group names.
+ (and method (not (gnus-server-equal
+ (gnus-server-get-method nil method)
+ (gnus-server-get-method nil gnus-select-method)))
+ (let ((prefix (gnus-group-prefixed-name "" method)))
+ (goto-char (point-min))
+ (while (and (not (eobp))
+ (progn (insert prefix)
+ (zerop (forward-line 1)))))))
+ ;; Store the active file in a hash table.
+ (goto-char (point-min))
+ (if (string-match "%[oO]" gnus-group-line-format)
+ ;; Suggested by Brian Edmonds <edmonds@cs.ubc.ca>.
+ ;; If we want information on moderated groups, we use this
+ ;; loop...
+ (let* ((mod-hashtb (make-vector 7 0))
+ (m (intern "m" mod-hashtb))
+ group max min)
+ (while (not (eobp))
+ (condition-case nil
+ (progn
+ (narrow-to-region (point) (gnus-point-at-eol))
+ (setq group (let ((obarray hashtb)) (read cur)))
+ (if (and (numberp (setq max (read cur)))
+ (numberp (setq min (read cur)))
+ (progn
+ (skip-chars-forward " \t")
+ (not
+ (or (= (following-char) ?=)
+ (= (following-char) ?x)
+ (= (following-char) ?j)))))
+ (set group (cons min max))
+ (set group nil))
+ ;; Enter moderated groups into a list.
+ (if (eq (let ((obarray mod-hashtb)) (read cur)) m)
+ (setq gnus-moderated-list
+ (cons (symbol-name group) gnus-moderated-list))))
+ (error
+ (and group
+ (symbolp group)
+ (set group nil))))
+ (widen)
+ (forward-line 1)))
+ ;; And if we do not care about moderation, we use this loop,
+ ;; which is faster.
+ (let (group max min)
+ (while (not (eobp))
+ (condition-case ()
+ (progn
+ (narrow-to-region (point) (gnus-point-at-eol))
+ ;; group gets set to a symbol interned in the hash table
+ ;; (what a hack!!) - jwz
+ (setq group (let ((obarray hashtb)) (read cur)))
+ (if (and (numberp (setq max (read cur)))
+ (numberp (setq min (read cur)))
+ (progn
+ (skip-chars-forward " \t")
+ (not
+ (or (= (following-char) ?=)
+ (= (following-char) ?x)
+ (= (following-char) ?j)))))
+ (set group (cons min max))
+ (set group nil)))
+ (error
+ (progn
+ (and group
+ (symbolp group)
+ (set group nil))
+ (or ignore-errors
+ (gnus-message 3 "Warning - illegal active: %s"
+ (buffer-substring
+ (gnus-point-at-bol) (gnus-point-at-eol)))))))
+ (widen)
+ (forward-line 1))))))
+
+(defun gnus-groups-to-gnus-format (method &optional hashtb)
+ ;; Parse a "groups" active file.
+ (let ((cur (current-buffer))
+ (hashtb (or hashtb
+ (if (and method gnus-active-hashtb)
+ gnus-active-hashtb
+ (setq gnus-active-hashtb
+ (gnus-make-hashtable
+ (count-lines (point-min) (point-max)))))))
+ (prefix (and method
+ (not (gnus-server-equal
+ (gnus-server-get-method nil method)
+ (gnus-server-get-method nil gnus-select-method)))
+ (gnus-group-prefixed-name "" method))))
+
+ (goto-char (point-min))
+ ;; We split this into to separate loops, one with the prefix
+ ;; and one without to speed the reading up somewhat.
+ (if prefix
+ (let (min max opoint group)
+ (while (not (eobp))
+ (condition-case ()
+ (progn
+ (read cur) (read cur)
+ (setq min (read cur)
+ max (read cur)
+ opoint (point))
+ (skip-chars-forward " \t")
+ (insert prefix)
+ (goto-char opoint)
+ (set (let ((obarray hashtb)) (read cur))
+ (cons min max)))
+ (error (and group (symbolp group) (set group nil))))
+ (forward-line 1)))
+ (let (min max group)
+ (while (not (eobp))
+ (condition-case ()
+ (if (= (following-char) ?2)
+ (progn
+ (read cur) (read cur)
+ (setq min (read cur)
+ max (read cur))
+ (set (setq group (let ((obarray hashtb)) (read cur)))
+ (cons min max))))
+ (error (and group (symbolp group) (set group nil))))
+ (forward-line 1))))))
+
+(defun gnus-read-newsrc-file (&optional force)
+ "Read startup file.
+If FORCE is non-nil, the .newsrc file is read."
+ ;; Reset variables that might be defined in the .newsrc.eld file.
+ (let ((variables gnus-variable-list))
+ (while variables
+ (set (car variables) nil)
+ (setq variables (cdr variables))))
+ (let* ((newsrc-file gnus-current-startup-file)
+ (quick-file (concat newsrc-file ".el")))
+ (save-excursion
+ ;; We always load the .newsrc.eld file. If always contains
+ ;; much information that can not be gotten from the .newsrc
+ ;; file (ticked articles, killed groups, foreign methods, etc.)
+ (gnus-read-newsrc-el-file quick-file)
+
+ (if (or force
+ (and (file-newer-than-file-p newsrc-file quick-file)
+ (file-newer-than-file-p newsrc-file
+ (concat quick-file "d")))
+ (not gnus-newsrc-alist))
+ ;; We read the .newsrc file. Note that if there if a
+ ;; .newsrc.eld file exists, it has already been read, and
+ ;; the `gnus-newsrc-hashtb' has been created. While reading
+ ;; the .newsrc file, Gnus will only use the information it
+ ;; can find there for changing the data already read -
+ ;; ie. reading the .newsrc file will not trash the data
+ ;; already read (except for read articles).
+ (save-excursion
+ (gnus-message 5 "Reading %s..." newsrc-file)
+ (set-buffer (find-file-noselect newsrc-file))
+ (buffer-disable-undo (current-buffer))
+ (gnus-newsrc-to-gnus-format)
+ (kill-buffer (current-buffer))
+ (gnus-message 5 "Reading %s...done" newsrc-file))))))
+
+(defun gnus-read-newsrc-el-file (file)
+ (let ((ding-file (concat file "d")))
+ ;; We always, always read the .eld file.
+ (gnus-message 5 "Reading %s..." ding-file)
+ (let (gnus-newsrc-assoc)
+ (condition-case nil
+ (load ding-file t t t)
+ (error nil))
+ (and gnus-newsrc-assoc (setq gnus-newsrc-alist gnus-newsrc-assoc)))
+ (let ((inhibit-quit t))
+ (gnus-uncompress-newsrc-alist))
+ (gnus-make-hashtable-from-newsrc-alist)
+ (if (not (file-newer-than-file-p file ding-file))
+ ()
+ ;; Old format quick file
+ (gnus-message 5 "Reading %s..." file)
+ ;; The .el file is newer than the .eld file, so we read that one
+ ;; as well.
+ (gnus-read-old-newsrc-el-file file))))
+
+;; Parse the old-style quick startup file
+(defun gnus-read-old-newsrc-el-file (file)
+ (let (newsrc killed marked group m)
+ (prog1
+ (let ((gnus-killed-assoc nil)
+ gnus-marked-assoc gnus-newsrc-alist gnus-newsrc-assoc)
+ (prog1
+ (condition-case nil
+ (load file t t t)
+ (error nil))
+ (setq newsrc gnus-newsrc-assoc
+ killed gnus-killed-assoc
+ marked gnus-marked-assoc)))
+ (setq gnus-newsrc-alist nil)
+ (while newsrc
+ (setq group (car newsrc))
+ (let ((info (nth 2 (gnus-gethash (car group) gnus-newsrc-hashtb))))
+ (if info
+ (progn
+ (setcar (nthcdr 2 info) (cdr (cdr group)))
+ (setcar (cdr info)
+ (if (nth 1 group) gnus-level-default-subscribed
+ gnus-level-default-unsubscribed))
+ (setq gnus-newsrc-alist (cons info gnus-newsrc-alist)))
+ (setq gnus-newsrc-alist
+ (cons
+ (setq info
+ (list (car group)
+ (if (nth 1 group) gnus-level-default-subscribed
+ gnus-level-default-unsubscribed)
+ (cdr (cdr group))))
+ gnus-newsrc-alist)))
+ (if (setq m (assoc (car group) marked))
+ (setcdr (cdr (cdr info))
+ (cons (list (cons 'tick (cdr m))) nil))))
+ (setq newsrc (cdr newsrc)))
+ (setq newsrc killed)
+ (while newsrc
+ (setcar newsrc (car (car newsrc)))
+ (setq newsrc (cdr newsrc)))
+ (setq gnus-killed-list killed))
+ ;; The .el file version of this variable does not begin with
+ ;; "options", while the .eld version does, so we just add it if it
+ ;; isn't there.
+ (and
+ gnus-newsrc-options
+ (progn
+ (and (not (string-match "^ *options" gnus-newsrc-options))
+ (setq gnus-newsrc-options (concat "options " gnus-newsrc-options)))
+ (and (not (string-match "\n$" gnus-newsrc-options))
+ (setq gnus-newsrc-options (concat gnus-newsrc-options "\n")))
+ ;; Finally, if we read some options lines, we parse them.
+ (or (string= gnus-newsrc-options "")
+ (gnus-newsrc-parse-options gnus-newsrc-options))))
+
+ (setq gnus-newsrc-alist (nreverse gnus-newsrc-alist))
+ (gnus-make-hashtable-from-newsrc-alist)))
+
+(defun gnus-make-newsrc-file (file)
+ "Make server dependent file name by catenating FILE and server host name."
+ (let* ((file (expand-file-name file nil))
+ (real-file (concat file "-" (nth 1 gnus-select-method))))
+ (if (or (file-exists-p real-file)
+ (file-exists-p (concat real-file ".el"))
+ (file-exists-p (concat real-file ".eld")))
+ real-file file)))
+
+(defun gnus-uncompress-newsrc-alist ()
+ ;; Uncompress all lists of marked articles in the newsrc assoc.
+ (let ((newsrc gnus-newsrc-alist)
+ marked)
+ (while newsrc
+ (if (not (setq marked (nth 3 (car newsrc))))
+ ()
+ (while marked
+ (or (eq 'score (car (car marked)))
+ (eq 'bookmark (car (car marked)))
+ (eq 'killed (car (car marked)))
+ (setcdr (car marked) (gnus-uncompress-range (cdr (car marked)))))
+ (setq marked (cdr marked))))
+ (setq newsrc (cdr newsrc)))))
+
+(defun gnus-compress-newsrc-alist ()
+ ;; Compress all lists of marked articles in the newsrc assoc.
+ (let ((newsrc gnus-newsrc-alist)
+ marked)
+ (while newsrc
+ (if (not (setq marked (nth 3 (car newsrc))))
+ ()
+ (while marked
+ (or (eq 'score (car (car marked)))
+ (eq 'bookmark (car (car marked)))
+ (eq 'killed (car (car marked)))
+ (setcdr (car marked)
+ (condition-case ()
+ (gnus-compress-sequence
+ (sort (cdr (car marked)) '<) t)
+ (error (cdr (car marked))))))
+ (setq marked (cdr marked))))
+ (setq newsrc (cdr newsrc)))))
+
+(defun gnus-newsrc-to-gnus-format ()
+ (setq gnus-newsrc-options "")
+ (setq gnus-newsrc-options-n nil)
+
+ (or gnus-active-hashtb
+ (setq gnus-active-hashtb (make-vector 4095 0)))
+ (let ((buf (current-buffer))
+ (already-read (> (length gnus-newsrc-alist) 1))
+ group subscribed options-symbol newsrc Options-symbol
+ symbol reads num1)
+ (goto-char (point-min))
+ ;; We intern the symbol `options' in the active hashtb so that we
+ ;; can `eq' against it later.
+ (set (setq options-symbol (intern "options" gnus-active-hashtb)) nil)
+ (set (setq Options-symbol (intern "Options" gnus-active-hashtb)) nil)
+
+ (while (not (eobp))
+ ;; We first read the first word on the line by narrowing and
+ ;; then reading into `gnus-active-hashtb'. Most groups will
+ ;; already exist in that hashtb, so this will save some string
+ ;; space.
+ (narrow-to-region
+ (point)
+ (progn (skip-chars-forward "^ \t!:\n") (point)))
+ (goto-char (point-min))
+ (setq symbol
+ (and (/= (point-min) (point-max))
+ (let ((obarray gnus-active-hashtb)) (read buf))))
+ (widen)
+ ;; Now, the symbol we have read is either `options' or a group
+ ;; name. If it is an options line, we just add it to a string.
+ (cond
+ ((or (eq symbol options-symbol)
+ (eq symbol Options-symbol))
+ (setq gnus-newsrc-options
+ ;; This concatting is quite inefficient, but since our
+ ;; thorough studies show that approx 99.37% of all
+ ;; .newsrc files only contain a single options line, we
+ ;; don't give a damn, frankly, my dear.
+ (concat gnus-newsrc-options
+ (buffer-substring
+ (gnus-point-at-bol)
+ ;; Options may continue on the next line.
+ (or (and (re-search-forward "^[^ \t]" nil 'move)
+ (progn (beginning-of-line) (point)))
+ (point)))))
+ (forward-line -1))
+ (symbol
+ (or (boundp symbol) (set symbol nil))
+ ;; It was a group name.
+ (setq subscribed (= (following-char) ?:)
+ group (symbol-name symbol)
+ reads nil)
+ (if (eolp)
+ ;; If the line ends here, this is clearly a buggy line, so
+ ;; we put point a the beginning of line and let the cond
+ ;; below do the error handling.
+ (beginning-of-line)
+ ;; We skip to the beginning of the ranges.
+ (skip-chars-forward "!: \t"))
+ ;; We are now at the beginning of the list of read articles.
+ ;; We read them range by range.
+ (while
+ (cond
+ ((looking-at "[0-9]+")
+ ;; We narrow and read a number instead of buffer-substring/
+ ;; string-to-int because it's faster. narrow/widen is
+ ;; faster than save-restriction/narrow, and save-restriction
+ ;; produces a garbage object.
+ (setq num1 (progn
+ (narrow-to-region (match-beginning 0) (match-end 0))
+ (read buf)))
+ (widen)
+ ;; If the next character is a dash, then this is a range.
+ (if (= (following-char) ?-)
+ (progn
+ ;; We read the upper bound of the range.
+ (forward-char 1)
+ (if (not (looking-at "[0-9]+"))
+ ;; This is a buggy line, by we pretend that
+ ;; it's kinda OK. Perhaps the user should be
+ ;; dinged?
+ (setq reads (cons num1 reads))
+ (setq reads
+ (cons
+ (cons num1
+ (progn
+ (narrow-to-region (match-beginning 0)
+ (match-end 0))
+ (read buf)))
+ reads))
+ (widen)))
+ ;; It was just a simple number, so we add it to the
+ ;; list of ranges.
+ (setq reads (cons num1 reads)))
+ ;; If the next char in ?\n, then we have reached the end
+ ;; of the line and return nil.
+ (/= (following-char) ?\n))
+ ((= (following-char) ?\n)
+ ;; End of line, so we end.
+ nil)
+ (t
+ ;; Not numbers and not eol, so this might be a buggy
+ ;; line...
+ (or (eobp)
+ ;; If it was eob instead of ?\n, we allow it.
+ (progn
+ ;; The line was buggy.
+ (setq group nil)
+ (gnus-message 3 "Mangled line: %s"
+ (buffer-substring (gnus-point-at-bol)
+ (gnus-point-at-eol)))
+ (ding)
+ (sit-for 1)))
+ nil))
+ ;; Skip past ", ". Spaces are illegal in these ranges, but
+ ;; we allow them, because it's a common mistake to put a
+ ;; space after the comma.
+ (skip-chars-forward ", "))
+
+ ;; We have already read .newsrc.eld, so we gently update the
+ ;; data in the hash table with the information we have just
+ ;; read.
+ (if (not group)
+ ()
+ (let ((info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
+ level)
+ (if info
+ ;; There is an entry for this file in the alist.
+ (progn
+ (setcar (nthcdr 2 info) (nreverse reads))
+ ;; We update the level very gently. In fact, we
+ ;; only change it if there's been a status change
+ ;; from subscribed to unsubscribed, or vice versa.
+ (setq level (nth 1 info))
+ (cond ((and (<= level gnus-level-subscribed)
+ (not subscribed))
+ (setq level (if reads
+ gnus-level-default-unsubscribed
+ (1+ gnus-level-default-unsubscribed))))
+ ((and (> level gnus-level-subscribed) subscribed)
+ (setq level gnus-level-default-subscribed)))
+ (setcar (cdr info) level))
+ ;; This is a new group.
+ (setq info (list group
+ (if subscribed
+ gnus-level-default-subscribed
+ (if reads
+ (1+ gnus-level-subscribed)
+ gnus-level-default-unsubscribed))
+ (nreverse reads))))
+ (setq newsrc (cons info newsrc))))))
+ (forward-line 1))
+
+ (setq newsrc (nreverse newsrc))
+
+ (if (not already-read)
+ ()
+ ;; We now have two newsrc lists - `newsrc', which is what we
+ ;; have read from .newsrc, and `gnus-newsrc-alist', which is
+ ;; what we've read from .newsrc.eld. We have to merge these
+ ;; lists. We do this by "attaching" any (foreign) groups in the
+ ;; gnus-newsrc-alist to the (native) group that precedes them.
+ (let ((rc (cdr gnus-newsrc-alist))
+ (prev gnus-newsrc-alist)
+ entry mentry)
+ (while rc
+ (or (null (nth 4 (car rc))) ; It's a native group.
+ (assoc (car (car rc)) newsrc) ; It's already in the alist.
+ (if (setq entry (assoc (car (car prev)) newsrc))
+ (setcdr (setq mentry (memq entry newsrc))
+ (cons (car rc) (cdr mentry)))
+ (setq newsrc (cons (car rc) newsrc))))
+ (setq prev rc
+ rc (cdr rc)))))
+
+ (setq gnus-newsrc-alist newsrc)
+ ;; We make the newsrc hashtb.
+ (gnus-make-hashtable-from-newsrc-alist)
+
+ ;; Finally, if we read some options lines, we parse them.
+ (or (string= gnus-newsrc-options "")
+ (gnus-newsrc-parse-options gnus-newsrc-options))))
+
+;; Parse options lines to find "options -n !all rec.all" and stuff.
+;; The return value will be a list on the form
+;; ((regexp1 . ignore)
+;; (regexp2 . subscribe)...)
+;; When handling new newsgroups, groups that match a `ignore' regexp
+;; will be ignored, and groups that match a `subscribe' regexp will be
+;; subscribed. A line like
+;; options -n !all rec.all
+;; will lead to a list that looks like
+;; (("^rec\\..+" . subscribe)
+;; ("^.+" . ignore))
+;; So all "rec.*" groups will be subscribed, while all the other
+;; groups will be ignored. Note that "options -n !all rec.all" is very
+;; different from "options -n rec.all !all".
+(defun gnus-newsrc-parse-options (options)
+ (let (out eol)
+ (save-excursion
+ (gnus-set-work-buffer)
+ (insert (regexp-quote options))
+ ;; First we treat all continuation lines.
+ (goto-char (point-min))
+ (while (re-search-forward "\n[ \t]+" nil t)
+ (replace-match " " t t))
+ ;; Then we transform all "all"s into ".+"s.
+ (goto-char (point-min))
+ (while (re-search-forward "\\ball\\b" nil t)
+ (replace-match ".+" t t))
+ (goto-char (point-min))
+ ;; We remove all other options than the "-n" ones.
+ (while (re-search-forward "[ \t]-[^n][^-]*" nil t)
+ (replace-match " ")
+ (forward-char -1))
+ (goto-char (point-min))
+
+ ;; We are only interested in "options -n" lines - we
+ ;; ignore the other option lines.
+ (while (re-search-forward "[ \t]-n" nil t)
+ (setq eol
+ (or (save-excursion
+ (and (re-search-forward "[ \t]-n" (gnus-point-at-eol) t)
+ (- (point) 2)))
+ (gnus-point-at-eol)))
+ ;; Search for all "words"...
+ (while (re-search-forward "[^ \t,\n]+" eol t)
+ (if (= (char-after (match-beginning 0)) ?!)
+ ;; If the word begins with a bang (!), this is a "not"
+ ;; spec. We put this spec (minus the bang) and the
+ ;; symbol `ignore' into the list.
+ (setq out (cons (cons (concat
+ "^" (buffer-substring
+ (1+ (match-beginning 0))
+ (match-end 0)))
+ 'ignore) out))
+ ;; There was no bang, so this is a "yes" spec.
+ (setq out (cons (cons (concat
+ "^" (buffer-substring (match-beginning 0)
+ (match-end 0)))
+ 'subscribe) out)))))
+
+ (setq gnus-newsrc-options-n out))))
+
+
+(defun gnus-save-newsrc-file ()
+ "Save .newsrc file."
+ ;; Note: We cannot save .newsrc file if all newsgroups are removed
+ ;; from the variable gnus-newsrc-alist.
+ (and (or gnus-newsrc-alist gnus-killed-list)
+ gnus-current-startup-file
+ (progn
+ (run-hooks 'gnus-save-newsrc-hook)
+ (save-excursion
+ (if (and gnus-use-dribble-file
+ (or (not gnus-dribble-buffer)
+ (not (buffer-name gnus-dribble-buffer))
+ (zerop (save-excursion
+ (set-buffer gnus-dribble-buffer)
+ (buffer-size)))))
+ (gnus-message 4 "(No changes need to be saved)")
+ (if gnus-save-newsrc-file
+ (progn
+ (gnus-message 5 "Saving %s..." gnus-current-startup-file)
+ ;; Make backup file of master newsrc.
+ (gnus-gnus-to-newsrc-format)
+ (gnus-message 5 "Saving %s...done"
+ gnus-current-startup-file)))
+ ;; Quickly loadable .newsrc.
+ (set-buffer (get-buffer-create " *Gnus-newsrc*"))
+ (setq buffer-file-name (concat gnus-current-startup-file ".eld"))
+ (gnus-add-current-to-buffer-list)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (gnus-message 5 "Saving %s.eld..." gnus-current-startup-file)
+ (gnus-gnus-to-quick-newsrc-format)
+ (save-buffer)
+ (kill-buffer (current-buffer))
+ (gnus-message 5 "Saving %s.eld...done" gnus-current-startup-file)
+ (gnus-dribble-delete-file))))))
+
+(defun gnus-gnus-to-quick-newsrc-format ()
+ "Insert Gnus variables such as gnus-newsrc-alist in lisp format."
+ (insert ";; Gnus startup file.\n")
+ (insert ";; Never delete this file - touch .newsrc instead to force Gnus\n")
+ (insert ";; to read .newsrc.\n")
+ (insert "(setq gnus-newsrc-file-version "
+ (prin1-to-string gnus-version) ")\n")
+ (let ((variables gnus-variable-list)
+ (inhibit-quit t)
+ (gnus-newsrc-alist (cdr gnus-newsrc-alist))
+ variable)
+ ;; insert lisp expressions.
+ (gnus-compress-newsrc-alist)
+ (while variables
+ (setq variable (car variables))
+ (and (boundp variable)
+ (symbol-value variable)
+ (or gnus-save-killed-list (not (eq variable 'gnus-killed-list)))
+ (insert "(setq " (symbol-name variable) " '"
+ (prin1-to-string (symbol-value variable))
+ ")\n"))
+ (setq variables (cdr variables)))
+ (gnus-uncompress-newsrc-alist)))
+
+
+(defun gnus-gnus-to-newsrc-format ()
+ ;; Generate and save the .newsrc file.
+ (let ((newsrc (cdr gnus-newsrc-alist))
+ info ranges range)
+ (save-excursion
+ (set-buffer (create-file-buffer gnus-current-startup-file))
+ (setq buffer-file-name gnus-current-startup-file)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ ;; Write options.
+ (if gnus-newsrc-options (insert gnus-newsrc-options))
+ ;; Write subscribed and unsubscribed.
+ (while newsrc
+ (setq info (car newsrc))
+ (if (not (nth 4 info)) ;Don't write foreign groups to .newsrc.
+ (progn
+ (insert (car info) (if (> (nth 1 info) gnus-level-subscribed)
+ "!" ":"))
+ (if (setq ranges (nth 2 info))
+ (progn
+ (insert " ")
+ (if (not (listp (cdr ranges)))
+ (if (= (car ranges) (cdr ranges))
+ (insert (int-to-string (car ranges)))
+ (insert (int-to-string (car ranges)) "-"
+ (int-to-string (cdr ranges))))
+ (while ranges
+ (setq range (car ranges)
+ ranges (cdr ranges))
+ (if (or (atom range) (= (car range) (cdr range)))
+ (insert (int-to-string
+ (or (and (atom range) range)
+ (car range))))
+ (insert (int-to-string (car range)) "-"
+ (int-to-string (cdr range))))
+ (if ranges (insert ","))))))
+ (insert "\n")))
+ (setq newsrc (cdr newsrc)))
+ ;; It has been reported that sometime the modtime on the .newsrc
+ ;; file seems to be off. We really do want to overwrite it, so
+ ;; we clear the modtime here before saving. It's a bit odd,
+ ;; though...
+ ;; sometimes the modtime clear isn't sufficient. most brute force:
+ ;; delete the silly thing entirely first. but this fails to provide
+ ;; such niceties as .newsrc~ creation.
+ (if gnus-modtime-botch
+ (delete-file gnus-startup-file)
+ (clear-visited-file-modtime))
+ (save-buffer)
+ (kill-buffer (current-buffer)))))
+
+(defun gnus-read-all-descriptions-files ()
+ (let ((methods (cons gnus-select-method gnus-secondary-select-methods)))
+ (while methods
+ (gnus-read-descriptions-file (car methods))
+ (setq methods (cdr methods)))
+ t))
+
+(defun gnus-read-descriptions-file (&optional method)
+ (let ((method (or method gnus-select-method)))
+ ;; We create the hashtable whether we manage to read the desc file
+ ;; to avoid trying to re-read after a failed read.
+ (or gnus-description-hashtb
+ (setq gnus-description-hashtb
+ (gnus-make-hashtable (length gnus-active-hashtb))))
+ ;; Mark this method's desc file as read.
+ (gnus-sethash (gnus-group-prefixed-name "" method) "Has read"
+ gnus-description-hashtb)
+
+ (gnus-message 5 "Reading descriptions file via %s..." (car method))
+ (cond
+ ((not (gnus-check-server method))
+ (gnus-message 1 "Couldn't open server")
+ nil)
+ ((not (gnus-request-list-newsgroups method))
+ (gnus-message 1 "Couldn't read newsgroups descriptions")
+ nil)
+ (t
+ (let (group)
+ (save-excursion
+ (save-restriction
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (if (or (search-forward "\n.\n" nil t)
+ (goto-char (point-max)))
+ (progn
+ (beginning-of-line)
+ (narrow-to-region (point-min) (point))))
+ (goto-char (point-min))
+ (while (not (eobp))
+ ;; If we get an error, we set group to 0, which is not a
+ ;; symbol...
+ (setq group
+ (condition-case ()
+ (let ((obarray gnus-description-hashtb))
+ ;; Group is set to a symbol interned in this
+ ;; hash table.
+ (read nntp-server-buffer))
+ (error 0)))
+ (skip-chars-forward " \t")
+ ;; ... which leads to this line being effectively ignored.
+ (and (symbolp group)
+ (set group (buffer-substring
+ (point) (progn (end-of-line) (point)))))
+ (forward-line 1))))
+ (gnus-message 5 "Reading descriptions file...done")
+ t)))))
+
+(defun gnus-group-get-description (group)
+ ;; Get the description of a group by sending XGTITLE to the server.
+ (and (gnus-request-group-description group)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (and (looking-at "[^ \t]+[ \t]+\\(.*\\)")
+ (buffer-substring (match-beginning 1) (match-end 1))))))
+
+;;;
+;;; Server
+;;;
+
+(defvar gnus-server-mode-hook nil
+ "Hook run in `gnus-server-mode' buffers.")
+
+(defconst gnus-server-line-format " {%(%h:%w%)}\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.")
+
+(defconst gnus-server-line-format-alist
+ (list (list ?h 'how ?s)
+ (list ?n 'name ?s)
+ (list ?w 'where ?s)
+ ))
+
+(defconst gnus-server-mode-line-format-alist
+ (list (list ?S 'news-server ?s)
+ (list ?M 'news-method ?s)
+ (list ?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 nil)
+(put 'gnus-server-mode 'mode-class 'special)
+
+(if gnus-server-mode-map
+ nil
+ (setq gnus-server-mode-map (make-sparse-keymap))
+ (suppress-keymap gnus-server-mode-map)
+ (define-key gnus-server-mode-map " " 'gnus-server-read-server)
+ (define-key gnus-server-mode-map "\r" 'gnus-server-read-server)
+ (define-key gnus-server-mode-map gnus-mouse-2 'gnus-server-pick-server)
+ (define-key gnus-server-mode-map "q" 'gnus-server-exit)
+ (define-key gnus-server-mode-map "l" 'gnus-server-list-servers)
+ (define-key gnus-server-mode-map "k" 'gnus-server-kill-server)
+ (define-key gnus-server-mode-map "y" 'gnus-server-yank-server)
+ (define-key gnus-server-mode-map "c" 'gnus-server-copy-server)
+ (define-key gnus-server-mode-map "a" 'gnus-server-add-server)
+ (define-key gnus-server-mode-map "e" 'gnus-server-edit-server))
+
+(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)
+ (if gnus-visual (gnus-server-make-menu-bar))
+ (kill-all-local-variables)
+ (setq mode-line-modified "-- ")
+ (make-local-variable 'mode-line-format)
+ (setq mode-line-format (copy-sequence mode-line-format))
+ (and (equal (nth 3 mode-line-format) " ")
+ (setcar (nthcdr 3 mode-line-format) ""))
+ (setq major-mode 'gnus-server-mode)
+ (setq mode-name "Server")
+ ; (gnus-group-set-mode-line)
+ (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 (sformat name method)
+ (let* ((sformat (or sformat gnus-server-line-format-spec))
+ (how (car method))
+ (where (nth 1 method))
+ b)
+ (beginning-of-line)
+ (setq b (point))
+ ;; Insert the text.
+ (insert (eval sformat))
+ (add-text-properties b (1+ b) (list 'gnus-server (intern name)))))
+
+(defun gnus-server-setup-buffer ()
+ (if (get-buffer gnus-server-buffer)
+ ()
+ (save-excursion
+ (set-buffer (get-buffer-create gnus-server-buffer))
+ (gnus-server-mode)
+ (and 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))
+ (let ((alist gnus-server-alist)
+ (buffer-read-only nil))
+ (erase-buffer)
+ (while alist
+ (gnus-server-insert-server-line nil (car (car alist)) (cdr (car alist)))
+ (setq alist (cdr alist))))
+ (goto-char (point-min))
+ (gnus-server-position-cursor))
+
+(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-cursor '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)
+ (info (cdr (assoc server gnus-server-alist))))
+ (gnus-dribble-enter
+ (concat "(gnus-server-set-info \"" server "\" '"
+ (prin1-to-string info) ")"))
+ ;; Buffer may be narrowed.
+ (save-restriction
+ (widen)
+ (if (gnus-server-goto-server server)
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
+ (let ((entry (assoc server gnus-server-alist)))
+ (gnus-server-insert-server-line nil (car entry) (cdr entry))
+ (gnus-server-position-cursor))))))
+
+(defun gnus-server-set-info (server info)
+ ;; Enter a select method into the virtual server alist.
+ (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)))))))
+
+(defun gnus-server-to-method (server)
+ ;; Map virtual server names to select methods.
+ (or (and (equal server "native") gnus-select-method)
+ (cdr (assoc server gnus-server-alist))))
+
+(defun gnus-server-extend-method (group method)
+ ;; This function "extends" a virtual server. If the server is
+ ;; "hello", and the select method is ("hello" (my-var "something"))
+ ;; in the group "alt.alt", this will result in a new virtual server
+ ;; called "helly+alt.alt".
+ (let ((entry
+ (gnus-copy-sequence
+ (if (equal (car method) "native") gnus-select-method
+ (cdr (assoc (car method) gnus-server-alist))))))
+ (setcar (cdr entry) (concat (nth 1 entry) "+" group))
+ (nconc entry (cdr method))))
+
+(defun gnus-server-get-method (group method)
+ ;; Input either a server name, and extended server name, or a
+ ;; select method, and return a select method.
+ (cond ((stringp method)
+ (gnus-server-to-method method))
+ ((and (stringp (car method)) group)
+ (gnus-server-extend-method group method))
+ (t
+ (gnus-server-add-address method))))
+
+(defun gnus-server-add-address (method)
+ (let ((method-name (symbol-name (car method))))
+ (if (and (memq 'address (assoc method-name gnus-valid-select-methods))
+ (not (assq (intern (concat method-name "-address")) method)))
+ (append method (list (list (intern (concat method-name "-address"))
+ (nth 1 method))))
+ method)))
+
+(defun gnus-server-equal (s1 s2)
+ (or (equal s1 s2)
+ (and (= (length s1) (length s2))
+ (progn
+ (while (and s1 (member (car s1) s2))
+ (setq s1 (cdr s1)))
+ (null s1)))))
+
+;;; Interactive server functions.
+
+(defun gnus-server-kill-server (server)
+ "Kill the server on the current line."
+ (interactive (list (gnus-server-server-name)))
+ (or (gnus-server-goto-server server)
+ (if server (error "No such server: %s" server)
+ (error "No server on the current line")))
+ (gnus-dribble-enter "")
+ (let ((buffer-read-only nil))
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point))))
+ (setq gnus-server-killed-servers
+ (cons (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-cursor))
+
+(defun gnus-server-yank-server ()
+ "Yank the previously killed server."
+ (interactive)
+ (or 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 (car (car gnus-server-alist)))
+ (setq gnus-server-alist (cons killed gnus-server-alist))
+ (while (and (cdr alist)
+ (not (string= server (car (car (cdr alist))))))
+ (setq alist (cdr alist)))
+ (setcdr alist (cons killed (cdr alist)))))
+ (gnus-server-update-server (car killed))
+ (setq gnus-server-killed-servers (cdr gnus-server-killed-servers))
+ (gnus-server-position-cursor)))
+
+(defun gnus-server-exit ()
+ "Return to the group buffer."
+ (interactive)
+ (kill-buffer (current-buffer))
+ (switch-to-buffer gnus-group-buffer))
+
+(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-cursor)))
+
+(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: ")))
+ (or from (error "No server on current line"))
+ (or (and to (not (string= to ""))) (error "No name to copy to"))
+ (and (assoc to gnus-server-alist) (error "%s already exists" to))
+ (or (assoc from gnus-server-alist)
+ (error "%s: no such server" from))
+ (let ((to-entry (gnus-copy-sequence (assoc from gnus-server-alist))))
+ (setcar to-entry to)
+ (setcar (nthcdr 2 to-entry) to)
+ (setq gnus-server-killed-servers
+ (cons 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: ")))
+ (setq gnus-server-killed-servers
+ (cons (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))))
+ (and to
+ (progn
+ (goto-char to)
+ (gnus-server-position-cursor)))))
+
+(defun gnus-server-edit-server (server)
+ "Edit the server on the current line."
+ (interactive (list (gnus-server-server-name)))
+ (or server
+ (error "No server on current line"))
+ (let ((winconf (current-window-configuration)))
+ (get-buffer-create gnus-server-edit-buffer)
+ (gnus-configure-windows 'edit-server)
+ (gnus-add-current-to-buffer-list)
+ (emacs-lisp-mode)
+ (make-local-variable 'gnus-prev-winconf)
+ (setq gnus-prev-winconf winconf)
+ (use-local-map (copy-keymap (current-local-map)))
+ (let ((done-func '(lambda ()
+ "Exit editing mode and update the information."
+ (interactive)
+ (gnus-server-edit-server-done 'group))))
+ (setcar (cdr (nth 4 done-func)) server)
+ (local-set-key "\C-c\C-c" done-func))
+ (erase-buffer)
+ (insert ";; Type `C-c C-c' after you have edited the server.\n\n")
+ (insert (pp-to-string (cdr (assoc server gnus-server-alist))))))
+
+(defun gnus-server-edit-server-done (server)
+ (interactive)
+ (set-buffer (get-buffer-create gnus-server-edit-buffer))
+ (goto-char (point-min))
+ (let ((form (read (current-buffer)))
+ (winconf gnus-prev-winconf))
+ (gnus-server-set-info server form)
+ (kill-buffer (current-buffer))
+ (and winconf (set-window-configuration winconf))
+ (set-buffer gnus-server-buffer)
+ (gnus-server-update-server (gnus-server-server-name))
+ (gnus-server-list-servers)
+ (gnus-server-position-cursor)))
+
+(defun gnus-server-read-server (server)
+ "Browse a server."
+ (interactive (list (gnus-server-server-name)))
+ (gnus-browse-foreign-server (gnus-server-to-method server) (current-buffer)))
+
+(defun gnus-mouse-pick-server (e)
+ (interactive "e")
+ (mouse-set-point e)
+ (gnus-server-read-server (gnus-server-server-name)))
+
+;;;
+;;; entry points into gnus-score.el
+;;;
+
+;;; Finding score files.
+
+(defvar gnus-global-score-files nil
+ "*List of global score files and directories.
+Set this variable if you want to use people's score files. One entry
+for each score file or each score file directory. Gnus will decide
+by itself what score files are applicable to which group.
+
+Say you want to use the single score file
+\"/ftp.ifi.uio.no@ftp:/pub/larsi/ding/score/soc.motss.SCORE\" and all
+score files in the \"/ftp.some-where:/pub/score\" directory.
+
+ (setq gnus-global-score-files
+ '(\"/ftp.ifi.uio.no:/pub/larsi/ding/score/soc.motss.SCORE\"
+ \"/ftp.some-where:/pub/score\"))")
+
+(defun gnus-score-score-files (group)
+ "Return a list of all possible score files."
+ ;; Search and set any global score files.
+ (and gnus-global-score-files
+ (or gnus-internal-global-score-files
+ (gnus-score-search-global-directories gnus-global-score-files)))
+ ;; Fix the kill-file dir variable.
+ (setq gnus-kill-files-directory
+ (file-name-as-directory
+ (or gnus-kill-files-directory "~/News/")))
+ ;; If we can't read it, there are no score files.
+ (if (not (file-exists-p (expand-file-name gnus-kill-files-directory)))
+ (setq gnus-score-file-list nil)
+ (if (gnus-use-long-file-name 'not-score)
+ ;; We want long file names.
+ (if (or (not gnus-score-file-list)
+ (not (car gnus-score-file-list))
+ (gnus-file-newer-than gnus-kill-files-directory
+ (car gnus-score-file-list)))
+ (setq gnus-score-file-list
+ (cons (nth 5 (file-attributes gnus-kill-files-directory))
+ (nreverse
+ (directory-files
+ gnus-kill-files-directory t
+ (gnus-score-file-regexp))))))
+ ;; We do not use long file names, so we have to do some
+ ;; directory traversing.
+ (let ((mdir (length (expand-file-name gnus-kill-files-directory)))
+ (suffixes (list gnus-score-file-suffix gnus-adaptive-file-suffix))
+ dir files suffix)
+ (while suffixes
+ (setq dir (expand-file-name
+ (concat gnus-kill-files-directory
+ (gnus-replace-chars-in-string group ?. ?/))))
+ (setq dir (gnus-replace-chars-in-string dir ?: ?/))
+ (setq suffix (car suffixes)
+ suffixes (cdr suffixes))
+ (if (file-exists-p (concat dir "/" suffix))
+ (setq files (cons (concat dir "/" suffix) files)))
+ (while (>= (1+ (length dir)) mdir)
+ (and (file-exists-p (concat dir "/all/" suffix))
+ (setq files (cons (concat dir "/all/" suffix) files)))
+ (string-match "/[^/]*$" dir)
+ (setq dir (substring dir 0 (match-beginning 0)))))
+ (setq gnus-score-file-list
+ (cons nil (nreverse files)))))
+ (cdr gnus-score-file-list)))
+
+(defun gnus-score-file-regexp ()
+ (concat "\\(" gnus-score-file-suffix
+ "\\|" gnus-adaptive-file-suffix "\\)$"))
+
+(defun gnus-score-find-bnews (group)
+ "Return a list of score files for GROUP.
+The score files are those files in the ~/News directory which matches
+GROUP using BNews sys file syntax."
+ (let* ((sfiles (append (gnus-score-score-files group)
+ gnus-internal-global-score-files))
+ (kill-dir (file-name-as-directory
+ (expand-file-name gnus-kill-files-directory)))
+ (klen (length kill-dir))
+ ofiles not-match regexp)
+ (save-excursion
+ (set-buffer (get-buffer-create "*gnus score files*"))
+ (buffer-disable-undo (current-buffer))
+ ;; Go through all score file names and create regexp with them
+ ;; as the source.
+ (while sfiles
+ (erase-buffer)
+ (insert (car sfiles))
+ (goto-char (point-min))
+ ;; First remove the suffix itself.
+ (re-search-forward (concat "." (gnus-score-file-regexp)))
+ (replace-match "" t t)
+ (goto-char (point-min))
+ (if (looking-at (regexp-quote kill-dir))
+ ;; If the file name was just "SCORE", `klen' is one character
+ ;; too much.
+ (delete-char (min (1- (point-max)) klen))
+ (goto-char (point-max))
+ (search-backward "/")
+ (delete-region (1+ (point)) (point-min)))
+ ;; If short file names were used, we have to translate slashes.
+ (goto-char (point-min))
+ (while (re-search-forward "[/:]" nil t)
+ (replace-match "." t t))
+ ;; Cludge to get rid of "nntp+" problems.
+ (goto-char (point-min))
+ (and (looking-at "nn[a-z]+\\+")
+ (progn
+ (search-forward "+")
+ (forward-char -1)
+ (insert "\\")))
+ ;; Translate ".all" to "[./].*";
+ (while (search-forward ".all" nil t)
+ (replace-match "[./:].*" t t))
+ (goto-char (point-min))
+ ;; Translate "all" to ".*".
+ (while (search-forward "all" nil t)
+ (replace-match ".*" t t))
+ (goto-char (point-min))
+ ;; Deal with "not."s.
+ (if (looking-at "not.")
+ (progn
+ (setq not-match t)
+ (setq regexp (buffer-substring 5 (point-max))))
+ (setq regexp (buffer-substring 1 (point-max)))
+ (setq not-match nil))
+ ;; Finally - if this resulting regexp matches the group name,
+ ;; we add this score file to the list of score files
+ ;; applicable to this group.
+ (if (or (and not-match
+ (not (string-match regexp group)))
+ (and (not not-match)
+ (string-match regexp group)))
+ (setq ofiles (cons (car sfiles) ofiles)))
+ (setq sfiles (cdr sfiles)))
+ (kill-buffer (current-buffer))
+ ;; Slight kludge here - the last score file returned should be
+ ;; the local score file, whether it exists or not. This is so
+ ;; that any score commands the user enters will go to the right
+ ;; file, and not end up in some global score file.
+ (let ((localscore
+ (expand-file-name
+ (if (gnus-use-long-file-name 'not-score)
+ (concat gnus-kill-files-directory group "."
+ gnus-score-file-suffix)
+ (concat gnus-kill-files-directory
+ (gnus-replace-chars-in-string group ?. ?/ ?: ?/)
+ "/" gnus-score-file-suffix)))))
+ ;; The localest score file might already be there, but it's
+ ;; supposed to be the very last file, so we delete it from the
+ ;; list if it's already there, and add it to the head of the
+ ;; list.
+ (setq ofiles (cons localscore (delete localscore ofiles))))
+ (nreverse ofiles))))
+
+(defun gnus-score-find-single (group)
+ "Return list containing the score file for GROUP."
+ (list (gnus-score-file-name group gnus-adaptive-file-suffix)
+ (gnus-score-file-name group)))
+
+(defun gnus-score-find-hierarchical (group)
+ "Return list of score files for GROUP.
+This includes the score file for the group and all its parents."
+ (let ((all (copy-sequence '(nil)))
+ (start 0))
+ (while (string-match "\\." group (1+ start))
+ (setq start (match-beginning 0))
+ (setq all (cons (substring group 0 start) all)))
+ (setq all (cons group all))
+ (nconc
+ (mapcar (lambda (newsgroup)
+ (gnus-score-file-name newsgroup gnus-adaptive-file-suffix))
+ (setq all (nreverse all)))
+ (mapcar 'gnus-score-file-name all))))
+
+(defvar gnus-score-file-alist-cache nil)
+
+(defun gnus-score-find-alist (group)
+ "Return list of score files for GROUP.
+The list is determined from the variable gnus-score-file-alist."
+ (let ((alist gnus-score-file-multiple-match-alist)
+ score-files)
+ ;; if this group has been seen before, return the cached entry
+ (if (setq score-files (assoc group gnus-score-file-alist-cache))
+ (cdr score-files) ;ensures caching groups with no matches
+ ;; handle the multiple match alist
+ (while alist
+ (and (string-match (car (car alist)) group)
+ (setq score-files
+ (nconc score-files (copy-sequence (cdr (car alist))))))
+ (setq alist (cdr alist)))
+ (setq alist gnus-score-file-single-match-alist)
+ ;; handle the single match alist
+ (while alist
+ (and (string-match (car (car alist)) group)
+ ;; progn used just in case ("regexp") has no files
+ ;; and score-files is still nil. -sj
+ ;; this can be construed as a "stop searching here" feature :>
+ ;; and used to simplify regexps in the single-alist
+ (progn
+ (setq score-files
+ (nconc score-files (copy-sequence (cdr (car alist)))))
+ (setq alist nil)))
+ (setq alist (cdr alist)))
+ ;; cache the score files
+ (setq gnus-score-file-alist-cache
+ (cons (cons group score-files) gnus-score-file-alist-cache))
+ score-files)))
+
+
+(defun gnus-possibly-score-headers (&optional trace)
+ (let ((func gnus-score-find-score-files-function)
+ score-files)
+ (and func (not (listp func))
+ (setq func (list func)))
+ ;; Go through all the functions for finding score files (or actual
+ ;; scores) and add them to a list.
+ (setq score-files (gnus-score-find-alist gnus-newsgroup-name))
+ (while func
+ (and (symbolp (car func))
+ (fboundp (car func))
+ (setq score-files
+ (nconc score-files (funcall (car func) gnus-newsgroup-name))))
+ (setq func (cdr func)))
+ (if score-files (gnus-score-headers score-files trace))))
+
+(defun gnus-score-file-name (newsgroup &optional suffix)
+ "Return the name of a score file for NEWSGROUP."
+ (let ((suffix (or suffix gnus-score-file-suffix)))
+ (cond
+ ((or (null newsgroup)
+ (string-equal newsgroup ""))
+ ;; The global score file is placed at top of the directory.
+ (expand-file-name
+ suffix (or gnus-kill-files-directory "~/News")))
+ ((gnus-use-long-file-name 'not-score)
+ ;; Append ".SCORE" to newsgroup name.
+ (expand-file-name (concat (gnus-newsgroup-saveable-name newsgroup)
+ "." suffix)
+ (or gnus-kill-files-directory "~/News")))
+ (t
+ ;; Place "SCORE" under the hierarchical directory.
+ (expand-file-name (concat (gnus-newsgroup-directory-form newsgroup)
+ "/" suffix)
+ (or gnus-kill-files-directory "~/News"))))))
+
+(defun gnus-score-search-global-directories (files)
+ "Scan all global score directories for score files."
+ ;; Set the variable `gnus-internal-global-score-files' to all
+ ;; available global score files.
+ (interactive (list gnus-global-score-files))
+ (let (out)
+ (while files
+ (if (string-match "/$" (car files))
+ (setq out (nconc (directory-files
+ (car files) t
+ (concat (gnus-score-file-regexp) "$"))))
+ (setq out (cons (car files) out)))
+ (setq files (cdr files)))
+ (setq gnus-internal-global-score-files out)))
+
+;; Allow redefinition of Gnus functions.
+
+(gnus-ems-redefine)
+
+(provide 'gnus)
+
+;;; gnus.el ends here
diff --git a/lisp/nnbabyl.el b/lisp/nnbabyl.el
new file mode 100644
index 00000000000..111c0d479cd
--- /dev/null
+++ b/lisp/nnbabyl.el
@@ -0,0 +1,578 @@
+;;; nnbabyl.el --- rmail mbox access for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For an overview of what the interface functions do, please see the
+;; Gnus sources.
+
+;;; Code:
+
+(require 'nnheader)
+(require 'rmail)
+(require 'nnmail)
+
+(defvar nnbabyl-mbox-file (expand-file-name "~/RMAIL")
+ "The name of the rmail box file in the users home directory.")
+
+(defvar nnbabyl-active-file (expand-file-name "~/.rmail-active")
+ "The name of the active file for the rmail box.")
+
+(defvar nnbabyl-get-new-mail t
+ "If non-nil, nnbabyl will check the incoming mail file and split the mail.")
+
+(defvar 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.")
+
+(defvar nnbabyl-mbox-buffer nil)
+(defvar nnbabyl-current-group nil)
+(defvar nnbabyl-status-string "")
+(defvar nnbabyl-group-alist nil)
+(defvar nnbabyl-active-timestamp nil)
+
+
+
+(defvar nnbabyl-current-server nil)
+(defvar nnbabyl-server-alist nil)
+(defvar nnbabyl-server-variables
+ (list
+ (list 'nnbabyl-mbox-file nnbabyl-mbox-file)
+ (list 'nnbabyl-active-file nnbabyl-active-file)
+ (list 'nnbabyl-get-new-mail nnbabyl-get-new-mail)
+ '(nnbabyl-current-group nil)
+ '(nnbabyl-status-string "")
+ '(nnbabyl-group-alist nil)))
+
+
+
+;;; Interface functions
+
+(defun nnbabyl-retrieve-headers (sequence &optional newsgroup server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let ((number (length sequence))
+ (count 0)
+ article art-string start stop)
+ (nnbabyl-possibly-change-newsgroup newsgroup)
+ (if (stringp (car sequence))
+ 'headers
+ (while sequence
+ (setq article (car sequence))
+ (setq art-string (nnbabyl-article-string article))
+ (set-buffer nnbabyl-mbox-buffer)
+ (if (or (search-forward art-string nil t)
+ (search-backward art-string nil t))
+ (progn
+ (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
+ (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 " (int-to-string article) " Article retrieved.\n")
+ (insert-buffer-substring nnbabyl-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))
+ gnus-verbose-backends
+ (message "nnbabyl: Receiving headers... %d%%"
+ (/ (* count 100) number))))
+
+ (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)
+ gnus-verbose-backends
+ (message "nnbabyl: Receiving headers...done"))
+
+ ;; Fold continuation lines.
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ 'headers))))
+
+(defun nnbabyl-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (equal server nnbabyl-current-server)
+ t
+ (if nnbabyl-current-server
+ (setq nnbabyl-server-alist
+ (cons (list nnbabyl-current-server
+ (nnheader-save-variables nnbabyl-server-variables))
+ nnbabyl-server-alist)))
+ (let ((state (assoc server nnbabyl-server-alist)))
+ (if state
+ (progn
+ (nnheader-restore-variables (nth 1 state))
+ (setq nnbabyl-server-alist (delq state nnbabyl-server-alist)))
+ (nnheader-set-init-variables nnbabyl-server-variables defs)))
+ (setq nnbabyl-current-server server)))
+
+(defun nnbabyl-close-server (&optional server)
+ t)
+
+(defun nnbabyl-server-opened (&optional server)
+ (and (equal server nnbabyl-current-server)
+ nnbabyl-mbox-buffer
+ (buffer-name nnbabyl-mbox-buffer)
+ nntp-server-buffer
+ (buffer-name nntp-server-buffer)))
+
+(defun nnbabyl-status-message (&optional server)
+ nnbabyl-status-string)
+
+(defun nnbabyl-request-article (article &optional newsgroup server buffer)
+ (nnbabyl-possibly-change-newsgroup newsgroup)
+ (if (stringp article)
+ nil
+ (save-excursion
+ (set-buffer nnbabyl-mbox-buffer)
+ (goto-char (point-min))
+ (if (search-forward (nnbabyl-article-string article) nil t)
+ (let (start stop summary-line)
+ (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
+ (while (and (not (looking-at ".+:"))
+ (zerop (forward-line 1))))
+ (setq start (point))
+ (or (and (re-search-forward
+ (concat "^" nnbabyl-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 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:"))
+ (if (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)))))
+ t))))))
+
+(defun nnbabyl-request-group (group &optional server dont-check)
+ (save-excursion
+ (if (nnbabyl-possibly-change-newsgroup group)
+ (if dont-check
+ t
+ (nnbabyl-get-new-mail group)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let ((active (assoc group nnbabyl-group-alist)))
+ (insert (format "211 %d %d %d %s\n"
+ (1+ (- (cdr (car (cdr active)))
+ (car (car (cdr active)))))
+ (car (car (cdr active)))
+ (cdr (car (cdr active)))
+ (car active))))
+ t)))))
+
+(defun nnbabyl-close-group (group &optional server)
+ t)
+
+(defun nnbabyl-request-create-group (group &optional server)
+ (nnmail-activate 'nnbabyl)
+ (or (assoc group nnbabyl-group-alist)
+ (let (active)
+ (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 0)))
+ nnbabyl-group-alist))
+ (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))
+ t)
+
+(defun nnbabyl-request-list (&optional server)
+ (if server (nnbabyl-get-new-mail))
+ (save-excursion
+ (or (nnmail-find-file nnbabyl-active-file)
+ (progn
+ (setq nnbabyl-group-alist (nnmail-get-active))
+ (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
+ (nnmail-find-file nnbabyl-active-file)))))
+
+(defun nnbabyl-request-newgroups (date &optional server)
+ (nnbabyl-request-list server))
+
+(defun nnbabyl-request-list-newsgroups (&optional server)
+ (setq nnbabyl-status-string "nnbabyl: LIST NEWSGROUPS is not implemented.")
+ nil)
+
+(defun nnbabyl-request-post (&optional server)
+ (mail-send-and-exit nil))
+
+(defalias 'nnbabyl-request-post-buffer 'nnmail-request-post-buffer)
+
+(defun nnbabyl-request-expire-articles
+ (articles newsgroup &optional server force)
+ (nnbabyl-possibly-change-newsgroup newsgroup)
+ (let* ((days (or (and nnmail-expiry-wait-function
+ (funcall nnmail-expiry-wait-function newsgroup))
+ nnmail-expiry-wait))
+ (is-old t)
+ rest)
+ (nnmail-activate 'nnbabyl)
+
+ (save-excursion
+ (set-buffer nnbabyl-mbox-buffer)
+ (set-text-properties (point-min) (point-max) nil)
+ (while (and articles is-old)
+ (goto-char (point-min))
+ (if (search-forward (nnbabyl-article-string (car articles)) nil t)
+ (if (or force
+ (setq is-old
+ (> (nnmail-days-between
+ (current-time-string)
+ (buffer-substring
+ (point) (progn (end-of-line) (point))))
+ days)))
+ (progn
+ (and gnus-verbose-backends
+ (message "Deleting article %s..." (car articles)))
+ (nnbabyl-delete-mail))
+ (setq rest (cons (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))))
+
+(defun nnbabyl-request-move-article
+ (article group server accept-form &optional last)
+ (nnbabyl-possibly-change-newsgroup group)
+ (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))
+ (if (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
+ (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))
+
+(defun nnbabyl-request-accept-article (group &optional last)
+ (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)))))
+ (let ((nnmail-split-methods
+ (if (stringp group) (list (list group ""))
+ nnmail-split-methods)))
+ (setq result (car (nnbabyl-save-mail))))
+ (set-buffer nnbabyl-mbox-buffer)
+ (goto-char (point-max))
+ (search-backward "\n\^_")
+ (goto-char (match-end 0))
+ (insert-buffer buf)
+ (and last (progn
+ (save-buffer)
+ (nnmail-save-active
+ nnbabyl-group-alist nnbabyl-active-file)))
+ result))))
+
+(defun 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)))
+
+
+;;; Low-Level Interface
+
+;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
+;; headers there are. If LEAVE-DELIM, don't delete the Unix mbox
+;; delimeter line.
+(defun nnbabyl-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
+ (widen)
+ (narrow-to-region
+ (save-excursion
+ (re-search-backward (concat "^" nnbabyl-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 "^" nnbabyl-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.
+ (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
+ (delete-region (point-min) (point-max))))))
+
+(defun nnbabyl-possibly-change-newsgroup (newsgroup)
+ (if (or (not nnbabyl-mbox-buffer)
+ (not (buffer-name nnbabyl-mbox-buffer)))
+ (save-excursion (nnbabyl-read-mbox)))
+ (or nnbabyl-group-alist
+ (nnmail-activate 'nnbabyl))
+ (if newsgroup
+ (if (assoc newsgroup nnbabyl-group-alist)
+ (setq nnbabyl-current-group newsgroup)
+ (setq nnbabyl-status-string "No such group in file")
+ nil)))
+
+(defun nnbabyl-article-string (article)
+ (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
+ (int-to-string article) " "))
+
+(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))
+ (if (search-forward "\n\n" nil t)
+ (progn
+ ;; There may be an EOOH line here...
+ (if (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
+ (search-forward "\n\n" nil t))
+ (setq chars (- (point-max) (point)))
+ (setq lines (- (count-lines (point) (point-max)) 1))
+ ;; Move back to the end of the headers.
+ (goto-char (point-min))
+ (search-forward "\n\n" nil t)
+ (forward-char -1)
+ (save-excursion
+ (if (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 ()
+ ;; Called narrowed to an article.
+ (let ((group-art (nreverse (nnmail-article-group 'nnbabyl-active-number))))
+ (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))
+ (or (looking-at "\^L")
+ (save-excursion
+ (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
+ (goto-char (point-max))
+ (insert "\^_\n")))
+ (if (search-forward "\n\n" nil t)
+ (progn
+ (forward-char -1)
+ (while group-art
+ (insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
+ (car (car group-art)) (cdr (car 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 (car (cdr (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...
+ (setq nnbabyl-group-alist (cons (list group (setq active (cons 1 1)))
+ nnbabyl-group-alist)))
+ (cdr active)))
+
+(defun nnbabyl-read-mbox ()
+ (nnmail-activate 'nnbabyl)
+ (or (file-exists-p nnbabyl-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\^_")
+ (write-region (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))
+
+ (if (and nnbabyl-mbox-buffer
+ (buffer-name nnbabyl-mbox-buffer)
+ (save-excursion
+ (set-buffer nnbabyl-mbox-buffer)
+ (= (buffer-size) (nth 7 (file-attributes nnbabyl-mbox-file)))))
+ ()
+ (save-excursion
+ (let ((delim (concat "^" nnbabyl-mail-delimiter))
+ start end)
+ (set-buffer (setq nnbabyl-mbox-buffer
+ (nnheader-find-file-noselect
+ nnbabyl-mbox-file nil 'raw)))
+ (buffer-disable-undo (current-buffer))
+ (widen)
+ (setq buffer-read-only nil)
+ (fundamental-mode)
+
+ (goto-char (point-min))
+ (re-search-forward delim nil t)
+ (setq start (match-end 0))
+ (while (re-search-forward delim nil t)
+ (setq end (match-end 0))
+ (or (search-backward "\nX-Gnus-Newsgroup: " start t)
+ (progn
+ (goto-char end)
+ (save-excursion
+ (save-restriction
+ (goto-char start)
+ (narrow-to-region start end)
+ (nnbabyl-save-mail)
+ (setq end (point-max))))))
+ (goto-char (setq start end)))
+ (and (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-get-new-mail (&optional group)
+ "Read new incoming mail."
+ (let* ((spools (nnmail-get-spool-files group))
+ (group-in group)
+ incoming incomings)
+ (nnbabyl-read-mbox)
+ (if (or (not nnbabyl-get-new-mail) (not nnmail-spool-file))
+ ()
+ ;; We go through all the existing spool files and split the
+ ;; mail from each.
+ (while spools
+ (and
+ (file-exists-p (car spools))
+ (> (nth 7 (file-attributes (car spools))) 0)
+ (progn
+ (and gnus-verbose-backends
+ (message "nnbabyl: Reading incoming mail..."))
+ (if (not (setq incoming
+ (nnmail-move-inbox
+ (car spools)
+ (concat nnbabyl-mbox-file "-Incoming"))))
+ ()
+ (setq incomings (cons incoming incomings))
+ (save-excursion
+ (setq group (nnmail-get-split-group (car spools) group-in))
+ (let* ((nnmail-prepare-incoming-hook
+ (cons 'nnbabyl-remove-incoming-delims
+ nnmail-prepare-incoming-hook))
+ in-buf)
+ (setq in-buf (nnmail-split-incoming
+ incoming 'nnbabyl-save-mail t group))
+ (set-buffer in-buf)
+ (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)
+ (kill-buffer in-buf))))))
+ (setq spools (cdr spools)))
+ ;; If we did indeed read any incoming spools, we save all info.
+ (and (buffer-modified-p nnbabyl-mbox-buffer)
+ (save-excursion
+ (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
+ (set-buffer nnbabyl-mbox-buffer)
+ (save-buffer)))
+ (if incomings (run-hooks 'nnmail-read-incoming-hook))
+ (while incomings
+ (setq incoming (car incomings))
+ (and nnmail-delete-incoming
+ (file-exists-p incoming)
+ (file-writable-p incoming)
+ (delete-file incoming))
+ (setq incomings (cdr incomings))))))
+
+(provide 'nnbabyl)
+
+;;; nnbabyl.el ends here
diff --git a/lisp/nndir.el b/lisp/nndir.el
new file mode 100644
index 00000000000..4e6ffb82eff
--- /dev/null
+++ b/lisp/nndir.el
@@ -0,0 +1,141 @@
+;;; nndir.el --- single directory newsgroup access for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nnmh)
+(require 'nnml)
+
+(eval-and-compile
+ (autoload 'mail-send-and-exit "sendmail"))
+
+
+
+(defconst nndir-version "nndir 1.0")
+
+(defvar nndir-current-directory nil
+ "Current news group directory.")
+
+(defvar nndir-status-string "")
+
+(defvar nndir-nov-is-evil nil
+ "*Non-nil means that nndir will never retrieve NOV headers.")
+
+
+
+;;; Interface functions.
+
+
+(defun nndir-retrieve-headers (sequence &optional newsgroup server)
+ (nndir-execute-nnml-command
+ '(nnml-retrieve-headers sequence group server) server))
+
+(defun nndir-open-server (host &optional service)
+ "Open nndir backend."
+ (setq nndir-status-string "")
+ (nnheader-init-server-buffer))
+
+(defun nndir-close-server (&optional server)
+ "Close news server."
+ t)
+
+(defun nndir-server-opened (&optional server)
+ "Return server process status, T or NIL.
+If the stream is opened, return T, otherwise return NIL."
+ (and nntp-server-buffer
+ (get-buffer nntp-server-buffer)))
+
+(defun nndir-status-message (&optional server)
+ "Return server status response as string."
+ nndir-status-string)
+
+(defun nndir-request-article (id &optional newsgroup server buffer)
+ (nndir-execute-nnmh-command
+ '(nnmh-request-article id group server buffer) server))
+
+(defun nndir-request-group (group &optional server dont-check)
+ "Select news GROUP."
+ (nndir-execute-nnmh-command
+ '(nnmh-request-group group "" dont-check) server))
+
+(defun nndir-request-list (&optional server dir)
+ "Get list of active articles in all newsgroups."
+ (nndir-execute-nnmh-command
+ '(nnmh-request-list nil dir) server))
+
+(defun nndir-request-newgroups (date &optional server)
+ (nndir-execute-nnmh-command
+ '(nnmh-request-newgroups date server) server))
+
+(defun nndir-request-post (&optional server)
+ "Post a new news in current buffer."
+ (mail-send-and-exit nil))
+
+(defalias 'nndir-request-post-buffer 'nnmail-request-post-buffer)
+
+(defun nndir-request-expire-articles (articles newsgroup &optional server force)
+ "Expire all articles in the ARTICLES list in group GROUP."
+ (setq nndir-status-string "nndir: expire not possible")
+ nil)
+
+(defun nndir-close-group (group &optional server)
+ t)
+
+(defun nndir-request-move-article (article group server accept-form)
+ (setq nndir-status-string "nndir: move not possible")
+ nil)
+
+(defun nndir-request-accept-article (group)
+ (setq nndir-status-string "nndir: accept not possible")
+ nil)
+
+
+;;; Low-Level Interface
+
+(defun nndir-execute-nnmh-command (command server)
+ (let ((dir (expand-file-name server)))
+ (and (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))))
+ (nnmh-get-new-mail nil))
+ (eval command))))
+
+(defun nndir-execute-nnml-command (command server)
+ (let ((dir (expand-file-name server)))
+ (and (string-match "/$" dir)
+ (setq dir (substring dir 0 (match-beginning 0))))
+ (string-match "/[^/]+$" dir)
+ (let ((group (substring dir (1+ (match-beginning 0))))
+ (nnml-directory (substring dir 0 (1+ (match-beginning 0))))
+ (nnml-nov-is-evil nndir-nov-is-evil)
+ (nnml-get-new-mail nil))
+ (eval command))))
+
+(provide 'nndir)
+
+;;; nndir.el ends here
diff --git a/lisp/nndoc.el b/lisp/nndoc.el
new file mode 100644
index 00000000000..a54269d9e9c
--- /dev/null
+++ b/lisp/nndoc.el
@@ -0,0 +1,400 @@
+;;; nndoc.el --- single file access for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'rmail)
+(require 'nnmail)
+
+(defvar nndoc-article-type 'mbox
+ "*Type of the file - one of `mbox', `babyl' or `digest'.")
+
+(defvar nndoc-digest-type 'traditional
+ "Type of the last digest. Auto-detected from the article header.
+Possible values:
+ `traditional' -- the \"lots of dashes\" (30+) rules used;
+ we currently also do unconditional RFC 934 unquoting.
+ `rfc1341' -- RFC 1341 digest (MIME, unique boundary, no quoting).")
+
+(defconst nndoc-type-to-regexp
+ (list (list 'mbox
+ (concat "^" rmail-unix-mail-delimiter)
+ (concat "^" rmail-unix-mail-delimiter)
+ nil "^$" nil nil nil)
+ (list 'babyl "\^_\^L *\n" "\^_" "^[0-9].*\n" "^$" nil nil
+ "\\*\\*\\* EOOH \\*\\*\\*\n\\(^.+\n\\)*")
+ (list 'digest
+ "^------------------------------*[\n \t]+"
+ "^------------------------------*[\n \t]+"
+ nil "^ ?$"
+ "^------------------------------*[\n \t]+"
+ "^End of" nil))
+ "Regular expressions for articles of the various types.")
+
+
+
+(defvar nndoc-article-begin nil)
+(defvar nndoc-article-end nil)
+(defvar nndoc-head-begin nil)
+(defvar nndoc-head-end nil)
+(defvar nndoc-first-article nil)
+(defvar nndoc-end-of-file nil)
+(defvar nndoc-body-begin nil)
+
+(defvar nndoc-current-server nil)
+(defvar nndoc-server-alist nil)
+(defvar nndoc-server-variables
+ (list
+ (list 'nndoc-article-type nndoc-article-type)
+ '(nndoc-article-begin nil)
+ '(nndoc-article-end nil)
+ '(nndoc-head-begin nil)
+ '(nndoc-head-end nil)
+ '(nndoc-first-article nil)
+ '(nndoc-current-buffer nil)
+ '(nndoc-group-alist nil)
+ '(nndoc-end-of-file nil)
+ '(nndoc-body-begin nil)
+ '(nndoc-address nil)))
+
+(defconst nndoc-version "nndoc 1.0"
+ "nndoc version.")
+
+(defvar nndoc-current-buffer nil
+ "Current nndoc news buffer.")
+
+(defvar nndoc-address nil)
+
+
+
+(defvar nndoc-status-string "")
+
+(defvar nndoc-group-alist nil)
+
+;;; Interface functions
+
+(defun nndoc-retrieve-headers (sequence &optional newsgroup server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let ((prev 2)
+ article p beg lines)
+ (nndoc-possibly-change-buffer newsgroup server)
+ (if (stringp (car sequence))
+ 'headers
+ (set-buffer nndoc-current-buffer)
+ (widen)
+ (goto-char (point-min))
+ (re-search-forward (or nndoc-first-article
+ nndoc-article-begin) nil t)
+ (or (not nndoc-head-begin)
+ (re-search-forward nndoc-head-begin nil t))
+ (re-search-forward nndoc-head-end nil t)
+ (while sequence
+ (setq article (car sequence))
+ (set-buffer nndoc-current-buffer)
+ (if (not (nndoc-forward-article (max 0 (- article prev))))
+ ()
+ (setq p (point))
+ (setq beg (or (and
+ (re-search-backward nndoc-article-begin nil t)
+ (match-end 0))
+ (point-min)))
+ (goto-char p)
+ (setq lines (count-lines
+ (point)
+ (or
+ (and (re-search-forward nndoc-article-end nil t)
+ (goto-char (match-beginning 0)))
+ (goto-char (point-max)))))
+
+ (set-buffer nntp-server-buffer)
+ (insert (format "221 %d Article retrieved.\n" article))
+ (insert-buffer-substring nndoc-current-buffer beg p)
+ (goto-char (point-max))
+ (or (= (char-after (1- (point))) ?\n) (insert "\n"))
+ (insert (format "Lines: %d\n" lines))
+ (insert ".\n"))
+
+ (setq prev article
+ sequence (cdr sequence)))
+
+ ;; Fold continuation lines.
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ 'headers))))
+
+(defun nndoc-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (equal server nndoc-current-server)
+ t
+ (if nndoc-current-server
+ (setq nndoc-server-alist
+ (cons (list nndoc-current-server
+ (nnheader-save-variables nndoc-server-variables))
+ nndoc-server-alist)))
+ (let ((state (assoc server nndoc-server-alist)))
+ (if state
+ (progn
+ (nnheader-restore-variables (nth 1 state))
+ (setq nndoc-server-alist (delq state nndoc-server-alist)))
+ (nnheader-set-init-variables nndoc-server-variables defs)))
+ (setq nndoc-current-server server)
+ (let ((defs (cdr (assq nndoc-article-type nndoc-type-to-regexp))))
+ (setq nndoc-article-begin (nth 0 defs))
+ (setq nndoc-article-end (nth 1 defs))
+ (setq nndoc-head-begin (nth 2 defs))
+ (setq nndoc-head-end (nth 3 defs))
+ (setq nndoc-first-article (nth 4 defs))
+ (setq nndoc-end-of-file (nth 5 defs))
+ (setq nndoc-body-begin (nth 6 defs)))
+ t))
+
+(defun nndoc-close-server (&optional server)
+ t)
+
+(defun nndoc-server-opened (&optional server)
+ (and (equal server nndoc-current-server)
+ nntp-server-buffer
+ (buffer-name nntp-server-buffer)))
+
+(defun nndoc-status-message (&optional server)
+ nndoc-status-string)
+
+(defun nndoc-request-article (article &optional newsgroup server buffer)
+ (nndoc-possibly-change-buffer newsgroup server)
+ (save-excursion
+ (let ((buffer (or buffer nntp-server-buffer)))
+ (set-buffer buffer)
+ (erase-buffer)
+ (if (stringp article)
+ nil
+ (nndoc-insert-article article)
+ ;; Unquote quoted non-separators in digests.
+ (if (and (eq nndoc-article-type 'digest)
+ (eq nndoc-digest-type 'traditional))
+ (progn
+ (goto-char (point-min))
+ (while (re-search-forward "^- -"nil t)
+ (replace-match "-" t t))))
+ ;; Some assholish digests do not have a blank line after the
+ ;; headers. Aargh!
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ () ; We let this one pass.
+ (if (re-search-forward "^[ \t]+$" nil t)
+ (replace-match "" t t) ; We nix out a line of blanks.
+ (while (and (looking-at "[^ ]+:")
+ (zerop (forward-line 1))))
+ ;; We just insert a couple of lines. If you read digests
+ ;; that are so badly formatted, you don't deserve any
+ ;; better. Blphphpht!
+ (insert "\n\n")))
+ t))))
+
+(defun nndoc-request-group (group &optional server dont-check)
+ "Select news GROUP."
+ (save-excursion
+ (if (not (nndoc-possibly-change-buffer group server))
+ (progn
+ (setq nndoc-status-string "No such file or buffer")
+ nil)
+ (nndoc-set-header-dependent-regexps) ; hack for MIME digests
+ (if dont-check
+ t
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let ((number (nndoc-number-of-articles)))
+ (if (zerop number)
+ (progn
+ (nndoc-close-group group)
+ nil)
+ (insert (format "211 %d %d %d %s\n" number 1 number group))
+ t)))))))
+
+(defun nndoc-close-group (group &optional server)
+ (nndoc-possibly-change-buffer group server)
+ (kill-buffer nndoc-current-buffer)
+ (setq nndoc-group-alist (delq (assoc group nndoc-group-alist)
+ nndoc-group-alist))
+ (setq nndoc-current-buffer nil)
+ (setq nndoc-current-server nil)
+ t)
+
+(defun nndoc-request-list (&optional server)
+ nil)
+
+(defun nndoc-request-newgroups (date &optional server)
+ nil)
+
+(defun nndoc-request-list-newsgroups (&optional server)
+ nil)
+
+(defalias 'nndoc-request-post 'nnmail-request-post)
+(defalias 'nndoc-request-post-buffer 'nnmail-request-post-buffer)
+
+
+;;; Internal functions.
+
+(defun nndoc-possibly-change-buffer (group source)
+ (let (buf)
+ (cond
+ ;; The current buffer is this group's buffer.
+ ((and 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))))
+ (setq nndoc-group-alist
+ (cons (cons group (setq nndoc-current-buffer
+ (get-buffer-create
+ (concat " *nndoc " group "*"))))
+ nndoc-group-alist))
+ (save-excursion
+ (set-buffer nndoc-current-buffer)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (if (stringp nndoc-address)
+ (insert-file-contents nndoc-address)
+ (save-excursion
+ (set-buffer nndoc-address)
+ (widen))
+ (insert-buffer-substring nndoc-address))
+ t)))))
+
+;; MIME (RFC 1341) digest hack by Ulrik Dickow <dickow@nbi.dk>.
+(defun nndoc-set-header-dependent-regexps ()
+ (if (not (eq nndoc-article-type 'digest))
+ ()
+ (let ((case-fold-search t) ; We match a bit too much, keep it simple.
+ (boundary-id) (b-delimiter))
+ (save-excursion
+ (set-buffer nndoc-current-buffer)
+ (goto-char (point-min))
+ (if (and
+ (re-search-forward
+ (concat "\n\n\\|^Content-Type: *multipart/digest;[ \t\n]*[ \t]"
+ "boundary=\"\\([^\"\n]*[^\" \t\n]\\)\"")
+ nil t)
+ (match-beginning 1))
+ (setq nndoc-digest-type 'rfc1341
+ boundary-id (format "%s"
+ (buffer-substring
+ (match-beginning 1) (match-end 1)))
+ b-delimiter (concat "\n--" boundary-id "[\n \t]+")
+ nndoc-article-begin b-delimiter ; Too strict: "[ \t]*$"
+ nndoc-article-end (concat "\n--" boundary-id
+ "\\(--\\)?[\n \t]+")
+ nndoc-first-article b-delimiter ; ^eof ends article too.
+ nndoc-end-of-file (concat "\n--" boundary-id "--[ \t]*$"))
+ (setq nndoc-digest-type 'traditional))))))
+
+(defun nndoc-forward-article (n)
+ (while (and (> n 0)
+ (re-search-forward nndoc-article-begin nil t)
+ (or (not nndoc-head-begin)
+ (re-search-forward nndoc-head-begin nil t))
+ (re-search-forward nndoc-head-end nil t))
+ (setq n (1- n)))
+ (zerop n))
+
+(defun nndoc-number-of-articles ()
+ (save-excursion
+ (set-buffer nndoc-current-buffer)
+ (widen)
+ (goto-char (point-min))
+ (let ((num 0))
+ (if (re-search-forward (or nndoc-first-article
+ nndoc-article-begin) nil t)
+ (progn
+ (setq num 1)
+ (while (and (re-search-forward nndoc-article-begin nil t)
+ (or (not nndoc-end-of-file)
+ (not (looking-at nndoc-end-of-file)))
+ (or (not nndoc-head-begin)
+ (re-search-forward nndoc-head-begin nil t))
+ (re-search-forward nndoc-head-end nil t))
+ (setq num (1+ num)))))
+ num)))
+
+(defun nndoc-narrow-to-article (article)
+ (save-excursion
+ (set-buffer nndoc-current-buffer)
+ (widen)
+ (goto-char (point-min))
+ (while (and (re-search-forward nndoc-article-begin nil t)
+ (not (zerop (setq article (1- article))))))
+ (if (not (zerop article))
+ ()
+ (narrow-to-region
+ (match-end 0)
+ (or (and (re-search-forward nndoc-article-end nil t)
+ (match-beginning 0))
+ (point-max)))
+ t)))
+
+;; Insert article ARTICLE in the current buffer.
+(defun nndoc-insert-article (article)
+ (let ((ibuf (current-buffer)))
+ (save-excursion
+ (set-buffer nndoc-current-buffer)
+ (widen)
+ (goto-char (point-min))
+ (while (and (re-search-forward nndoc-article-begin nil t)
+ (not (zerop (setq article (1- article))))))
+ (if (not (zerop article))
+ ()
+ (narrow-to-region
+ (match-end 0)
+ (or (and (re-search-forward nndoc-article-end nil t)
+ (match-beginning 0))
+ (point-max)))
+ (goto-char (point-min))
+ (and nndoc-head-begin
+ (re-search-forward nndoc-head-begin nil t)
+ (narrow-to-region (point) (point-max)))
+ (or (re-search-forward nndoc-head-end nil t)
+ (goto-char (point-max)))
+ (append-to-buffer ibuf (point-min) (point))
+ (and nndoc-body-begin
+ (re-search-forward nndoc-body-begin nil t))
+ (append-to-buffer ibuf (point) (point-max))
+ t))))
+
+(provide 'nndoc)
+
+;;; nndoc.el ends here
diff --git a/lisp/nneething.el b/lisp/nneething.el
new file mode 100644
index 00000000000..0980c4d13cf
--- /dev/null
+++ b/lisp/nneething.el
@@ -0,0 +1,334 @@
+;;; nneething.el --- random file access for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, 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)
+
+(defvar nneething-map-file-directory "~/.nneething/"
+ "*Map files directory.")
+
+(defvar nneething-exclude-files "~$"
+ "*Regexp saying what files to exclude from the group.")
+
+(defvar nneething-map-file ".nneething"
+ "*Name of map files.")
+
+
+
+(defconst nneething-version "nneething 1.0"
+ "nneething version.")
+
+(defvar nneething-current-directory nil
+ "Current news group directory.")
+
+(defvar nneething-status-string "")
+(defvar nneething-group-alist nil)
+
+
+
+(defvar nneething-directory nil)
+(defvar nneething-group nil)
+(defvar nneething-map nil)
+(defvar nneething-read-only nil)
+(defvar nneething-active nil)
+(defvar nneething-server-variables
+ (list
+ (list 'nneething-directory nneething-directory)
+ '(nneething-current-directory nil)
+ '(nneething-status-string "")
+ '(nneething-group-alist)))
+
+
+
+;;; Interface functions.
+
+(defun nneething-retrieve-headers (sequence &optional newsgroup server)
+ (nneething-possibly-change-directory newsgroup)
+
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let* ((number (length sequence))
+ (count 0)
+ (large (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)))
+ article file)
+
+ (if (stringp (car sequence))
+ 'headers
+
+ (while sequence
+ (setq article (car sequence))
+ (setq file (nneething-file-name article))
+
+ (if (and (file-exists-p file)
+ (not (zerop (nth 7 (file-attributes file)))))
+ (progn
+ (insert (format "221 %d Article retrieved.\n" article))
+ (nneething-insert-head file)
+ (insert ".\n")))
+
+ (setq sequence (cdr sequence)
+ count (1+ count))
+
+ (and large
+ (zerop (% count 20))
+ (message "nneething: Receiving headers... %d%%"
+ (/ (* count 100) number))))
+
+ (and large (message "nneething: Receiving headers...done"))
+
+ ;; Fold continuation lines.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ 'headers))))
+
+(defun nneething-open-server (server &optional defs)
+ (setq nneething-status-string "")
+ (nnheader-init-server-buffer))
+
+(defun nneething-close-server (&optional server)
+ t)
+
+(defun nneething-server-opened (&optional server)
+ t)
+
+(defun nneething-status-message (&optional server)
+ nneething-status-string)
+
+(defun nneething-request-article (id &optional newsgroup server buffer)
+ (nneething-possibly-change-directory newsgroup)
+ (let ((file (if (stringp id) nil (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.
+ (or (nnheader-article-p) ; Either it's a real article...
+ (progn
+ (goto-char (point-min))
+ (nneething-make-head file) ; ... or we fake some headers.
+ (insert "\n")))
+ t))))
+
+(defun nneething-request-group (group &optional dir dont-check)
+ (nneething-possibly-change-directory group dir)
+ (or dont-check (nneething-create-mapping))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (if (> (car nneething-active) (cdr nneething-active))
+ (insert (format "211 0 1 0 %s\n" group))
+ (insert (format "211 %d %d %d %s\n"
+ (- (1+ (cdr nneething-active)) (car nneething-active))
+ (car nneething-active) (cdr nneething-active)
+ group)))
+ t))
+
+(defun nneething-request-list (&optional server dir)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer))
+ nil)
+
+(defun nneething-request-newgroups (date &optional server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer))
+ nil)
+
+(defun nneething-request-post (&optional server)
+ (mail-send-and-exit nil))
+
+(defalias 'nneething-request-post-buffer 'nnmail-request-post-buffer)
+
+(defun nneething-close-group (group &optional server)
+ t)
+
+
+;;; Internal functions.
+
+(defun nneething-possibly-change-directory (group &optional dir)
+ (if (not group)
+ ()
+ (if (and nneething-group
+ (string= group nneething-group))
+ t
+ (let (entry)
+ (if (setq entry (assoc group nneething-group-alist))
+ (progn
+ (setq nneething-group group)
+ (setq nneething-directory (nth 1 entry))
+ (setq nneething-map (nth 2 entry))
+ (setq nneething-active (nth 3 entry)))
+ (setq nneething-group group)
+ (setq nneething-directory dir)
+ (setq nneething-map nil)
+ (setq nneething-active (cons 1 0))
+ (nneething-create-mapping)
+ (setq nneething-group-alist
+ (cons (list group dir nneething-map nneething-active)
+ nneething-group-alist)))))))
+
+(defun nneething-map-file ()
+ ;; We make sure that the .neething directory exists.
+ (make-directory nneething-map-file-directory 'parents)
+ ;; 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
+ (let ((map-file (nneething-map-file))
+ (files (directory-files nneething-directory))
+ touched)
+ (if (file-exists-p map-file)
+ (condition-case nil
+ (load map-file nil t t)
+ (error nil)))
+ (or nneething-active (setq nneething-active (cons 1 0)))
+ ;; Remove files matching that regexp.
+ (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 files that have disappeared from the map.
+ (let ((map nneething-map)
+ prev)
+ (while map
+ (if (member (car (car 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
+ (or (assoc (car files) nneething-map) ; If already in the map, ignore.
+ (progn
+ (setq touched t)
+ (setcdr nneething-active (1+ (cdr nneething-active)))
+ (setq nneething-map
+ (cons (cons (car files) (cdr nneething-active)) nneething-map))))
+ (setq files (cdr files)))
+ (if (or (not touched) nneething-read-only)
+ ()
+ (save-excursion
+ (set-buffer (get-buffer-create " *nneething map*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert "(setq nneething-map '" (prin1-to-string nneething-map) ")\n"
+ "(setq nneething-active '" (prin1-to-string nneething-active)
+ ")\n")
+ (write-region (point-min) (point-max) map-file nil 'nomesg)
+ (kill-buffer (current-buffer))))))
+
+(defvar nneething-message-id-number 0)
+(defvar nneething-work-buffer " *nneething work*")
+
+(defun nneething-insert-head (file)
+ (and (nneething-get-head file)
+ (insert-buffer-substring nneething-work-buffer)))
+
+(defun nneething-make-head (file)
+ (let ((atts (file-attributes file)))
+ (insert "Subject: " (file-name-nondirectory file) "\n"
+ "Message-ID: <nneething-"
+ (int-to-string
+ (setq nneething-message-id-number
+ (1+ nneething-message-id-number)))
+ "@" (system-name) ">\n"
+ "Date: " (current-time-string (nth 5 atts)) "\n"
+ (nneething-from-line (nth 2 atts))
+ "Chars: " (int-to-string (nth 7 atts)) "\n")))
+
+(defun nneething-from-line (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"))))))
+ (concat "From: " login "@" (system-name)
+ (if name (concat " (" name ")") "") "\n")))
+
+(defun nneething-get-head (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))
+ (erase-buffer)
+ (nneething-make-head file))
+ t))))
+
+(defun nneething-number-to-file (number)
+ (car (rassq number nneething-map)))
+
+(defun nneething-file-name (article)
+ (concat (file-name-as-directory nneething-directory)
+ (if (numberp article) (nneething-number-to-file article)
+ article)))
+
+(provide 'nneething)
+
+;;; nneething.el ends here
diff --git a/lisp/nnfolder.el b/lisp/nnfolder.el
new file mode 100644
index 00000000000..17c4d9b1f7b
--- /dev/null
+++ b/lisp/nnfolder.el
@@ -0,0 +1,704 @@
+;;; nnfolder.el --- mail folder access for Gnus
+;; Copyright (C) 1995 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: 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For an overview of what the interface functions do, please see the
+;; Gnus sources.
+
+;; Various enhancements by byer@mv.us.adobe.com (Scott Byer).
+
+;;; Code:
+
+(require 'nnheader)
+(require 'rmail)
+(require 'nnmail)
+
+(defvar nnfolder-directory (expand-file-name "~/Mail/")
+ "The name of the mail box file in the users home directory.")
+
+(defvar nnfolder-active-file
+ (concat (file-name-as-directory nnfolder-directory) "active")
+ "The name of the active file.")
+
+;; I renamed this variable to somehting more in keeping with the general GNU
+;; style. -SLB
+
+(defvar 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.")
+
+;; Note that this variable may not be completely implemented yet. -SLB
+
+(defvar nnfolder-always-close nil
+ "If non-nil, nnfolder attempts to only ever have one mbox open at a time.
+This is a straight space/performance trade off, as the mboxes will have to
+be scanned every time they are read in. If nil (default), nnfolder will
+attempt to keep the buffers around (saving the nnfolder's buffer upon group
+close, but not killing it), speeding some things up tremendously, especially
+such things as moving mail. All buffers always get killed upon server close.")
+
+(defvar nnfolder-newsgroups-file
+ (concat (file-name-as-directory nnfolder-directory) "newsgroups")
+ "Mail newsgroups description file.")
+
+(defvar nnfolder-get-new-mail t
+ "If non-nil, nnfolder will check the incoming mail file and split the mail.")
+
+(defvar nnfolder-prepare-save-mail-hook nil
+ "Hook run narrowed to an article before saving.")
+
+
+
+(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.")
+
+(defvar nnfolder-current-group nil)
+(defvar nnfolder-current-buffer nil)
+(defvar nnfolder-status-string "")
+(defvar nnfolder-group-alist nil)
+(defvar nnfolder-buffer-alist nil)
+(defvar nnfolder-active-timestamp nil)
+
+(defmacro nnfolder-article-string (article)
+ (` (concat "\n" nnfolder-article-marker (int-to-string (, article)) " ")))
+
+
+
+(defvar nnfolder-current-server nil)
+(defvar nnfolder-server-alist nil)
+(defvar nnfolder-server-variables
+ (list
+ (list 'nnfolder-directory nnfolder-directory)
+ (list 'nnfolder-active-file nnfolder-active-file)
+ (list 'nnfolder-newsgroups-file nnfolder-newsgroups-file)
+ (list 'nnfolder-get-new-mail nnfolder-get-new-mail)
+ '(nnfolder-current-group nil)
+ '(nnfolder-current-buffer nil)
+ '(nnfolder-status-string "")
+ '(nnfolder-group-alist nil)
+ '(nnfolder-buffer-alist nil)
+ '(nnfolder-active-timestamp nil)))
+
+
+
+;;; Interface functions
+
+(defun nnfolder-retrieve-headers (sequence &optional newsgroup server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let ((delim-string (concat "^" rmail-unix-mail-delimiter))
+ article art-string start stop)
+ (nnfolder-possibly-change-group newsgroup)
+ (set-buffer nnfolder-current-buffer)
+ (goto-char (point-min))
+ (if (stringp (car sequence))
+ 'headers
+ (while sequence
+ (setq article (car sequence))
+ (setq art-string (nnfolder-article-string article))
+ (set-buffer nnfolder-current-buffer)
+ (if (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))
+ (progn
+ (setq start (or (re-search-backward delim-string 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 nnfolder-current-buffer start stop)
+ (goto-char (point-max))
+ (insert ".\n")))
+ (setq sequence (cdr sequence)))
+
+ ;; Fold continuation lines.
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ 'headers))))
+
+(defun nnfolder-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (equal server nnfolder-current-server)
+ t
+ (if nnfolder-current-server
+ (setq nnfolder-server-alist
+ (cons (list nnfolder-current-server
+ (nnheader-save-variables nnfolder-server-variables))
+ nnfolder-server-alist)))
+ (let ((state (assoc server nnfolder-server-alist)))
+ (if state
+ (progn
+ (nnheader-restore-variables (nth 1 state))
+ (setq nnfolder-server-alist (delq state nnfolder-server-alist)))
+ (nnheader-set-init-variables nnfolder-server-variables defs)))
+ (setq nnfolder-current-server server)))
+
+(defun nnfolder-close-server (&optional server)
+ t)
+
+(defun nnfolder-server-opened (&optional server)
+ (and (equal server nnfolder-current-server)
+ nntp-server-buffer
+ (buffer-name nntp-server-buffer)))
+
+(defun nnfolder-request-close ()
+ (let ((alist nnfolder-buffer-alist))
+ (while alist
+ (nnfolder-close-group (car (car alist)) nil t)
+ (setq alist (cdr alist))))
+ (setq nnfolder-buffer-alist nil
+ nnfolder-group-alist nil))
+
+(defun nnfolder-status-message (&optional server)
+ nnfolder-status-string)
+
+(defun nnfolder-request-article (article &optional newsgroup server buffer)
+ (nnfolder-possibly-change-group newsgroup)
+ (if (stringp article)
+ nil
+ (save-excursion
+ (set-buffer nnfolder-current-buffer)
+ (goto-char (point-min))
+ (if (search-forward (nnfolder-article-string article) nil t)
+ (let (start stop)
+ (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
+ (setq start (point))
+ (forward-line 1)
+ (or (and (re-search-forward
+ (concat "^" rmail-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 nnfolder-current-buffer start stop)
+ (goto-char (point-min))
+ (while (looking-at "From ")
+ (delete-char 5)
+ (insert "X-From-Line: ")
+ (forward-line 1))
+ t))))))
+
+(defun nnfolder-request-group (group &optional server dont-check)
+ (save-excursion
+ (nnmail-activate 'nnfolder)
+ (nnfolder-possibly-change-group group)
+ (and (assoc group nnfolder-group-alist)
+ (progn
+ (if dont-check
+ t
+ (nnfolder-get-new-mail group)
+ (let* ((active (assoc group nnfolder-group-alist))
+ (group (car active))
+ (range (car (cdr active)))
+ (minactive (car range))
+ (maxactive (cdr range)))
+ ;; I've been getting stray 211 lines in my nnfolder active
+ ;; file. So, let's make sure that doesn't happen. -SLB
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (if (not active)
+ ()
+ (insert (format "211 %d %d %d %s\n"
+ (1+ (- maxactive minactive))
+ minactive maxactive group))
+ t)))))))
+
+;; 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.
+
+(defun nnfolder-close-group (group &optional server force)
+ ;; Make sure we _had_ the group open.
+ (if (or (assoc group nnfolder-buffer-alist)
+ (equal group nnfolder-current-group))
+ (progn
+ (nnfolder-possibly-change-group group)
+ (save-excursion
+ (set-buffer nnfolder-current-buffer)
+ ;; If the buffer was modified, write the file out now.
+ (and (buffer-modified-p) (save-buffer))
+ (if (or force
+ nnfolder-always-close)
+ ;; 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.
+ (progn
+ (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)
+
+(defun nnfolder-request-create-group (group &optional server)
+ (nnmail-activate 'nnfolder)
+ (or (assoc group nnfolder-group-alist)
+ (let (active)
+ (setq nnfolder-group-alist
+ (cons (list group (setq active (cons 1 0)))
+ nnfolder-group-alist))
+ (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))
+ t)
+
+(defun nnfolder-request-list (&optional server)
+ (if server (nnfolder-get-new-mail))
+ (save-excursion
+ (nnmail-find-file nnfolder-active-file)
+ (setq nnfolder-group-alist (nnmail-get-active))))
+
+(defun nnfolder-request-newgroups (date &optional server)
+ (nnfolder-request-list server))
+
+(defun nnfolder-request-list-newsgroups (&optional server)
+ (save-excursion
+ (nnmail-find-file nnfolder-newsgroups-file)))
+
+(defun nnfolder-request-post (&optional server)
+ (mail-send-and-exit nil))
+
+(defalias 'nnfolder-request-post-buffer 'nnmail-request-post-buffer)
+
+(defun nnfolder-request-expire-articles
+ (articles newsgroup &optional server force)
+ (nnfolder-possibly-change-group newsgroup)
+ (let* ((days (or (and nnmail-expiry-wait-function
+ (funcall nnmail-expiry-wait-function newsgroup))
+ nnmail-expiry-wait))
+ (is-old t)
+ rest)
+ (nnmail-activate 'nnfolder)
+
+ (save-excursion
+ (set-buffer nnfolder-current-buffer)
+ (while (and articles is-old)
+ (goto-char (point-min))
+ (if (search-forward (nnfolder-article-string (car articles)) nil t)
+ (if (or force
+ (setq is-old
+ (> (nnmail-days-between
+ (current-time-string)
+ (buffer-substring
+ (point) (progn (end-of-line) (point))))
+ days)))
+ (progn
+ (and gnus-verbose-backends
+ (message "Deleting article %s..." (car articles)))
+ (nnfolder-delete-mail))
+ (setq rest (cons (car articles) rest))))
+ (setq articles (cdr articles)))
+ (and (buffer-modified-p) (save-buffer))
+ ;; Find the lowest active article in this group.
+ (let* ((active (car (cdr (assoc newsgroup nnfolder-group-alist))))
+ (marker (concat "\n" nnfolder-article-marker))
+ (number "[0-9]+")
+ (activemin (cdr active)))
+ (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))
+ (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+ (nconc rest articles))))
+
+(defun nnfolder-request-move-article
+ (article group server accept-form &optional last)
+ (nnfolder-possibly-change-group group)
+ (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)
+ (set-buffer nnfolder-current-buffer)
+ (goto-char (point-min))
+ (if (search-forward (nnfolder-article-string article) nil t)
+ (nnfolder-delete-mail))
+ (and last
+ (buffer-modified-p)
+ (save-buffer))))
+ result))
+
+(defun nnfolder-request-accept-article (group &optional last)
+ (and (stringp group) (nnfolder-possibly-change-group group))
+ (let ((buf (current-buffer))
+ result)
+ (goto-char (point-min))
+ (cond ((looking-at "X-From-Line: ")
+ (replace-match "From "))
+ ((not (looking-at "From "))
+ (insert "From nobody " (current-time-string) "\n")))
+ (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))))
+ (setq result (car (nnfolder-save-mail (and (stringp group) group)))))
+ (save-excursion
+ (set-buffer nnfolder-current-buffer)
+ (and last (buffer-modified-p) (save-buffer))))
+ (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+ result))
+
+(defun 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)
+ (and (buffer-modified-p) (save-buffer))
+ t)))
+
+
+;;; Internal functions.
+
+(defun nnfolder-delete-mail (&optional force leave-delim)
+ ;; Beginning of the article.
+ (save-excursion
+ (save-restriction
+ (narrow-to-region
+ (save-excursion
+ (re-search-backward (concat "^" rmail-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 "^" rmail-unix-mail-delimiter)
+ nil t)
+ (if (and (not (bobp)) leave-delim)
+ (progn (forward-line -2) (point))
+ (match-beginning 0)))
+ (point-max))))
+ (delete-region (point-min) (point-max)))))
+
+(defun nnfolder-possibly-change-group (group)
+ (or (file-exists-p nnfolder-directory)
+ (make-directory (directory-file-name nnfolder-directory)))
+ (nnfolder-possibly-activate-groups nil)
+ (or (assoc group nnfolder-group-alist)
+ (not (file-exists-p (concat (file-name-as-directory nnfolder-directory)
+ group)))
+ (progn
+ (setq nnfolder-group-alist
+ (cons (list group (cons 1 0)) nnfolder-group-alist))
+ (nnmail-save-active nnfolder-group-alist nnfolder-active-file)))
+ (let (inf file)
+ (if (and (equal group nnfolder-current-group)
+ nnfolder-current-buffer
+ (buffer-name nnfolder-current-buffer))
+ ()
+ (setq nnfolder-current-group group)
+
+ ;; If we have to change groups, see if we don't already have the mbox
+ ;; in memory. If we do, verify the modtime and destroy the mbox if
+ ;; needed so we can rescan it.
+ (if (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.
+ (if (or (not (and nnfolder-current-buffer
+ (buffer-name nnfolder-current-buffer)))
+ (not (and (bufferp nnfolder-current-buffer)
+ (verify-visited-file-modtime
+ nnfolder-current-buffer))))
+ (progn
+ (if (and nnfolder-current-buffer
+ (buffer-name nnfolder-current-buffer)
+ (bufferp nnfolder-current-buffer))
+ (kill-buffer nnfolder-current-buffer))
+ (setq nnfolder-buffer-alist (delq inf nnfolder-buffer-alist))
+ (setq inf nil)))
+
+ (if inf
+ ()
+ (save-excursion
+ (setq file (concat (file-name-as-directory nnfolder-directory)
+ group))
+ (if (file-directory-p (file-truename file))
+ ()
+ (if (not (file-exists-p file))
+ (write-region 1 1 file t 'nomesg))
+ (setq nnfolder-current-buffer
+ (set-buffer (nnfolder-read-folder file)))
+ (setq nnfolder-buffer-alist (cons (list group (current-buffer))
+ nnfolder-buffer-alist)))))))
+ (setq nnfolder-current-group group))
+
+(defun nnfolder-save-mail (&optional group)
+ "Called narrowed to an article."
+ (let* ((nnmail-split-methods
+ (if group (list (list group "")) nnmail-split-methods))
+ (group-art-list
+ (nreverse (nnmail-article-group 'nnfolder-active-number)))
+ save-list group-art)
+ (setq save-list group-art-list)
+ (nnmail-insert-lines)
+ (nnmail-insert-xref group-art-list)
+ (run-hooks 'nnfolder-prepare-save-mail-hook)
+
+ ;; Insert the mail into each of the destination groups.
+ (while group-art-list
+ (setq group-art (car group-art-list)
+ group-art-list (cdr group-art-list))
+
+ ;; Kill the 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-possibly-change-group (car group-art))
+ (nnfolder-insert-newsgroup-line group-art)
+ (let ((beg (point-min))
+ (end (point-max))
+ (obuf (current-buffer)))
+ (set-buffer nnfolder-current-buffer)
+ (goto-char (point-max))
+ (insert-buffer-substring obuf beg end)
+ (set-buffer obuf)))
+
+ ;; Did we save it anywhere?
+ save-list))
+
+(defun nnfolder-insert-newsgroup-line (group-art)
+ (save-excursion
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (progn
+ (forward-char -1)
+ (insert (format (concat nnfolder-article-marker "%d %s\n")
+ (cdr group-art) (current-time-string)))))))
+
+(defun nnfolder-possibly-activate-groups (&optional group)
+ (save-excursion
+ ;; If we're looking for the activation of a specific group, find out
+ ;; its real name and switch to it.
+ (if group (nnfolder-possibly-change-group group))
+ ;; If the group alist isn't active, activate it now.
+ (nnmail-activate 'nnfolder)))
+
+(defun nnfolder-active-number (group)
+ (save-excursion
+ ;; Find the next article number in GROUP.
+ (prog1
+ (let ((active (car (cdr (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...
+ (setq nnfolder-group-alist
+ (cons (list group (setq active (cons 1 1)))
+ nnfolder-group-alist)))
+ (cdr active))
+ (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+ (nnfolder-possibly-activate-groups group)
+ )))
+
+
+;; 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 accross 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 (file)
+ (save-excursion
+ (nnfolder-possibly-activate-groups nil)
+ ;; We should be paranoid here and make sure the group is in the alist,
+ ;; and add it if it isn't.
+ ;;(if (not (assoc nnfoler-current-group nnfolder-group-alist)
+ (set-buffer (setq nnfolder-current-buffer
+ (nnheader-find-file-noselect file nil 'raw)))
+ (buffer-disable-undo (current-buffer))
+ (let ((delim (concat "^" rmail-unix-mail-delimiter))
+ (marker (concat "\n" nnfolder-article-marker))
+ (number "[0-9]+")
+ (active (car (cdr (assoc nnfolder-current-group
+ nnfolder-group-alist))))
+ activenumber activemin start end)
+ (goto-char (point-min))
+ ;;
+ ;; Anytime the active number is 1 or 0, it is supect. 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.)
+ (setq activenumber (cdr active))
+ (if (or nnfolder-ignore-active-file
+ (< activenumber 2))
+ (progn
+ (setq activemin (max (1- (lsh 1 23))
+ (1- (lsh 1 24))
+ (1- (lsh 1 25))))
+ (while (and (search-forward marker nil t)
+ (re-search-forward number nil t))
+ (let ((newnum (string-to-number (buffer-substring
+ (match-beginning 0)
+ (match-end 0)))))
+ (setq activenumber (max activenumber newnum))
+ (setq activemin (min activemin newnum))))
+ (setcar active (max 1 (min activemin activenumber)))
+ (setcdr active (max activenumber (cdr active)))
+ (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.
+ (setq end (point-marker))
+ (set-marker end (or (and (re-search-forward delim nil t)
+ (match-beginning 0))
+ (point-max)))
+ (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 (or (and (re-search-forward delim nil t)
+ (match-beginning 0))
+ (point-max)))
+ (goto-char start)
+ (if (not (search-forward marker end t))
+ (progn
+ (narrow-to-region start end)
+ (nnmail-insert-lines)
+ (nnfolder-insert-newsgroup-line
+ (cons nil (nnfolder-active-number nnfolder-current-group)))
+ (widen))))
+
+ ;; Make absolutely sure that the active list reflects reality!
+ (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+ (current-buffer))))
+
+(defun nnfolder-get-new-mail (&optional group)
+ "Read new incoming mail."
+ (let* ((spools (nnmail-get-spool-files group))
+ (group-in group)
+ incomings incoming)
+ (if (or (not nnfolder-get-new-mail) (not nnmail-spool-file))
+ ()
+ ;; We first activate all the groups.
+ (nnfolder-possibly-activate-groups nil)
+ ;; The we go through all the existing spool files and split the
+ ;; mail from each.
+ (while spools
+ (and
+ (file-exists-p (car spools))
+ (> (nth 7 (file-attributes (car spools))) 0)
+ (progn
+ (and gnus-verbose-backends
+ (message "nnfolder: Reading incoming mail..."))
+ (if (not (setq incoming
+ (nnmail-move-inbox
+ (car spools)
+ (concat (file-name-as-directory nnfolder-directory)
+ "Incoming"))))
+ ()
+ (setq incomings (cons incoming incomings))
+ (setq group (nnmail-get-split-group (car spools) group-in))
+ (nnmail-split-incoming incoming 'nnfolder-save-mail nil group))))
+ (setq spools (cdr spools)))
+ ;; If we did indeed read any incoming spools, we save all info.
+ (if incoming
+ (progn
+ (nnmail-save-active nnfolder-group-alist nnfolder-active-file)
+ (run-hooks 'nnmail-read-incoming-hook)
+ (and gnus-verbose-backends
+ (message "nnfolder: Reading incoming mail...done"))))
+ (let ((bufs nnfolder-buffer-alist))
+ (save-excursion
+ (while bufs
+ (if (not (buffer-name (nth 1 (car bufs))))
+ (setq nnfolder-buffer-alist
+ (delq (car bufs) nnfolder-buffer-alist))
+ (set-buffer (nth 1 (car bufs)))
+ (and (buffer-modified-p) (save-buffer)))
+ (setq bufs (cdr bufs)))))
+ (while incomings
+ (setq incoming (car incomings))
+ (and
+ nnmail-delete-incoming
+ (file-writable-p incoming)
+ (file-exists-p incoming)
+ (delete-file incoming))
+ (setq incomings (cdr incomings))))))
+
+(provide 'nnfolder)
+
+;;; nnfolder.el ends here
diff --git a/lisp/nnheader.el b/lisp/nnheader.el
new file mode 100644
index 00000000000..8e303615cfa
--- /dev/null
+++ b/lisp/nnheader.el
@@ -0,0 +1,358 @@
+;;; nnheader.el --- header access macros for Gnus and its backends
+;; Copyright (C) 1987,88,89,90,93,94,95 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, 675 Mass Ave, Cambridge, MA 02139, 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. 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:
+
+(defalias 'nntp-header-number 'mail-header-number)
+(defmacro mail-header-number (header)
+ "Return article number in HEADER."
+ (` (aref (, header) 0)))
+
+(defalias 'nntp-set-header-number 'mail-header-set-number)
+(defmacro mail-header-set-number (header number)
+ "Set article number of HEADER to NUMBER."
+ (` (aset (, header) 0 (, number))))
+
+(defalias 'nntp-header-subject 'mail-header-subject)
+(defmacro mail-header-subject (header)
+ "Return subject string in HEADER."
+ (` (aref (, header) 1)))
+
+(defalias 'nntp-set-header-subject 'mail-header-set-subject)
+(defmacro mail-header-set-subject (header subject)
+ "Set article subject of HEADER to SUBJECT."
+ (` (aset (, header) 1 (, subject))))
+
+(defalias 'nntp-header-from 'mail-header-from)
+(defmacro mail-header-from (header)
+ "Return author string in HEADER."
+ (` (aref (, header) 2)))
+
+(defalias 'nntp-set-header-from 'mail-header-set-from)
+(defmacro mail-header-set-from (header from)
+ "Set article author of HEADER to FROM."
+ (` (aset (, header) 2 (, from))))
+
+(defalias 'nntp-header-date 'mail-header-date)
+(defmacro mail-header-date (header)
+ "Return date in HEADER."
+ (` (aref (, header) 3)))
+
+(defalias 'nntp-set-header-date 'mail-header-set-date)
+(defmacro mail-header-set-date (header date)
+ "Set article date of HEADER to DATE."
+ (` (aset (, header) 3 (, date))))
+
+(defalias 'nntp-header-id 'mail-header-id)
+(defmacro mail-header-id (header)
+ "Return Id in HEADER."
+ (` (aref (, header) 4)))
+
+(defalias 'nntp-set-header-id 'mail-header-set-id)
+(defmacro mail-header-set-id (header id)
+ "Set article Id of HEADER to ID."
+ (` (aset (, header) 4 (, id))))
+
+(defalias 'nntp-header-references 'mail-header-references)
+(defmacro mail-header-references (header)
+ "Return references in HEADER."
+ (` (aref (, header) 5)))
+
+(defalias 'nntp-set-header-references 'mail-header-set-references)
+(defmacro mail-header-set-references (header ref)
+ "Set article references of HEADER to REF."
+ (` (aset (, header) 5 (, ref))))
+
+(defalias 'nntp-header-chars 'mail-header-chars)
+(defmacro mail-header-chars (header)
+ "Return number of chars of article in HEADER."
+ (` (aref (, header) 6)))
+
+(defalias 'nntp-set-header-chars 'mail-header-set-chars)
+(defmacro mail-header-set-chars (header chars)
+ "Set number of chars in article of HEADER to CHARS."
+ (` (aset (, header) 6 (, chars))))
+
+(defalias 'nntp-header-lines 'mail-header-lines)
+(defmacro mail-header-lines (header)
+ "Return lines in HEADER."
+ (` (aref (, header) 7)))
+
+(defalias 'nntp-set-header-lines 'mail-header-set-lines)
+(defmacro mail-header-set-lines (header lines)
+ "Set article lines of HEADER to LINES."
+ (` (aset (, header) 7 (, lines))))
+
+(defalias 'nntp-header-xref 'mail-header-xref)
+(defmacro mail-header-xref (header)
+ "Return xref string in HEADER."
+ (` (aref (, header) 8)))
+
+(defalias 'nntp-set-header-xref 'mail-header-set-xref)
+(defmacro mail-header-set-xref (header xref)
+ "Set article xref of HEADER to xref."
+ (` (aset (, header) 8 (, xref))))
+
+
+;; Various cruft the backends and Gnus need to communicate.
+
+(defvar nntp-server-buffer nil)
+(defvar gnus-verbose-backends t
+ "*If non-nil, Gnus backends will generate lots of comments.")
+(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)
+
+;; All backends use this function, so I moved it to this file.
+
+(defun nnheader-init-server-buffer ()
+ (save-excursion
+ (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))
+
+(defun nnheader-set-init-variables (server defs)
+ (let ((s server)
+ val)
+ ;; First we set the server variables in the sequence required. We
+ ;; use the definitions from the `defs' list where that is
+ ;; possible.
+ (while s
+ (set (car (car s))
+ (if (setq val (assq (car (car s)) defs))
+ (nth 1 val)
+ (nth 1 (car s))))
+ (setq s (cdr s)))
+ ;; The we go through the defs list and set any variables that were
+ ;; not set in the first sweep.
+ (while defs
+ (if (not (assq (car (car defs)) server))
+ (set (car (car defs))
+ (if (and (symbolp (nth 1 (car defs)))
+ (not (boundp (nth 1 (car defs)))))
+ (nth 1 (car defs))
+ (eval (nth 1 (car defs))))))
+ (setq defs (cdr defs)))))
+
+(defun nnheader-save-variables (server)
+ (let (out)
+ (while server
+ (setq out (cons (list (car (car server))
+ (symbol-value (car (car server))))
+ out))
+ (setq server (cdr server)))
+ (nreverse out)))
+
+(defun nnheader-restore-variables (state)
+ (while state
+ (set (car (car state)) (nth 1 (car state)))
+ (setq state (cdr state))))
+
+;; Read the head of an article.
+(defun nnheader-insert-head (file)
+ (let ((beg 0)
+ (chop 1024))
+ (while (and (eq chop (nth 1 (nnheader-insert-file-contents-literally
+ file nil beg (setq beg (+ chop beg)))))
+ (prog1 (not (search-backward "\n\n" nil t))
+ (goto-char (point-max)))))))
+
+(defun nnheader-article-p ()
+ (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))))
+
+;; Written by Erik Naggum <erik@naggum.no>.
+(defun nnheader-insert-file-contents-literally (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 ( ; (file-name-handler-alist nil)
+ (format-alist nil)
+ (after-insert-file-functions nil)
+ (find-buffer-file-type-function
+ (if (fboundp 'find-buffer-file-type)
+ (symbol-function 'find-buffer-file-type)
+ nil)))
+ (unwind-protect
+ (progn
+ (fset 'find-buffer-file-type (lambda (filename) t))
+ (insert-file-contents filename visit beg end replace))
+ (if find-buffer-file-type-function
+ (fset 'find-buffer-file-type find-buffer-file-type-function)
+ (fmakunbound 'find-buffer-file-type)))))
+
+(defun nnheader-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)
+ (if (fboundp 'find-buffer-visiting)
+ (find-buffer-visiting filename)
+ (get-file-buffer filename))))
+ error)
+ ;; Let user know if there is a buffer with the same truename.
+ (if other
+ (progn
+ (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.
+ (if (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-literally 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)
+ (if (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))
+ (if 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.
+ (and (not (funcall backup-enable-predicate buffer-file-name))
+ (progn
+ (make-local-variable 'backup-inhibited)
+ (setq backup-inhibited t)))
+ (if rawfile
+ nil
+ (after-find-file error (not nowarn)))))
+ buf)))
+
+(defun nnheader-insert-references (references message-id)
+ (if (and (not references) (not message-id))
+ () ; This is illegal, but not all articles have Message-IDs.
+ (mail-position-on-field "References")
+ ;; Fold long references line to follow RFC1036.
+ (let ((begin (gnus-point-at-bol))
+ (fill-column 78)
+ (fill-prefix "\t"))
+ (if references (insert references))
+ (if (and references message-id) (insert " "))
+ (if message-id (insert message-id))
+ ;; The region must end with a newline to fill the region
+ ;; without inserting extra newline.
+ (fill-region-as-paragraph begin (1+ (point))))))
+
+(provide 'nnheader)
+
+;;; nnheader.el ends here
diff --git a/lisp/nnkiboze.el b/lisp/nnkiboze.el
new file mode 100644
index 00000000000..65b67432e77
--- /dev/null
+++ b/lisp/nnkiboze.el
@@ -0,0 +1,345 @@
+;;; nnkiboze.el --- select virtual news access for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, 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 'gnus-score)
+
+(defvar nnkiboze-directory
+ (expand-file-name (or gnus-article-save-directory "~/News/"))
+ "nnkiboze will put its files in this directory.")
+
+
+
+(defconst nnkiboze-version "nnkiboze 1.0"
+ "Version numbers of this version of nnkiboze.")
+
+(defvar nnkiboze-current-group nil)
+(defvar nnkiboze-current-score-group "")
+(defvar nnkiboze-status-string "")
+
+
+
+;;; Interface functions.
+
+(defun nnkiboze-retrieve-headers (articles &optional group server)
+ (nnkiboze-possibly-change-newsgroups group)
+ (if gnus-nov-is-evil
+ nil
+ (if (stringp (car articles))
+ 'headers
+ (let ((first (car articles))
+ (last (progn (while (cdr articles) (setq articles (cdr articles)))
+ (car articles)))
+ (nov (nnkiboze-nov-file-name)))
+ (if (file-exists-p nov)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (insert-file-contents nov)
+ (goto-char (point-min))
+ (while (and (not (eobp)) (< first (read (current-buffer))))
+ (forward-line 1))
+ (beginning-of-line)
+ (if (not (eobp)) (delete-region 1 (point)))
+ (while (and (not (eobp)) (>= last (read (current-buffer))))
+ (forward-line 1))
+ (beginning-of-line)
+ (if (not (eobp)) (delete-region (point) (point-max)))
+ 'nov))))))
+
+(defun nnkiboze-open-server (newsgroups &optional something)
+ "Open a virtual newsgroup that contains NEWSGROUPS."
+ (gnus-make-directory nnkiboze-directory)
+ (nnheader-init-server-buffer))
+
+(defun nnkiboze-close-server (&rest dum)
+ "Close news server."
+ t)
+
+(defalias 'nnkiboze-request-quit (symbol-function 'nnkiboze-close-server))
+
+(defun nnkiboze-server-opened (&optional server)
+ "Return server process status, T or NIL.
+If the stream is opened, return T, otherwise return NIL."
+ (and nntp-server-buffer
+ (get-buffer nntp-server-buffer)))
+
+(defun nnkiboze-status-message (&optional server)
+ "Return server status response as string."
+ nnkiboze-status-string)
+
+(defun nnkiboze-request-article (article &optional newsgroup server buffer)
+ "Select article by message number."
+ (nnkiboze-possibly-change-newsgroups newsgroup)
+ (if (not (numberp article))
+ ;; This is a real cludge. 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-get-header-by-number article))
+ (xref (mail-header-xref header))
+ igroup iarticle)
+ (or xref (error "nnkiboze: No xref"))
+ (or (string-match " \\([^ ]+\\):\\([0-9]+\\)" xref)
+ (error "nnkiboze: Malformed xref"))
+ (setq igroup (substring xref (match-beginning 1) (match-end 1)))
+ (setq iarticle (string-to-int
+ (substring xref (match-beginning 2) (match-end 2))))
+ (and (gnus-request-group igroup t)
+ (gnus-request-article iarticle igroup buffer)))))
+
+(defun nnkiboze-request-group (group &optional server dont-check)
+ "Make GROUP the current newsgroup."
+ (nnkiboze-possibly-change-newsgroups group)
+ (if dont-check
+ ()
+ (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))
+ (insert (format "211 0 0 0 %s\n" group))
+ (insert-file-contents nov-file)
+ (if (zerop (buffer-size))
+ (insert (format "211 0 0 0 %s\n" group))
+ (goto-char (point-min))
+ (and (looking-at "[0-9]+") (setq beg (read (current-buffer))))
+ (goto-char (point-max))
+ (and (re-search-backward "^[0-9]" nil t)
+ (setq end (read (current-buffer))))
+ (setq total (count-lines (point-min) (point-max)))
+ (erase-buffer)
+ (insert (format "211 %d %d %d %s\n" total beg end group)))))))
+ t)
+
+(defun nnkiboze-close-group (group &optional server)
+ (nnkiboze-possibly-change-newsgroups group)
+ ;; Remove NOV lines of articles that are marked as read.
+ (if (not (file-exists-p (nnkiboze-nov-file-name)))
+ ()
+ (save-excursion
+ (let ((unreads gnus-newsgroup-unreads)
+ (unselected gnus-newsgroup-unselected))
+ (set-buffer (get-buffer-create "*nnkiboze work*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (let ((cur (current-buffer))
+ article)
+ (insert-file-contents (nnkiboze-nov-file-name))
+ (goto-char (point-min))
+ (while (looking-at "[0-9]+")
+ (if (or (memq (setq article (read cur)) unreads)
+ (memq article unselected))
+ (forward-line 1)
+ (delete-region (progn (beginning-of-line) (point))
+ (progn (forward-line 1) (point)))))
+ (write-file (nnkiboze-nov-file-name))
+ (kill-buffer (current-buffer)))))
+ (setq nnkiboze-current-group nil)))
+
+(defun nnkiboze-request-list (&optional server)
+ (setq nnkiboze-status-string "nnkiboze: LIST is not implemented.")
+ nil)
+
+(defun nnkiboze-request-newgroups (date &optional server)
+ "List new groups."
+ (setq nnkiboze-status-string "NEWGROUPS is not supported.")
+ nil)
+
+(defun nnkiboze-request-list-newsgroups (&optional server)
+ (setq nnkiboze-status-string "nnkiboze: LIST NEWSGROUPS is not implemented.")
+ nil)
+
+(defalias 'nnkiboze-request-post 'nntp-request-post)
+
+(defalias 'nnkiboze-request-post-buffer 'nntp-request-post-buffer)
+
+
+;;; Internal functions.
+
+(defun nnkiboze-possibly-change-newsgroups (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 gnus-newsrc-alist))
+ (while newsrc
+ (if (string-match "nnkiboze" (car (car newsrc)))
+ (nnkiboze-generate-group (car (car newsrc))))
+ (setq newsrc (cdr newsrc)))))
+
+(defun nnkiboze-score-file (group)
+ (list (expand-file-name
+ (concat gnus-kill-files-directory nnkiboze-current-score-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"))
+ (regexp (nth 1 (nth 4 info)))
+ (gnus-expert-user t)
+ (gnus-large-newsgroup nil)
+ (gnus-score-find-score-files-function 'nnkiboze-score-file)
+ gnus-select-group-hook gnus-summary-prepare-hook
+ gnus-thread-sort-functions gnus-show-threads
+ gnus-visual
+ method nnkiboze-newsrc nov-buffer gname newsrc active
+ ginfo lowest)
+ (setq nnkiboze-current-score-group group)
+ (or info (error "No such group: %s" group))
+ (and (file-exists-p newsrc-file) (load newsrc-file))
+ (save-excursion
+ (set-buffer (setq nov-buffer (find-file-noselect nov-file)))
+ (buffer-disable-undo (current-buffer)))
+ ;; Go through the active hashtb and add new all groups that match the
+ ;; kiboze regexp.
+ (mapatoms
+ (lambda (group)
+ (if (and (string-match regexp (setq gname (symbol-name group))) ; Match
+ (not (assoc gname nnkiboze-newsrc)) ; It isn't registered
+ (numberp (car (symbol-value group))) ; It is active
+ (not (string-match "^nnkiboze:" gname))) ; Exclude kibozes
+ (setq nnkiboze-newsrc
+ (cons (cons gname (1- (car (symbol-value group))))
+ nnkiboze-newsrc))))
+ gnus-active-hashtb)
+ (setq newsrc nnkiboze-newsrc)
+ (while newsrc
+ (if (not (setq active (gnus-gethash
+ (car (car newsrc)) gnus-active-hashtb)))
+ (setq nnkiboze-newsrc (delq (car newsrc) nnkiboze-newsrc))
+ (switch-to-buffer gnus-group-buffer)
+ (gnus-group-jump-to-group (car (car newsrc)))
+ (if (and (setq ginfo (nth 2 (gnus-gethash (gnus-group-group-name)
+ gnus-newsrc-hashtb)))
+ (nth 3 ginfo))
+ (setcar (nthcdr 3 ginfo) nil))
+ (if (not (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))))
+ ()
+ (setq lowest (cdr (car newsrc)))
+ (setq method (gnus-find-method-for-group gnus-newsgroup-name))
+ (and (eq method gnus-select-method) (setq method nil))
+ (while gnus-newsgroup-scored
+ (if (> (car (car gnus-newsgroup-scored)) lowest)
+ (nnkiboze-enter-nov
+ nov-buffer
+ (gnus-get-header-by-number (car (car gnus-newsgroup-scored)))
+ (if method
+ (gnus-group-prefixed-name gnus-newsgroup-name method)
+ gnus-newsgroup-name)))
+ (setq gnus-newsgroup-scored (cdr gnus-newsgroup-scored)))
+ (gnus-summary-quit)))
+ (setcdr (car newsrc) (car active))
+ (setq newsrc (cdr newsrc)))
+ (set-buffer nov-buffer)
+ (save-buffer)
+ (kill-buffer (current-buffer))
+ (set-buffer (get-buffer-create "*nnkiboze work*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert "(setq nnkiboze-newsrc '" (prin1-to-string nnkiboze-newsrc)
+ ")\n")
+ (write-file newsrc-file)
+ (kill-buffer (current-buffer))
+ (switch-to-buffer gnus-group-buffer)
+ (gnus-group-list-groups 5 nil)))
+
+(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))
+ (first t)
+ article)
+ (if (zerop (forward-line -1))
+ (progn
+ (setq article (1+ (read (current-buffer))))
+ (forward-line 1))
+ (setq article 1))
+ (insert (int-to-string article) "\t"
+ (or (mail-header-subject header) "") "\t"
+ (or (mail-header-from header) "") "\t"
+ (or (mail-header-date header) "") "\t"
+ (or (mail-header-id header) "") "\t"
+ (or (mail-header-references header) "") "\t"
+ (int-to-string (or (mail-header-chars header) 0)) "\t"
+ (int-to-string (or (mail-header-lines header) 0)) "\t")
+ (if (or (not xref) (equal "" xref))
+ (insert "Xref: " (system-name) " " group ":"
+ (int-to-string (mail-header-number header))
+ "\t\n")
+ (insert (mail-header-xref header) "\t\n")
+ (search-backward "\t" nil t)
+ (search-backward "\t" nil t)
+ (while (re-search-forward
+ "[^ ]+:[0-9]+"
+ (save-excursion (end-of-line) (point)) t)
+ (if first
+ ;; 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.
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (insert prefix group ":"
+ (int-to-string (mail-header-number header)) " ")
+ (setq first nil)))
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (insert prefix)))))))
+
+(defun nnkiboze-nov-file-name ()
+ (concat nnkiboze-directory
+ (nnkiboze-prefixed-name nnkiboze-current-group) ".nov"))
+
+(provide 'nnkiboze)
+
+;;; nnkiboze.el ends here
diff --git a/lisp/nnmail.el b/lisp/nnmail.el
new file mode 100644
index 00000000000..2de0bcaad2a
--- /dev/null
+++ b/lisp/nnmail.el
@@ -0,0 +1,877 @@
+;;; nnmail.el --- mail support functions for the Gnus mail backends
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'rmail)
+(require 'timezone)
+(require 'sendmail)
+
+(defvar nnmail-split-methods
+ '(("mail.misc" ""))
+ "*Incoming mail will be split according to this variable.
+
+If you'd like, for instance, one mail group for mail from the
+\"4ad-l\" mailing list, one group for junk mail and one for everything
+else, you could do something like this:
+
+ (setq nnmail-split-methods
+ '((\"mail.4ad\" \"From:.*4ad\")
+ (\"mail.junk\" \"From:.*Lars\\\\|Subject:.*buy\")
+ (\"mail.misc\" \"\")))
+
+As you can see, this variable is a list of lists, where the first
+element in each \"rule\" is the name of the group (which, by the way,
+does not have to be called anything beginning with \"mail\",
+\"yonka.zow\" is a fine, fine name), and the second is a regexp that
+nnmail will try to match on the header to find a fit.
+
+The second element can also be a function. In that case, it will be
+called narrowed to the headers with the first element of the rule as
+the argument. It should return a non-nil value if it thinks that the
+mail belongs in that group.
+
+The last element should always have \"\" as the regexp.
+
+This variable can also have a function as its value.")
+
+;; Suggested by Erik Selberg <speed@cs.washington.edu>.
+(defvar nnmail-crosspost t
+ "*If non-nil, do crossposting if several split methods match the mail.
+If nil, the first match found will be used.")
+
+;; Added by gord@enci.ucalgary.ca (Gordon Matzigkeit).
+(defvar nnmail-keep-last-article nil
+ "*If non-nil, nnmail will never delete the last expired article in a
+directory. You may need to set this variable if other programs are putting
+new mail into folder numbers that Gnus has marked as expired.")
+
+(defvar nnmail-expiry-wait 7
+ "*Articles that are older than `nnmail-expiry-wait' days will be expired.")
+
+(defvar nnmail-expiry-wait-function nil
+ "*Variable that holds function to specify how old articles should be before they are expired.
+ The function will be called with the name of the group that the
+expiry is to be performed in, and it should return an integer that
+says how many days an article can be stored before it is considered
+'old'.
+
+Eg.:
+
+(setq nnmail-expiry-wait-function
+ (lambda (newsgroup)
+ (cond ((string-match \"private\" newsgroup) 31)
+ ((string-match \"junk\" newsgroup) 1)
+ (t 7))))")
+
+(defvar nnmail-spool-file
+ (or (getenv "MAIL")
+ (concat "/usr/spool/mail/" (user-login-name)))
+ "Where the mail backends will look for incoming mail.
+This variable is \"/usr/spool/mail/$user\" by default.
+If this variable is nil, no mail backends will read incoming mail.
+If this variable is a list, all files mentioned in this list will be
+used as incoming mailboxes.")
+
+(defvar nnmail-use-procmail nil
+ "*If non-nil, the mail backends will look in `nnmail-procmail-directory' for spool files.
+The file(s) in `nnmail-spool-file' will also be read.")
+
+(defvar nnmail-procmail-directory "~/incoming/"
+ "*When using procmail (and the like), incoming mail is put in this directory.
+The Gnus mail backends will read the mail from this directory.")
+
+(defvar nnmail-procmail-suffix ".spool"
+ "*Suffix of files created by procmail (and the like).
+This variable might be a suffix-regexp to match the suffixes of
+several files - eg. \".spool[0-9]*\".")
+
+(defvar nnmail-resplit-incoming nil
+ "*If non-nil, re-split incoming procmail sorted mail.")
+
+(defvar nnmail-movemail-program "movemail"
+ "*A command to be executed to move mail from the inbox.
+The default is \"movemail\".")
+
+(defvar nnmail-read-incoming-hook nil
+ "*Hook that will be run after the incoming mail has been transferred.
+The incoming mail is moved from `nnmail-spool-file' (which normally is
+something like \"/usr/spool/mail/$user\") to the user's home
+directory. This hook is called after the incoming mail box has been
+emptied, and can be used to call any mail box programs you have
+running (\"xwatch\", etc.)
+
+Eg.
+
+(add-hook 'nnmail-read-incoming-hook
+ (lambda ()
+ (start-process \"mailsend\" nil
+ \"/local/bin/mailsend\" \"read\" \"mbox\")))")
+
+;; Suggested by Erik Selberg <speed@cs.washington.edu>.
+(defvar nnmail-prepare-incoming-hook nil
+ "*Hook called before treating incoming mail.
+The hook is run in a buffer with all the new, incoming mail.")
+
+;; Suggested by Mejia Pablo J <pjm9806@usl.edu>.
+(defvar nnmail-tmp-directory nil
+ "*If non-nil, use this directory for temporary storage when reading incoming mail.")
+
+(defvar nnmail-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.")
+
+(defvar nnmail-split-fancy "mail.misc"
+ "*Incoming mail can be split according to this fancy variable.
+To enable this, set `nnmail-split-methods' to `nnmail-split-fancy'.
+
+The format is this variable is SPLIT, where SPLIT can be one of
+the following:
+
+GROUP: Mail will be stored in GROUP (a string).
+
+\(FIELD VALUE SPLIT): If the message field FIELD (a regexp) contains
+ VALUE (a regexp), store the messages as specified by SPLIT.
+
+\(| SPLIT...): Process each SPLIT expression until one of them matches.
+ A SPLIT expression is said to match if it will cause the mail
+ message to be stored in one or more groups.
+
+\(& SPLIT...): Process each SPLIT expression.
+
+FIELD must match a complete field name. VALUE must match a complete
+word according to the fundamental mode syntax table. You can use .*
+in the regexps to match partial field names or words.
+
+FIELD and VALUE can also be lisp symbols, in that case they are expanded
+as specified in `nnmail-split-abbrev-alist'.
+
+Example:
+
+\(setq nnmail-split-methods 'nnmail-split-fancy
+ nnmail-split-fancy
+ ;; Messages from the mailer deamon are not crossposted to any of
+ ;; the ordinary groups. Warnings are put in a separate group
+ ;; from real errors.
+ '(| (\"from\" mail (| (\"subject\" \"warn.*\" \"mail.warning\")
+ \"mail.misc\"))
+ ;; Non-error messages are crossposted to all relevant
+ ;; groups, but we don't crosspost between the group for the
+ ;; (ding) list and the group for other (ding) related mail.
+ (& (| (any \"ding@ifi\\\\.uio\\\\.no\" \"ding.list\")
+ (\"subject\" \"ding\" \"ding.misc\"))
+ ;; Other mailing lists...
+ (any \"procmail@informatik\\\\.rwth-aachen\\\\.de\" \"procmail.list\")
+ (any \"SmartList@informatik\\\\.rwth-aachen\\\\.de\" \"SmartList.list\")
+ ;; People...
+ (any \"larsi@ifi\\\\.uio\\\\.no\" \"people.Lars Magne Ingebrigtsen\"))
+ ;; Unmatched mail goes to the catch all group.
+ \"misc.misc\"))")
+
+(defvar nnmail-split-abbrev-alist
+ '((any . "from\\|to\\|cc\\|sender\\|apparently-to")
+ (mail . "mailer-daemon\\|postmaster"))
+ "*Alist of abbreviations allowed in `nnmail-split-fancy'.")
+
+(defvar nnmail-delete-incoming t
+ "*If non-nil, the mail backends will delete incoming files after splitting.")
+
+(defvar nnmail-message-id-cache-length 1000
+ "*The approximate number of Message-IDs nnmail will keep in its cache.
+If this variable is nil, no checking on duplicate messages will be
+perfomed.")
+
+(defvar nnmail-message-id-cache-file "~/.nnmail-cache"
+ "*The file name of the nnmail Message-ID cache.")
+
+(defvar nnmail-delete-duplicates nil
+ "*If non-nil, nnmail will delete any duplicate mails it sees.")
+
+
+
+(defconst nnmail-version "nnmail 1.0"
+ "nnmail version.")
+
+
+
+(defun nnmail-request-post (&optional server)
+ (mail-send-and-exit nil))
+
+(defun nnmail-request-post-buffer (post group subject header article-buffer
+ info follow-to respect-poster)
+ (let ((method-address (cdr (assq 'to-address (nth 5 info))))
+ from date to reply-to message-of
+ references message-id cc new-cc sendto elt)
+ (setq method-address
+ (if (and (stringp method-address)
+ (string= method-address ""))
+ nil method-address))
+ (save-excursion
+ (set-buffer (get-buffer-create "*mail*"))
+ (mail-mode)
+ (local-set-key "\C-c\C-c" 'gnus-mail-send-and-exit)
+ (if (and (buffer-modified-p)
+ (> (buffer-size) 0)
+ (not (y-or-n-p "Unsent mail being composed; erase it? ")))
+ ()
+ (erase-buffer)
+ (if post
+ (progn
+ (mail-setup method-address subject nil nil nil nil)
+ (auto-save-mode auto-save-default))
+ (save-excursion
+ (set-buffer article-buffer)
+ (goto-char (point-min))
+ (narrow-to-region (point-min)
+ (progn (search-forward "\n\n") (point)))
+ (let ((buffer-read-only nil))
+ (set-text-properties (point-min) (point-max) nil))
+ (setq from (mail-header-from header))
+ (setq date (mail-header-date header))
+ (and from
+ (let ((stop-pos
+ (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (setq message-of
+ (concat (if stop-pos (substring from 0 stop-pos) from)
+ "'s message of " date))))
+ (setq cc (mail-strip-quoted-names (or (mail-fetch-field "cc") "")))
+ (setq to (mail-strip-quoted-names (or (mail-fetch-field "to") "")))
+ (setq new-cc (rmail-dont-reply-to
+ (concat (or to "")
+ (if cc (concat (if to ", " "") cc) ""))))
+ (let ((rmail-dont-reply-to-names
+ (regexp-quote (mail-strip-quoted-names
+ (or method-address reply-to from "")))))
+ (setq new-cc (rmail-dont-reply-to new-cc)))
+ (setq subject (mail-header-subject header))
+ (or (string-match "^[Rr][Ee]:" subject)
+ (setq subject (concat "Re: " subject)))
+ (setq reply-to (mail-fetch-field "reply-to"))
+ (setq references (mail-header-references header))
+ (setq message-id (mail-header-id header))
+ (widen))
+ (setq news-reply-yank-from from)
+ (setq news-reply-yank-message-id message-id)
+
+ ;; Gather the "to" addresses out of the follow-to list and remove
+ ;; them as we go.
+ (if (and follow-to (listp follow-to))
+ (while (setq elt (assoc "To" follow-to))
+ (setq sendto (concat sendto (and sendto ", ") (cdr elt)))
+ (setq follow-to (delq elt follow-to))))
+ (mail-setup (if (and follow-to (listp follow-to))
+ sendto
+ (or method-address reply-to from ""))
+ subject message-of
+ (if (zerop (length new-cc)) nil new-cc)
+ article-buffer nil)
+ (auto-save-mode auto-save-default)
+ ;; Note that "To" elements should already be in the message.
+ (if (and follow-to (listp follow-to))
+ (progn
+ (goto-char (point-min))
+ (re-search-forward "^To:" nil t)
+ (beginning-of-line)
+ (forward-line 1)
+ (while follow-to
+ (insert
+ (car (car follow-to)) ": " (cdr (car follow-to)) "\n")
+ (setq follow-to (cdr follow-to)))))
+ (nnheader-insert-references references message-id)))
+ (current-buffer))))
+
+(defun nnmail-find-file (file)
+ "Insert FILE in server buffer safely."
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (condition-case ()
+ (progn (insert-file-contents file) t)
+ (file-error nil)))
+
+(defun nnmail-article-pathname (group mail-dir)
+ "Make pathname for GROUP."
+ (concat (file-name-as-directory (expand-file-name mail-dir))
+ (nnmail-replace-chars-in-string group ?. ?/) "/"))
+
+(defun nnmail-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)
+ (if (= (aref string idx) from)
+ (aset string idx to))
+ (setq idx (1+ idx)))
+ string))
+
+(defun nnmail-days-between (date1 date2)
+ ;; Return the number of days between date1 and date2.
+ (let ((d1 (mapcar (lambda (s) (and s (string-to-int s)) )
+ (timezone-parse-date date1)))
+ (d2 (mapcar (lambda (s) (and s (string-to-int s)) )
+ (timezone-parse-date date2))))
+ (- (timezone-absolute-from-gregorian
+ (nth 1 d1) (nth 2 d1) (car d1))
+ (timezone-absolute-from-gregorian
+ (nth 1 d2) (nth 2 d2) (car d2)))))
+
+;; Function taken from rmail.el.
+(defun nnmail-move-inbox (inbox tofile)
+ (let ((inbox (file-truename
+ (expand-file-name (substitute-in-file-name inbox))))
+ movemail popmail errors)
+ ;; Check whether the inbox is to be moved to the special tmp dir.
+ (if nnmail-tmp-directory
+ (setq tofile (concat (file-name-as-directory nnmail-tmp-directory)
+ (file-name-nondirectory tofile))))
+ ;; Make the filename unique.
+ (setq tofile (nnmail-make-complex-temp-name (expand-file-name tofile)))
+ ;; We create the directory the tofile is to reside in if it
+ ;; doesn't exist.
+ (or (file-exists-p (file-name-directory tofile))
+ (make-directory tofile 'parents))
+ ;; If getting from mail spool directory,
+ ;; use movemail to move rather than just renaming,
+ ;; so as to interlock with the mailer.
+ (or (setq popmail (string-match "^po:" (file-name-nondirectory inbox)))
+ (setq movemail t))
+ (if popmail (setq inbox (file-name-nondirectory inbox)))
+ (if movemail
+ ;; On some systems, /usr/spool/mail/foo is a directory
+ ;; and the actual inbox is /usr/spool/mail/foo/foo.
+ (if (file-directory-p inbox)
+ (setq inbox (expand-file-name (user-login-name) inbox))))
+ (if popmail
+ (message "Getting mail from post office ...")
+ (if (or (and (file-exists-p tofile)
+ (/= 0 (nth 7 (file-attributes tofile))))
+ (and (file-exists-p inbox)
+ (/= 0 (nth 7 (file-attributes inbox)))))
+ (message "Getting mail from %s..." inbox)))
+ ;; Set TOFILE if have not already done so, and
+ ;; rename or copy the file INBOX to TOFILE if and as appropriate.
+ (cond ((or (file-exists-p tofile) (and (not popmail)
+ (not (file-exists-p inbox))))
+ nil)
+ ((and (not movemail) (not popmail))
+ ;; Try copying. If that fails (perhaps no space),
+ ;; rename instead.
+ (condition-case nil
+ (copy-file inbox tofile nil)
+ (error
+ ;; Third arg is t so we can replace existing file TOFILE.
+ (rename-file inbox tofile t)))
+ ;; Make the real inbox file empty.
+ ;; Leaving it deleted could cause lossage
+ ;; because mailers often won't create the file.
+ (condition-case ()
+ (write-region (point) (point) inbox)
+ (file-error nil)))
+ (t
+ (unwind-protect
+ (save-excursion
+ (setq errors (generate-new-buffer " *nnmail loss*"))
+ (buffer-disable-undo errors)
+ (call-process
+ (expand-file-name nnmail-movemail-program exec-directory)
+ nil errors nil inbox tofile)
+ (if (not (buffer-modified-p errors))
+ ;; No output => movemail won
+ nil
+ (set-buffer errors)
+ (subst-char-in-region (point-min) (point-max) ?\n ?\ )
+ (goto-char (point-max))
+ (skip-chars-backward " \t")
+ (delete-region (point) (point-max))
+ (goto-char (point-min))
+ (if (looking-at "movemail: ")
+ (delete-region (point-min) (match-end 0)))
+ (beep t)
+ (message (concat "movemail: "
+ (buffer-substring (point-min)
+ (point-max))))
+ (sit-for 3)
+ nil)))))
+ (and errors
+ (buffer-name errors)
+ (kill-buffer errors))
+ tofile))
+
+
+(defun nnmail-get-active ()
+ "Returns an assoc of group names and active ranges.
+nn*-request-list should have been called before calling this function."
+ (let (group-assoc)
+ ;; Go through all groups from the active list.
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\([^ \t]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)" nil t)
+ (setq group-assoc
+ (cons (list (buffer-substring (match-beginning 1)
+ (match-end 1))
+ (cons (string-to-int
+ (buffer-substring (match-beginning 3)
+ (match-end 3)))
+ (string-to-int
+ (buffer-substring (match-beginning 2)
+ (match-end 2)))))
+ group-assoc))))
+
+ ;; ;; In addition, add all groups mentioned in `nnmail-split-methods'.
+ ;; (let ((methods (and (not (symbolp nnmail-split-methods))
+ ;; nnmail-split-methods)))
+ ;; (while methods
+ ;; (if (not (assoc (car (car methods)) group-assoc))
+ ;; (setq group-assoc
+ ;; (cons (list (car (car methods)) (cons 1 0))
+ ;; group-assoc)))
+ ;; (setq methods (cdr methods)))
+
+ group-assoc))
+
+(defun nnmail-save-active (group-assoc file-name)
+ (let (group)
+ (save-excursion
+ (set-buffer (get-buffer-create " *nnmail active*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (while group-assoc
+ (setq group (car group-assoc))
+ (insert (format "%s %d %d y\n" (car group) (cdr (car (cdr group)) )
+ (car (car (cdr group)))))
+ (setq group-assoc (cdr group-assoc)))
+ (write-region 1 (point-max) (expand-file-name file-name) nil 'nomesg)
+ (kill-buffer (current-buffer)))))
+
+(defun nnmail-get-split-group (file group)
+ (if (or (eq nnmail-spool-file 'procmail)
+ nnmail-use-procmail)
+ (cond (group group)
+ ((string-match (concat "^" (expand-file-name
+ (file-name-as-directory
+ nnmail-procmail-directory))
+ "\\(.*\\)" nnmail-procmail-suffix "$")
+ (expand-file-name file))
+ (substring (expand-file-name file)
+ (match-beginning 1) (match-end 1)))
+ (t
+ group))
+ group))
+
+(defun nnmail-split-incoming (incoming func &optional dont-kill group)
+ "Go through the entire INCOMING file and pick out each individual mail.
+FUNC will be called with the buffer narrowed to each mail."
+ (let ((delim (concat "^" rmail-unix-mail-delimiter))
+ ;; If this is a group-specific split, we bind the split
+ ;; methods to just this group.
+ (nnmail-split-methods (if (and group
+ (or (eq nnmail-spool-file 'procmail)
+ nnmail-use-procmail)
+ (not nnmail-resplit-incoming))
+ (list (list group ""))
+ nnmail-split-methods))
+ start end content-length do-search message-id)
+ (save-excursion
+ ;; Open the message-id cache.
+ (nnmail-cache-open)
+ ;; Insert the incoming file.
+ (set-buffer (get-buffer-create " *nnmail incoming*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (insert-file-contents incoming)
+ (goto-char (point-min))
+ (save-excursion (run-hooks 'nnmail-prepare-incoming-hook))
+ ;; Go to the beginning of the first mail...
+ (if (and (re-search-forward delim nil t)
+ (goto-char (match-beginning 0)))
+ ;; and then carry on until the bitter end.
+ (while (not (eobp))
+ (setq start (point))
+ ;; Skip all the headers in case there are more "From "s...
+ (if (not (search-forward "\n\n" nil t))
+ (forward-line 1))
+ ;; Find the Message-ID header.
+ (save-excursion
+ (if (re-search-backward "^Message-ID:[ \t]*\\(<[^>]*>\\)" nil t)
+ (setq message-id (buffer-substring (match-beginning 1)
+ (match-end 1)))
+ ;; There is no Message-ID here, so we create one.
+ (forward-line -1)
+ (insert "Message-ID: " (setq message-id (nnmail-message-id))
+ "\n")))
+ ;; Look for a Content-Length header.
+ (if (not (save-excursion
+ (and (re-search-backward
+ "^Content-Length: \\([0-9]+\\)" start t)
+ (setq content-length (string-to-int
+ (buffer-substring
+ (match-beginning 1)
+ (match-end 1))))
+ ;; We destroy the header, since none of
+ ;; the backends ever use it, and we do not
+ ;; want to confuse other mailers by having
+ ;; a (possibly) faulty header.
+ (progn (insert "X-") t))))
+ (setq do-search t)
+ (if (or (= (+ (point) content-length) (point-max))
+ (save-excursion
+ (goto-char (+ (point) content-length))
+ (looking-at delim)))
+ (progn
+ (goto-char (+ (point) content-length))
+ (setq do-search nil))
+ (setq do-search t)))
+ ;; Go to the beginning of the next article - or to the end
+ ;; of the buffer.
+ (if do-search
+ (if (re-search-forward delim nil t)
+ (goto-char (match-beginning 0))
+ (goto-char (point-max))))
+ (save-excursion
+ (save-restriction
+ (narrow-to-region start (point))
+ (goto-char (point-min))
+ ;; If this is a duplicate message, then we do not save it.
+ (if (nnmail-cache-id-exists-p message-id)
+ (delete-region (point-min) (point-max))
+ (nnmail-cache-insert message-id)
+ (funcall func))
+ (setq end (point-max))))
+ (goto-char end)))
+ ;; Close the message-id cache.
+ (nnmail-cache-close)
+ (if dont-kill
+ (current-buffer)
+ (kill-buffer (current-buffer))))))
+
+;; Mail crossposts syggested by Brian Edmonds <edmonds@cs.ubc.ca>.
+(defun nnmail-article-group (func)
+ "Look at the headers and return an alist of groups that match.
+FUNC will be called with the group name to determine the article number."
+ (let ((methods nnmail-split-methods)
+ (obuf (current-buffer))
+ (beg (point-min))
+ end group-art)
+ (if (and (sequencep methods) (= (length methods) 1))
+ ;; If there is only just one group to put everything in, we
+ ;; just return a list with just this one method in.
+ (setq group-art
+ (list (cons (car (car methods))
+ (funcall func (car (car methods))))))
+ ;; We do actual comparison.
+ (save-excursion
+ ;; Find headers.
+ (goto-char beg)
+ (setq end (if (search-forward "\n\n" nil t) (point) (point-max)))
+ (set-buffer (get-buffer-create " *nnmail work*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ ;; Copy the headers into the work buffer.
+ (insert-buffer-substring obuf beg end)
+ ;; Fold continuation lines.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ (if (and (symbolp nnmail-split-methods)
+ (fboundp nnmail-split-methods))
+ (setq group-art
+ (mapcar
+ (lambda (group) (cons group (funcall func group)))
+ (condition-case nil
+ (funcall nnmail-split-methods)
+ (error
+ (message "\
+Problems with `nnmail-split-methods', using `bogus' mail group")
+ (sit-for 1)
+ '("bogus")))))
+ ;; Go throught the split methods to find a match.
+ (while (and methods (or nnmail-crosspost (not group-art)))
+ (goto-char (point-max))
+ (if (or (cdr methods)
+ (not (equal "" (nth 1 (car methods)))))
+ (if (and (condition-case ()
+ (if (stringp (nth 1 (car methods)))
+ (re-search-backward
+ (car (cdr (car methods))) nil t)
+ ;; Suggested by Brian Edmonds
+ ;; <edmonds@cs.ubc.ca>.
+ (funcall (nth 1 (car methods))
+ (car (car methods))))
+ (error nil))
+ ;; Don't enter the article into the same group twice.
+ (not (assoc (car (car methods)) group-art)))
+ (setq group-art
+ (cons (cons (car (car methods))
+ (funcall func (car (car methods))))
+ group-art)))
+ (or group-art
+ (setq group-art
+ (list (cons (car (car methods))
+ (funcall func (car (car methods))))))))
+ (setq methods (cdr methods))))
+ (kill-buffer (current-buffer))
+ group-art))))
+
+(defun nnmail-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))
+ (if (search-forward "\n\n" nil t)
+ (progn
+ (setq chars (- (point-max) (point)))
+ (setq lines (- (count-lines (point) (point-max)) 1))
+ (forward-char -1)
+ (save-excursion
+ (if (re-search-backward "^Lines: " nil t)
+ (delete-region (point) (progn (forward-line 1) (point)))))
+ (insert (format "Lines: %d\n" lines))
+ chars)))))
+
+(defun nnmail-insert-xref (group-alist)
+ "Insert an Xref line based on the (group . article) alist."
+ (save-excursion
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (progn
+ (forward-char -1)
+ (if (re-search-backward "^Xref: " nil t)
+ (delete-region (match-beginning 0)
+ (progn (forward-line 1) (point))))
+ (insert (format "Xref: %s" (system-name)))
+ (while group-alist
+ (insert (format " %s:%d" (car (car group-alist))
+ (cdr (car group-alist))))
+ (setq group-alist (cdr group-alist)))
+ (insert "\n")))))
+
+;; Written by byer@mv.us.adobe.com (Scott Byer).
+(defun nnmail-make-complex-temp-name (prefix)
+ (let ((newname (make-temp-name prefix))
+ (newprefix prefix))
+ (while (file-exists-p newname)
+ (setq newprefix (concat newprefix "x"))
+ (setq newname (make-temp-name newprefix)))
+ newname))
+
+;; Written by Per Abrahamsen <amanda@iesd.auc.dk>.
+
+(defun nnmail-split-fancy ()
+ "Fancy splitting method.
+See the documentation for the variable `nnmail-split-fancy' for documentation."
+ (nnmail-split-it nnmail-split-fancy))
+
+(defvar nnmail-split-cache nil)
+;; Alist of split expresions their equivalent regexps.
+
+(defun nnmail-split-it (split)
+ ;; Return a list of groups matching SPLIT.
+ (cond ((stringp split)
+ ;; A group.
+ (list split))
+ ((eq (car split) '&)
+ (apply 'nconc (mapcar 'nnmail-split-it (cdr split))))
+ ((eq (car split) '|)
+ (let (done)
+ (while (and (not done) (cdr split))
+ (setq split (cdr split)
+ done (nnmail-split-it (car split))))
+ done)) ((assq split nnmail-split-cache)
+ ;; A compiled match expression.
+ (goto-char (point-max))
+ (if (re-search-backward (cdr (assq split nnmail-split-cache)) nil t)
+ (nnmail-split-it (nth 2 split))))
+ (t
+ ;; An uncompiled match.
+ (let* ((field (nth 0 split))
+ (value (nth 1 split))
+ (regexp (concat "^\\("
+ (if (symbolp field)
+ (cdr (assq field
+ nnmail-split-abbrev-alist))
+ field)
+ "\\):.*\\<\\("
+ (if (symbolp value)
+ (cdr (assq value
+ nnmail-split-abbrev-alist))
+ value)
+ "\\>\\)")))
+ (setq nnmail-split-cache
+ (cons (cons split regexp) nnmail-split-cache))
+ (goto-char (point-max))
+ (if (re-search-backward regexp nil t)
+ (nnmail-split-it (nth 2 split)))))))
+
+;; Get a list of spool files to read.
+(defun nnmail-get-spool-files (&optional group)
+ (if (null nnmail-spool-file)
+ ;; No spool file whatsoever.
+ nil)
+ (let* ((procmails
+ ;; If procmail is used to get incoming mail, the files
+ ;; are stored in this directory.
+ (and (file-exists-p nnmail-procmail-directory)
+ (directory-files
+ nnmail-procmail-directory
+ t (concat (if group group "")
+ nnmail-procmail-suffix "$") t)))
+ (p procmails))
+ ;; Remove any directories that inadvertantly match the procmail
+ ;; suffix, which might happen if the suffix is "".
+ (while p
+ (and (or (file-directory-p (car p))
+ (file-symlink-p (car p)))
+ (setq procmails (delete (car p) procmails)))
+ (setq p (cdr p)))
+ (cond ((listp nnmail-spool-file)
+ (append nnmail-spool-file procmails))
+ ((stringp nnmail-spool-file)
+ (cons nnmail-spool-file procmails))
+ (t
+ procmails))))
+
+;; Activate a backend only if it isn't already activated.
+;; If FORCE, re-read the active file even if the backend is
+;; already activated.
+(defun nnmail-activate (backend &optional force)
+ (let (file timestamp file-time)
+ (if (or (not (symbol-value (intern (format "%s-group-alist" backend))))
+ force
+ (and (setq file (condition-case ()
+ (symbol-value (intern (format "%s-active-file"
+ backend)))
+ (error nil)))
+ (setq file-time (nth 5 (file-attributes file)))
+ (or (not
+ (setq timestamp
+ (condition-case ()
+ (symbol-value (intern
+ (format "%s-active-timestamp"
+ backend)))
+ (error 'none))))
+ (not (consp timestamp))
+ (equal timestamp '(0 0))
+ (> (nth 0 file-time) (nth 0 timestamp))
+ (and (= (nth 0 file-time) (nth 0 timestamp))
+ (> (nth 1 file-time) (nth 1 timestamp))))))
+ (save-excursion
+ (or (eq timestamp 'none)
+ (set (intern (format "%s-active-timestamp" backend))
+ (current-time)))
+ (funcall (intern (format "%s-request-list" backend)))
+ (set (intern (format "%s-group-alist" backend))
+ (nnmail-get-active))))
+ t))
+
+(defun nnmail-message-id ()
+ (concat "<" (nnmail-unique-id) "@totally-fudged-out-message-id>"))
+
+(defvar nnmail-unique-id-char nil)
+
+(defun nnmail-number-base36 (num len)
+ (if (if (< len 0) (<= num 0) (= len 0))
+ ""
+ (concat (nnmail-number-base36 (/ num 36) (1- len))
+ (char-to-string (aref "zyxwvutsrqponmlkjihgfedcba9876543210"
+ (% num 36))))))
+
+(defun nnmail-unique-id ()
+ (setq nnmail-unique-id-char
+ (% (1+ (or nnmail-unique-id-char (logand (random t) (1- (lsh 1 20)))))
+ ;; (current-time) returns 16-bit ints,
+ ;; and 2^16*25 just fits into 4 digits i base 36.
+ (* 25 25)))
+ (let ((tm (if (fboundp 'current-time)
+ (current-time) '(12191 46742 287898))))
+ (concat
+ (nnmail-number-base36 (+ (car tm)
+ (lsh (% nnmail-unique-id-char 25) 16)) 4)
+ (nnmail-number-base36 (+ (nth 1 tm)
+ (lsh (/ nnmail-unique-id-char 25) 16)) 4))))
+
+;;;
+;;; nnmail duplicate handling
+;;;
+
+(defvar nnmail-cache-buffer nil)
+
+(defun nnmail-cache-open ()
+ (if (or (not nnmail-delete-duplicates)
+ (and nnmail-cache-buffer
+ (buffer-name nnmail-cache-buffer)))
+ () ; The buffer is open.
+ (save-excursion
+ (set-buffer
+ (setq nnmail-cache-buffer
+ (get-buffer-create " *nnmail message-id cache*")))
+ (buffer-disable-undo (current-buffer))
+ (and (file-exists-p nnmail-message-id-cache-file)
+ (insert-file-contents nnmail-message-id-cache-file))
+ (current-buffer))))
+
+(defun nnmail-cache-close ()
+ (if (or (not nnmail-cache-buffer)
+ (not nnmail-delete-duplicates)
+ (not (buffer-name nnmail-cache-buffer))
+ (not (buffer-modified-p nnmail-cache-buffer)))
+ () ; The buffer is closed.
+ (save-excursion
+ (set-buffer nnmail-cache-buffer)
+ ;; Weed out the excess number of Message-IDs.
+ (goto-char (point-max))
+ (and (search-backward "\n" nil t nnmail-message-id-cache-length)
+ (progn
+ (beginning-of-line)
+ (delete-region (point-min) (point))))
+ ;; Save the buffer.
+ (or (file-exists-p (file-name-directory nnmail-message-id-cache-file))
+ (make-directory (file-name-directory nnmail-message-id-cache-file)
+ t))
+ (write-region (point-min) (point-max)
+ nnmail-message-id-cache-file nil 'silent)
+ (set-buffer-modified-p nil))))
+
+(defun nnmail-cache-insert (id)
+ (and nnmail-delete-duplicates
+ (save-excursion
+ (set-buffer nnmail-cache-buffer)
+ (goto-char (point-max))
+ (insert id "\n"))))
+
+(defun nnmail-cache-id-exists-p (id)
+ (and nnmail-delete-duplicates
+ (save-excursion
+ (set-buffer nnmail-cache-buffer)
+ (goto-char (point-max))
+ (search-backward id nil t))))
+
+
+(provide 'nnmail)
+
+;;; nnmail.el ends here
diff --git a/lisp/nnmbox.el b/lisp/nnmbox.el
new file mode 100644
index 00000000000..500bffa9591
--- /dev/null
+++ b/lisp/nnmbox.el
@@ -0,0 +1,508 @@
+;;; nnmbox.el --- mail mbox access for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; For an overview of what the interface functions do, please see the
+;; Gnus sources.
+
+;;; Code:
+
+(require 'nnheader)
+(require 'rmail)
+(require 'nnmail)
+
+(defvar nnmbox-mbox-file (expand-file-name "~/mbox")
+ "The name of the mail box file in the user's home directory.")
+
+(defvar nnmbox-active-file (expand-file-name "~/.mbox-active")
+ "The name of the active file for the mail box.")
+
+(defvar nnmbox-get-new-mail t
+ "If non-nil, nnmbox will check the incoming mail file and split the mail.")
+
+(defvar nnmbox-prepare-save-mail-hook nil
+ "Hook run narrowed to an article before saving.")
+
+
+
+(defconst nnmbox-version "nnmbox 1.0"
+ "nnmbox version.")
+
+(defvar nnmbox-current-group nil
+ "Current nnmbox news group directory.")
+
+(defconst nnmbox-mbox-buffer nil)
+
+(defvar nnmbox-status-string "")
+
+(defvar nnmbox-group-alist nil)
+(defvar nnmbox-active-timestamp nil)
+
+
+
+(defvar nnmbox-current-server nil)
+(defvar nnmbox-server-alist nil)
+(defvar nnmbox-server-variables
+ (list
+ (list 'nnmbox-mbox-file nnmbox-mbox-file)
+ (list 'nnmbox-active-file nnmbox-active-file)
+ (list 'nnmbox-get-new-mail nnmbox-get-new-mail)
+ '(nnmbox-current-group nil)
+ '(nnmbox-status-string "")
+ '(nnmbox-group-alist nil)))
+
+
+
+;;; Interface functions
+
+(defun nnmbox-retrieve-headers (sequence &optional newsgroup server)
+ (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)
+ (if (stringp (car sequence))
+ 'headers
+ (while sequence
+ (setq article (car sequence))
+ (setq art-string (nnmbox-article-string article))
+ (set-buffer nnmbox-mbox-buffer)
+ (if (or (search-forward art-string nil t)
+ (progn (goto-char (point-min))
+ (search-forward art-string nil t)))
+ (progn
+ (setq start
+ (save-excursion
+ (re-search-backward
+ (concat "^" rmail-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))
+ gnus-verbose-backends
+ (message "nnmbox: Receiving headers... %d%%"
+ (/ (* count 100) number))))
+
+ (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)
+ gnus-verbose-backends
+ (message "nnmbox: Receiving headers...done"))
+
+ ;; Fold continuation lines.
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ 'headers))))
+
+(defun nnmbox-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (equal server nnmbox-current-server)
+ t
+ (if nnmbox-current-server
+ (setq nnmbox-server-alist
+ (cons (list nnmbox-current-server
+ (nnheader-save-variables nnmbox-server-variables))
+ nnmbox-server-alist)))
+ (let ((state (assoc server nnmbox-server-alist)))
+ (if state
+ (progn
+ (nnheader-restore-variables (nth 1 state))
+ (setq nnmbox-server-alist (delq state nnmbox-server-alist)))
+ (nnheader-set-init-variables nnmbox-server-variables defs)))
+ (setq nnmbox-current-server server)))
+
+(defun nnmbox-close-server (&optional server)
+ t)
+
+(defun nnmbox-server-opened (&optional server)
+ (and (equal server nnmbox-current-server)
+ nnmbox-mbox-buffer
+ (buffer-name nnmbox-mbox-buffer)
+ nntp-server-buffer
+ (buffer-name nntp-server-buffer)))
+
+(defun nnmbox-status-message (&optional server)
+ nnmbox-status-string)
+
+(defun nnmbox-request-article (article &optional newsgroup server buffer)
+ (nnmbox-possibly-change-newsgroup newsgroup)
+ (if (stringp article)
+ nil
+ (save-excursion
+ (set-buffer nnmbox-mbox-buffer)
+ (goto-char (point-min))
+ (if (search-forward (nnmbox-article-string article) nil t)
+ (let (start stop)
+ (re-search-backward (concat "^" rmail-unix-mail-delimiter) nil t)
+ (setq start (point))
+ (forward-line 1)
+ (or (and (re-search-forward
+ (concat "^" rmail-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))
+ t))))))
+
+(defun nnmbox-request-group (group &optional server dont-check)
+ (save-excursion
+ (if (nnmbox-possibly-change-newsgroup group)
+ (if dont-check
+ t
+ (nnmbox-get-new-mail group)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let ((active (assoc group nnmbox-group-alist)))
+ (insert (format "211 %d %d %d %s\n"
+ (1+ (- (cdr (car (cdr active)))
+ (car (car (cdr active)))))
+ (car (car (cdr active)))
+ (cdr (car (cdr active)))
+ (car active))))
+ t)))))
+
+(defun nnmbox-close-group (group &optional server)
+ t)
+
+(defun nnmbox-request-list (&optional server)
+ (if server (nnmbox-get-new-mail))
+ (save-excursion
+ (or (nnmail-find-file nnmbox-active-file)
+ (progn
+ (setq nnmbox-group-alist (nnmail-get-active))
+ (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
+ (nnmail-find-file nnmbox-active-file)))))
+
+(defun nnmbox-request-newgroups (date &optional server)
+ (nnmbox-request-list server))
+
+(defun nnmbox-request-list-newsgroups (&optional server)
+ (setq nnmbox-status-string "nnmbox: LIST NEWSGROUPS is not implemented.")
+ nil)
+
+(defun nnmbox-request-post (&optional server)
+ (mail-send-and-exit nil))
+
+(defalias 'nnmbox-request-post-buffer 'nnmail-request-post-buffer)
+
+(defun nnmbox-request-expire-articles
+ (articles newsgroup &optional server force)
+ (nnmbox-possibly-change-newsgroup newsgroup)
+ (let* ((days (or (and nnmail-expiry-wait-function
+ (funcall nnmail-expiry-wait-function newsgroup))
+ nnmail-expiry-wait))
+ (is-old t)
+ rest)
+ (nnmail-activate 'nnmbox)
+
+ (save-excursion
+ (set-buffer nnmbox-mbox-buffer)
+ (while (and articles is-old)
+ (goto-char (point-min))
+ (if (search-forward (nnmbox-article-string (car articles)) nil t)
+ (if (or force
+ (setq is-old
+ (> (nnmail-days-between
+ (current-time-string)
+ (buffer-substring
+ (point) (progn (end-of-line) (point))))
+ days)))
+ (progn
+ (and gnus-verbose-backends
+ (message "Deleting article %s..." (car articles)))
+ (nnmbox-delete-mail))
+ (setq rest (cons (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))))
+
+(defun nnmbox-request-move-article
+ (article group server accept-form &optional last)
+ (nnmbox-possibly-change-newsgroup group)
+ (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
+ (set-buffer nnmbox-mbox-buffer)
+ (goto-char (point-min))
+ (if (search-forward (nnmbox-article-string article) nil t)
+ (nnmbox-delete-mail))
+ (and last (save-buffer))))
+ result))
+
+(defun nnmbox-request-accept-article (group &optional last)
+ (let ((buf (current-buffer))
+ result)
+ (goto-char (point-min))
+ (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))))
+ (setq result (nnmbox-save-mail (and (stringp group) group))))
+ (save-excursion
+ (set-buffer nnmbox-mbox-buffer)
+ (insert-buffer-substring buf)
+ (and last (save-buffer))
+ result)
+ (nnmail-save-active nnmbox-group-alist nnmbox-active-file))
+ (car result)))
+
+(defun 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)))
+
+
+;;; 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
+;; delimeter 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 "^" rmail-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 "^" rmail-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.
+ (if (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
+ (delete-region (point-min) (point-max))))))
+
+(defun nnmbox-possibly-change-newsgroup (newsgroup)
+ (if (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))))
+ (if (not nnmbox-group-alist)
+ (nnmail-activate 'nnmbox))
+ (if newsgroup
+ (if (assoc newsgroup nnmbox-group-alist)
+ (setq nnmbox-current-group newsgroup))))
+
+(defun nnmbox-article-string (article)
+ (concat "\nX-Gnus-Newsgroup: " nnmbox-current-group ":"
+ (int-to-string article) " "))
+
+(defun nnmbox-save-mail (&optional group)
+ "Called narrowed to an article."
+ (let* ((nnmail-split-methods
+ (if group (list (list group "")) nnmail-split-methods))
+ (group-art (nreverse (nnmail-article-group 'nnmbox-active-number))))
+ (nnmail-insert-lines)
+ (nnmail-insert-xref group-art)
+ (nnmbox-insert-newsgroup-line group-art)
+ (run-hooks 'nnml-prepare-save-mail-hook)
+ group-art))
+
+(defun nnmbox-insert-newsgroup-line (group-art)
+ (save-excursion
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (progn
+ (forward-char -1)
+ (while group-art
+ (insert (format "X-Gnus-Newsgroup: %s:%d %s\n"
+ (car (car group-art)) (cdr (car 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 (car (cdr (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...
+ (setq nnmbox-group-alist (cons (list group (setq active (cons 1 1)))
+ nnmbox-group-alist)))
+ (cdr active)))
+
+(defun nnmbox-read-mbox ()
+ (nnmail-activate 'nnmbox)
+ (if (not (file-exists-p nnmbox-mbox-file))
+ (write-region 1 1 nnmbox-mbox-file t 'nomesg))
+ (if (and nnmbox-mbox-buffer
+ (buffer-name nnmbox-mbox-buffer)
+ (save-excursion
+ (set-buffer nnmbox-mbox-buffer)
+ (= (buffer-size) (nth 7 (file-attributes nnmbox-mbox-file)))))
+ ()
+ (save-excursion
+ (let ((delim (concat "^" rmail-unix-mail-delimiter))
+ start end)
+ (set-buffer (setq nnmbox-mbox-buffer
+ (nnheader-find-file-noselect
+ nnmbox-mbox-file nil 'raw)))
+ (buffer-disable-undo (current-buffer))
+ (goto-char (point-min))
+ (while (re-search-forward delim nil t)
+ (setq start (match-beginning 0))
+ (if (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))))
+ (goto-char end))))))
+
+(defun nnmbox-get-new-mail (&optional group)
+ "Read new incoming mail."
+ (let* ((spools (nnmail-get-spool-files group))
+ (group-in group)
+ incoming incomings)
+ (nnmbox-read-mbox)
+ (if (or (not nnmbox-get-new-mail) (not nnmail-spool-file))
+ ()
+ ;; We go through all the existing spool files and split the
+ ;; mail from each.
+ (while spools
+ (and
+ (file-exists-p (car spools))
+ (> (nth 7 (file-attributes (car spools))) 0)
+ (progn
+ (and gnus-verbose-backends
+ (message "nnmbox: Reading incoming mail..."))
+ (if (not (setq incoming
+ (nnmail-move-inbox
+ (car spools)
+ (concat nnmbox-mbox-file "-Incoming"))))
+ ()
+ (setq incomings (cons incoming incomings))
+ (save-excursion
+ (setq group (nnmail-get-split-group (car spools) group-in))
+ (let ((in-buf (nnmail-split-incoming
+ incoming 'nnmbox-save-mail t group)))
+ (set-buffer nnmbox-mbox-buffer)
+ (goto-char (point-max))
+ (insert-buffer-substring in-buf)
+ (kill-buffer in-buf))))))
+ (setq spools (cdr spools)))
+ ;; If we did indeed read any incoming spools, we save all info.
+ (and (buffer-modified-p nnmbox-mbox-buffer)
+ (save-excursion
+ (nnmail-save-active nnmbox-group-alist nnmbox-active-file)
+ (set-buffer nnmbox-mbox-buffer)
+ (save-buffer)))
+ (if incomings (run-hooks 'nnmail-read-incoming-hook))
+ (while incomings
+ (setq incoming (car incomings))
+ (and nnmail-delete-incoming
+ (file-exists-p incoming)
+ (file-writable-p incoming)
+ (delete-file incoming))
+ (setq incomings (cdr incomings))))))
+
+
+(provide 'nnmbox)
+
+;;; nnmbox.el ends here
diff --git a/lisp/nnmh.el b/lisp/nnmh.el
new file mode 100644
index 00000000000..2a8664ba00a
--- /dev/null
+++ b/lisp/nnmh.el
@@ -0,0 +1,516 @@
+;;; nnmh.el --- mhspool access for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, 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 'rmail)
+(require 'nnmail)
+(require 'gnus)
+
+(defvar nnmh-directory "~/Mail/"
+ "*Mail spool directory.")
+
+(defvar nnmh-get-new-mail t
+ "*If non-nil, nnmh will check the incoming mail file and split the mail.")
+
+(defvar nnmh-prepare-save-mail-hook nil
+ "*Hook run narrowed to an article before saving.")
+
+(defvar 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.")
+
+(defvar nnmh-current-directory nil
+ "Current news group directory.")
+
+(defvar nnmh-status-string "")
+(defvar nnmh-group-alist nil)
+
+
+
+(defvar nnmh-current-server nil)
+(defvar nnmh-server-alist nil)
+(defvar nnmh-server-variables
+ (list
+ (list 'nnmh-directory nnmh-directory)
+ (list 'nnmh-get-new-mail nnmh-get-new-mail)
+ '(nnmh-current-directory nil)
+ '(nnmh-status-string "")
+ '(nnmh-group-alist)))
+
+
+
+;;; Interface functions.
+
+(defun nnmh-retrieve-headers (sequence &optional newsgroup server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let* ((file nil)
+ (number (length sequence))
+ (large (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)))
+ (count 0)
+ beg article)
+ (nnmh-possibly-change-directory newsgroup)
+ (if (stringp (car sequence))
+ 'headers
+ (while sequence
+ (setq article (car sequence))
+ (setq file
+ (concat nnmh-current-directory (int-to-string article)))
+ (if (and (file-exists-p file)
+ (not (file-directory-p file)))
+ (progn
+ (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 large
+ (zerop (% count 20))
+ (message "nnmh: Receiving headers... %d%%"
+ (/ (* count 100) number))))
+
+ (and large (message "nnmh: Receiving headers...done"))
+
+ ;; Fold continuation lines.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ 'headers))))
+
+(defun nnmh-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (equal server nnmh-current-server)
+ t
+ (if nnmh-current-server
+ (setq nnmh-server-alist
+ (cons (list nnmh-current-server
+ (nnheader-save-variables nnmh-server-variables))
+ nnmh-server-alist)))
+ (let ((state (assoc server nnmh-server-alist)))
+ (if state
+ (progn
+ (nnheader-restore-variables (nth 1 state))
+ (setq nnmh-server-alist (delq state nnmh-server-alist)))
+ (nnheader-set-init-variables nnmh-server-variables defs)))
+ (setq nnmh-current-server server)))
+
+(defun nnmh-close-server (&optional server)
+ t)
+
+(defun nnmh-server-opened (&optional server)
+ (and (equal server nnmh-current-server)
+ nntp-server-buffer
+ (buffer-name nntp-server-buffer)))
+
+(defun nnmh-status-message (&optional server)
+ nnmh-status-string)
+
+(defun nnmh-request-article (id &optional newsgroup server buffer)
+ (nnmh-possibly-change-directory newsgroup)
+ (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)))))
+
+(defun nnmh-request-group (group &optional server dont-check)
+ (and nnmh-get-new-mail (or dont-check (nnmh-get-new-mail group)))
+ (let ((pathname (nnmh-article-pathname group nnmh-directory))
+ dir)
+ (if (file-directory-p pathname)
+ (progn
+ (setq nnmh-current-directory pathname)
+ (and nnmh-get-new-mail
+ nnmh-be-safe
+ (nnmh-update-gnus-unreads group))
+ (or dont-check
+ (progn
+ (setq dir
+ (sort
+ (mapcar
+ (function
+ (lambda (name)
+ (string-to-int name)))
+ (directory-files pathname nil "^[0-9]+$" t))
+ '<))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (if dir
+ (insert (format "211 %d %d %d %s\n" (length dir)
+ (car dir)
+ (progn (while (cdr dir)
+ (setq dir (cdr dir)))
+ (car dir))
+ group))
+ (insert (format "211 0 1 0 %s\n" group))))))
+ t)
+ (setq nnmh-status-string "No such group")
+ nil)))
+
+(defun nnmh-request-list (&optional server dir)
+ (or dir
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (setq dir (file-truename (file-name-as-directory nnmh-directory)))))
+ (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))))
+ (while dirs
+ (if (and (not (string-match "/\\.\\.?$" (car dirs)))
+ (file-directory-p (car dirs))
+ (file-readable-p (car dirs)))
+ (nnmh-request-list nil (car dirs)))
+ (setq dirs (cdr dirs))))
+ ;; For each directory, generate an active file line.
+ (if (not (string= (expand-file-name nnmh-directory) dir))
+ (let ((files (mapcar
+ (lambda (name) (string-to-int name))
+ (directory-files dir nil "^[0-9]+$" t))))
+ (if (null files)
+ ()
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-max))
+ (insert
+ (format
+ "%s %d %d y\n"
+ (progn
+ (string-match
+ (file-truename (file-name-as-directory
+ (expand-file-name nnmh-directory))) dir)
+ (nnmail-replace-chars-in-string
+ (substring dir (match-end 0)) ?/ ?.))
+ (apply (function max) files)
+ (apply (function min) files)))))))
+ (setq nnmh-group-alist (nnmail-get-active))
+ (and server nnmh-get-new-mail (nnmh-get-new-mail))
+ t)
+
+(defun nnmh-request-newgroups (date &optional server)
+ (nnmh-request-list server))
+
+(defun nnmh-request-post (&optional server)
+ (mail-send-and-exit nil))
+
+(defalias 'nnmh-request-post-buffer 'nnmail-request-post-buffer)
+
+(defun nnmh-request-expire-articles (articles newsgroup &optional server force)
+ (nnmh-possibly-change-directory newsgroup)
+ (let* ((days (or (and nnmail-expiry-wait-function
+ (funcall nnmail-expiry-wait-function newsgroup))
+ nnmail-expiry-wait))
+ (active-articles
+ (mapcar
+ (function
+ (lambda (name)
+ (string-to-int name)))
+ (directory-files nnmh-current-directory nil "^[0-9]+$" t)))
+ (max-article (and active-articles (apply 'max active-articles)))
+ (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))))
+ (if (setq mod-time (nth 5 (file-attributes article)))
+ (if (and (or (not nnmail-keep-last-article)
+ (not max-article)
+ (not (= (car articles) max-article)))
+ (not (equal mod-time '(0 0)))
+ (or force
+ (setq is-old
+ (> (nnmail-days-between
+ (current-time-string)
+ (current-time-string mod-time))
+ days))))
+ (progn
+ (and gnus-verbose-backends
+ (message "Deleting article %s..." article))
+ (condition-case ()
+ (delete-file article)
+ (file-error
+ (setq rest (cons (car articles) rest)))))
+ (setq rest (cons (car articles) rest))))
+ (setq articles (cdr articles)))
+ (message "")
+ (nconc rest articles)))
+
+(defun nnmh-close-group (group &optional server)
+ t)
+
+(defun nnmh-request-move-article
+ (article group server accept-form &optional last)
+ (let ((buf (get-buffer-create " *nnmh move*"))
+ result)
+ (and
+ (nnmh-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)
+ (condition-case ()
+ (delete-file (concat nnmh-current-directory
+ (int-to-string article)))
+ (file-error nil)))
+ result))
+
+(defun nnmh-request-accept-article (group &optional last)
+ (if (stringp group)
+ (and
+ (nnmail-activate 'nnmh)
+ ;; We trick the choosing function into believing that only one
+ ;; group is availiable.
+ (let ((nnmail-split-methods (list (list group ""))))
+ (car (nnmh-save-mail))))
+ (and
+ (nnmail-activate 'nnmh)
+ (car (nnmh-save-mail)))))
+
+(defun nnmh-request-replace-article (article group buffer)
+ (nnmh-possibly-change-directory group)
+ (save-excursion
+ (set-buffer buffer)
+ (nnmh-possibly-create-directory group)
+ (condition-case ()
+ (progn
+ (write-region (point-min) (point-max)
+ (concat nnmh-current-directory (int-to-string article))
+ nil (if gnus-verbose-backends nil 'nomesg))
+ t)
+ (error nil))))
+
+
+;;; Internal functions.
+
+(defun nnmh-possibly-change-directory (newsgroup)
+ (if newsgroup
+ (let ((pathname (nnmh-article-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 (nnmh-article-pathname group nnmh-directory))
+ (while (not (file-directory-p dir))
+ (setq dirs (cons dir dirs))
+ (setq dir (file-name-directory (directory-file-name dir))))
+ (while dirs
+ (if (make-directory (directory-file-name (car dirs)))
+ (error "Could not create directory %s" (car dirs)))
+ (and gnus-verbose-backends
+ (message "Creating mail directory %s" (car dirs)))
+ (setq dirs (cdr dirs)))))
+
+(defun nnmh-save-mail ()
+ "Called narrowed to an article."
+ (let ((group-art (nreverse (nnmail-article-group 'nnmh-active-number))))
+ (nnmail-insert-lines)
+ (nnmail-insert-xref group-art)
+ (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 (car (car ga)))
+ (let ((file (concat (nnmh-article-pathname
+ (car (car ga)) nnmh-directory)
+ (int-to-string (cdr (car ga))))))
+ (if first
+ ;; It was already saved, so we just make a hard link.
+ (add-name-to-file first file t)
+ ;; Save the article.
+ (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 (car (cdr (assoc group nnmh-group-alist)))))
+ ;; The group wasn't known to nnmh, so we just create an active
+ ;; entry for it.
+ (or active
+ (progn
+ (setq active (cons 1 0))
+ (setq nnmh-group-alist (cons (list group active) nnmh-group-alist))))
+ (setcdr active (1+ (cdr active)))
+ (while (file-exists-p
+ (concat (nnmh-article-pathname group nnmh-directory)
+ (int-to-string (cdr active))))
+ (setcdr active (1+ (cdr active))))
+ (cdr active)))
+
+(defun nnmh-article-pathname (group mail-dir)
+ "Make pathname for GROUP."
+ (let ((mail-dir (file-name-as-directory (expand-file-name mail-dir))))
+ (if (file-directory-p (concat mail-dir group))
+ (concat mail-dir group "/")
+ (concat mail-dir (nnmail-replace-chars-in-string group ?. ?/) "/"))))
+
+(defun nnmh-get-new-mail (&optional group)
+ "Read new incoming mail."
+ (let* ((spools (nnmail-get-spool-files group))
+ (group-in group)
+ incoming incomings)
+ (if (or (not nnmh-get-new-mail) (not nnmail-spool-file))
+ ()
+ ;; We first activate all the groups.
+ (or nnmh-group-alist
+ (nnmh-request-list))
+ ;; The we go through all the existing spool files and split the
+ ;; mail from each.
+ (while spools
+ (and
+ (file-exists-p (car spools))
+ (> (nth 7 (file-attributes (car spools))) 0)
+ (progn
+ (and gnus-verbose-backends
+ (message "nnmh: Reading incoming mail..."))
+ (if (not (setq incoming
+ (nnmail-move-inbox
+ (car spools)
+ (concat (file-name-as-directory nnmh-directory)
+ "Incoming"))))
+ ()
+ (setq incomings (cons incoming incomings))
+ (setq group (nnmail-get-split-group (car spools) group-in))
+ (nnmail-split-incoming incoming 'nnmh-save-mail nil group))))
+ (setq spools (cdr spools)))
+ ;; If we did indeed read any incoming spools, we save all info.
+ (if incoming
+ (message "nnmh: Reading incoming mail...done"))
+ (while incomings
+ (setq incoming (car incomings))
+ (and nnmail-delete-incoming
+ (file-exists-p incoming)
+ (file-writable-p incoming)
+ (delete-file incoming))
+ (setq incomings (cdr incomings))))))
+
+
+(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.
+ (if (file-exists-p nnmh-file)
+ (setq articles
+ (let (nnmh-newsgroup-articles)
+ (condition-case nil (load nnmh-file nil t t) (error nil))
+ nnmh-newsgroup-articles)))
+ ;; Add all new articles to the `new' list.
+ (let ((art files))
+ (while art
+ (if (not (assq (car art) articles)) (setq new (cons (car art) new)))
+ (setq art (cdr art))))
+ ;; Remove all deleted articles.
+ (let ((art articles))
+ (while art
+ (if (not (memq (car (car art)) files))
+ (setq articles (delq (car art) articles)))
+ (setq art (cdr art))))
+ ;; Check whether the highest-numbered articles really are the ones
+ ;; that Gnus thinks they are by looking at the time-stamps.
+ (let ((art articles))
+ (while (and art
+ (not (equal
+ (nth 5 (file-attributes
+ (concat dir (int-to-string (car (car art))))))
+ (cdr (car art)))))
+ (setq articles (delq (car art) articles))
+ (setq new (cons (car (car art)) new))
+ (setq art (cdr art))))
+ ;; Go through all the new articles and add them, and their
+ ;; time-stamps to the list.
+ (let ((n new))
+ (while n
+ (setq articles
+ (cons (cons
+ (car n)
+ (nth 5 (file-attributes
+ (concat dir (int-to-string (car n))))))
+ articles))
+ (setq n (cdr n))))
+ ;; Make Gnus mark all new articles as unread.
+ (or (zerop (length 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.
+ (save-excursion
+ (set-buffer (get-buffer-create "*nnmh out*"))
+ (insert ";; Gnus article active file for " group "\n\n")
+ (insert "(setq nnmh-newsgroup-articles '")
+ (insert (prin1-to-string articles) ")\n")
+ (write-region (point-min) (point-max) nnmh-file nil 'nomesg)
+ (kill-buffer (current-buffer)))))
+
+(provide 'nnmh)
+
+;;; nnmh.el ends here
diff --git a/lisp/nnml.el b/lisp/nnml.el
new file mode 100644
index 00000000000..585a0c71558
--- /dev/null
+++ b/lisp/nnml.el
@@ -0,0 +1,701 @@
+;;; nnml.el --- mail spool access for Gnus
+;; Copyright (C) 1995 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, 675 Mass Ave, Cambridge, MA 02139, 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)
+
+(defvar nnml-directory "~/Mail/"
+ "Mail spool directory.")
+
+(defvar nnml-active-file (concat nnml-directory "active")
+ "Mail active file.")
+
+(defvar nnml-newsgroups-file (concat nnml-directory "newsgroups")
+ "Mail newsgroups description file.")
+
+(defvar nnml-get-new-mail t
+ "If non-nil, nnml will check the incoming mail file and split the mail.")
+
+(defvar 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.")
+
+(defvar nnml-prepare-save-mail-hook nil
+ "Hook run narrowed to an article before saving.")
+
+
+
+(defconst nnml-version "nnml 1.0"
+ "nnml version.")
+
+(defvar nnml-nov-file-name ".overview")
+
+(defvar nnml-current-directory nil)
+(defvar nnml-status-string "")
+(defvar nnml-nov-buffer-alist nil)
+(defvar nnml-group-alist nil)
+(defvar nnml-active-timestamp nil)
+
+
+
+;; Server variables.
+
+(defvar nnml-current-server nil)
+(defvar nnml-server-alist nil)
+(defvar nnml-server-variables
+ (list
+ (list 'nnml-directory nnml-directory)
+ (list 'nnml-active-file nnml-active-file)
+ (list 'nnml-newsgroups-file nnml-newsgroups-file)
+ (list 'nnml-get-new-mail nnml-get-new-mail)
+ (list 'nnml-nov-is-evil nnml-nov-is-evil)
+ (list 'nnml-nov-file-name nnml-nov-file-name)
+ '(nnml-current-directory nil)
+ '(nnml-status-string "")
+ '(nnml-nov-buffer-alist nil)
+ '(nnml-group-alist nil)
+ '(nnml-active-timestamp nil)))
+
+
+
+;;; Interface functions.
+
+(defun nnml-retrieve-headers (sequence &optional newsgroup 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
+ (nnml-possibly-change-directory newsgroup)
+ (if (nnml-retrieve-headers-with-nov sequence)
+ 'nov
+ (while sequence
+ (setq article (car sequence))
+ (setq file
+ (concat nnml-current-directory (int-to-string article)))
+ (if (and (file-exists-p file)
+ (not (file-directory-p file)))
+ (progn
+ (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))
+ gnus-verbose-backends
+ (message "nnml: Receiving headers... %d%%"
+ (/ (* count 100) number))))
+
+ (and (numberp nnmail-large-newsgroup)
+ (> number nnmail-large-newsgroup)
+ gnus-verbose-backends
+ (message "nnml: Receiving headers...done"))
+
+ ;; Fold continuation lines.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ 'headers)))))
+
+(defun nnml-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (equal server nnml-current-server)
+ t
+ (if nnml-current-server
+ (setq nnml-server-alist
+ (cons (list nnml-current-server
+ (nnheader-save-variables nnml-server-variables))
+ nnml-server-alist)))
+ (let ((state (assoc server nnml-server-alist)))
+ (if state
+ (progn
+ (nnheader-restore-variables (nth 1 state))
+ (setq nnml-server-alist (delq state nnml-server-alist)))
+ (nnheader-set-init-variables nnml-server-variables defs)))
+ (setq nnml-current-server server)))
+
+(defun nnml-close-server (&optional server)
+ t)
+
+(defun nnml-server-opened (&optional server)
+ (and (equal server nnml-current-server)
+ nntp-server-buffer
+ (buffer-name nntp-server-buffer)))
+
+(defun nnml-status-message (&optional server)
+ nnml-status-string)
+
+(defun nnml-request-article (id &optional newsgroup server buffer)
+ (nnml-possibly-change-directory newsgroup)
+ (let ((file (if (stringp id)
+ nil
+ (concat nnml-current-directory (int-to-string id))))
+ (nntp-server-buffer (or buffer nntp-server-buffer)))
+ (if (and (stringp file)
+ (file-exists-p file)
+ (not (file-directory-p file)))
+ (save-excursion
+ (nnmail-find-file file)))))
+
+(defun nnml-request-group (group &optional server dont-check)
+ (if (not (nnml-possibly-change-directory group))
+ (progn
+ (setq nnml-status-string "Invalid group (no such directory)")
+ nil)
+ (if dont-check
+ t
+ (nnml-get-new-mail group)
+ (nnmail-activate 'nnml)
+ (let ((active (nth 1 (assoc group nnml-group-alist))))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (if (not active)
+ ()
+ (insert (format "211 %d %d %d %s\n"
+ (max (1+ (- (cdr active) (car active))) 0)
+ (car active) (cdr active) group))
+ t))))))
+
+(defun nnml-close-group (group &optional server)
+ t)
+
+(defun nnml-request-close ()
+ (setq nnml-current-server nil)
+ (setq nnml-server-alist nil)
+ t)
+
+(defun nnml-request-create-group (group &optional server)
+ (nnmail-activate 'nnml)
+ (or (assoc group nnml-group-alist)
+ (let (active)
+ (setq nnml-group-alist (cons (list group (setq active (cons 1 0)))
+ nnml-group-alist))
+ (nnml-possibly-create-directory group)
+ (nnml-possibly-change-directory group)
+ (let ((articles (mapcar
+ (lambda (file)
+ (string-to-int file))
+ (directory-files
+ nnml-current-directory nil "^[0-9]+$"))))
+ (and articles
+ (progn
+ (setcar active (apply 'min articles))
+ (setcdr active (apply 'max articles)))))
+ (nnmail-save-active nnml-group-alist nnml-active-file)))
+ t)
+
+(defun nnml-request-list (&optional server)
+ (if server (nnml-get-new-mail))
+ (save-excursion
+ (nnmail-find-file nnml-active-file)
+ (setq nnml-group-alist (nnmail-get-active))))
+
+(defun nnml-request-newgroups (date &optional server)
+ (nnml-request-list server))
+
+(defun nnml-request-list-newsgroups (&optional server)
+ (save-excursion
+ (nnmail-find-file nnml-newsgroups-file)))
+
+(defun nnml-request-post (&optional server)
+ (mail-send-and-exit nil))
+
+(defalias 'nnml-request-post-buffer 'nnmail-request-post-buffer)
+
+(defun nnml-request-expire-articles (articles newsgroup &optional server force)
+ (nnml-possibly-change-directory newsgroup)
+ (let* ((days (or (and nnmail-expiry-wait-function
+ (funcall nnmail-expiry-wait-function newsgroup))
+ nnmail-expiry-wait))
+ (active-articles
+ (mapcar
+ (function
+ (lambda (name)
+ (string-to-int name)))
+ (directory-files nnml-current-directory nil "^[0-9]+$" t)))
+ (max-article (and active-articles (apply 'max active-articles)))
+ (is-old t)
+ article rest mod-time)
+ (nnmail-activate 'nnml)
+
+ (while (and articles is-old)
+ (setq article (concat nnml-current-directory
+ (int-to-string (car articles))))
+ (if (setq mod-time (nth 5 (file-attributes article)))
+ (if (and (or (not nnmail-keep-last-article)
+ (not max-article)
+ (not (= (car articles) max-article)))
+ (or force
+ (and (not (equal mod-time '(0 0)))
+ (setq is-old
+ (> (nnmail-days-between
+ (current-time-string)
+ (current-time-string mod-time))
+ days)))))
+ (progn
+ (and gnus-verbose-backends
+ (message "Deleting article %s..." article))
+ (condition-case ()
+ (delete-file article)
+ (file-error
+ (setq rest (cons (car articles) rest))))
+ (setq active-articles (delq (car articles) active-articles))
+ (nnml-nov-delete-article newsgroup (car articles)))
+ (setq rest (cons (car articles) rest))))
+ (setq articles (cdr articles)))
+ (let ((active (nth 1 (assoc newsgroup nnml-group-alist))))
+ (and active
+ (setcar active (or (and active-articles
+ (apply 'min active-articles))
+ 0)))
+ (nnmail-save-active nnml-group-alist nnml-active-file))
+ (nnml-save-nov)
+ (message "")
+ (nconc rest articles)))
+
+(defun nnml-request-move-article
+ (article group server accept-form &optional last)
+ (let ((buf (get-buffer-create " *nnml move*"))
+ result)
+ (and
+ (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
+ (condition-case ()
+ (delete-file (concat nnml-current-directory
+ (int-to-string article)))
+ (file-error nil))
+ (nnml-nov-delete-article group article)
+ (and last (nnml-save-nov))))
+ result))
+
+(defun nnml-request-accept-article (group &optional last)
+ (let (result)
+ (if (stringp group)
+ (and
+ (nnmail-activate 'nnml)
+ ;; We trick the choosing function into believing that only one
+ ;; group is availiable.
+ (let ((nnmail-split-methods (list (list group ""))))
+ (setq result (car (nnml-save-mail))))
+ (progn
+ (nnmail-save-active nnml-group-alist nnml-active-file)
+ (and last (nnml-save-nov))))
+ (and
+ (nnmail-activate 'nnml)
+ (setq result (car (nnml-save-mail)))
+ (progn
+ (nnmail-save-active nnml-group-alist nnml-active-file)
+ (and last (nnml-save-nov)))))
+ result))
+
+(defun nnml-request-replace-article (article group buffer)
+ (nnml-possibly-change-directory group)
+ (save-excursion
+ (set-buffer buffer)
+ (nnml-possibly-create-directory group)
+ (if (not (condition-case ()
+ (progn
+ (write-region (point-min) (point-max)
+ (concat nnml-current-directory
+ (int-to-string article))
+ nil (if gnus-verbose-backends nil 'nomesg))
+ t)
+ (error nil)))
+ ()
+ (let ((chars (nnmail-insert-lines))
+ (art (concat (int-to-string article) "\t"))
+ nov-line)
+ (setq nov-line (nnml-make-nov-line chars))
+ ;; 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)
+ (insert (int-to-string article) nov-line)
+ (nnml-save-nov)
+ t)))))
+
+
+
+;;; Internal functions
+
+(defun nnml-retrieve-headers-with-nov (articles)
+ (if (or gnus-nov-is-evil nnml-nov-is-evil)
+ nil
+ (let ((first (car articles))
+ (last (progn (while (cdr articles) (setq articles (cdr articles)))
+ (car articles)))
+ (nov (concat nnml-current-directory nnml-nov-file-name)))
+ (if (file-exists-p nov)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (insert-file-contents nov)
+ (goto-char (point-min))
+ (while (and (not (eobp)) (< first (read (current-buffer))))
+ (forward-line 1))
+ (beginning-of-line)
+ (if (not (eobp)) (delete-region 1 (point)))
+ (while (and (not (eobp)) (>= last (read (current-buffer))))
+ (forward-line 1))
+ (beginning-of-line)
+ (if (not (eobp)) (delete-region (point) (point-max)))
+ t)))))
+
+(defun nnml-possibly-change-directory (newsgroup &optional force)
+ (if newsgroup
+ (let ((pathname (nnmail-article-pathname newsgroup nnml-directory)))
+ (and (or force (file-directory-p pathname))
+ (setq nnml-current-directory pathname)))
+ t))
+
+(defun nnml-possibly-create-directory (group)
+ (let (dir dirs)
+ (setq dir (nnmail-article-pathname group nnml-directory))
+ (while (not (file-directory-p dir))
+ (setq dirs (cons dir dirs))
+ (setq dir (file-name-directory (directory-file-name dir))))
+ (while dirs
+ (make-directory (directory-file-name (car dirs)))
+ (and gnus-verbose-backends
+ (message "Creating mail directory %s" (car dirs)))
+ (setq dirs (cdr dirs)))))
+
+(defun nnml-save-mail ()
+ "Called narrowed to an article."
+ (let ((group-art (nreverse (nnmail-article-group 'nnml-active-number)))
+ chars nov-line)
+ (setq chars (nnmail-insert-lines))
+ (nnmail-insert-xref group-art)
+ (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 newsgroups it belongs in.
+ (let ((ga group-art)
+ first)
+ (while ga
+ (nnml-possibly-create-directory (car (car ga)))
+ (let ((file (concat (nnmail-article-pathname
+ (car (car ga)) nnml-directory)
+ (int-to-string (cdr (car ga))))))
+ (if first
+ ;; It was already saved, so we just make a hard link.
+ (add-name-to-file first file t)
+ ;; Save the article.
+ (write-region (point-min) (point-max) file nil
+ (if gnus-verbose-backends 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 nov-line (nnml-make-nov-line chars))
+ ;; Output the nov line to all nov databases that should have it.
+ (let ((ga group-art))
+ (while ga
+ (nnml-add-nov (car (car ga)) (cdr (car ga)) nov-line)
+ (setq ga (cdr ga))))
+ group-art))
+
+(defun nnml-active-number (group)
+ "Compute the next article number in GROUP."
+ (let ((active (car (cdr (assoc group nnml-group-alist)))))
+ ;; The group wasn't known to nnml, so we just create an active
+ ;; entry for it.
+ (or active
+ (progn
+ (setq active (cons 1 0))
+ (setq nnml-group-alist (cons (list group active) nnml-group-alist))))
+ (setcdr active (1+ (cdr active)))
+ (while (file-exists-p
+ (concat (nnmail-article-pathname group nnml-directory)
+ (int-to-string (cdr active))))
+ (setcdr active (1+ (cdr active))))
+ (cdr active)))
+
+(defun nnml-get-new-mail (&optional group)
+ "Read new incoming mail."
+ (let* ((spools (nnmail-get-spool-files group))
+ (group-in group)
+ incoming incomings)
+ (if (or (not nnml-get-new-mail) (not nnmail-spool-file))
+ ()
+ ;; We first activate all the groups.
+ (nnmail-activate 'nnml)
+ ;; The we go through all the existing spool files and split the
+ ;; mail from each.
+ (while spools
+ (and
+ (file-exists-p (car spools))
+ (> (nth 7 (file-attributes (car spools))) 0)
+ (progn
+ (and gnus-verbose-backends
+ (message "nnml: Reading incoming mail..."))
+ (if (not (setq incoming
+ (nnmail-move-inbox
+ (car spools) (concat nnml-directory "Incoming"))))
+ ()
+ (setq group (nnmail-get-split-group (car spools) group-in))
+ (nnmail-split-incoming incoming 'nnml-save-mail nil group)
+ (setq incomings (cons incoming incomings)))))
+ (setq spools (cdr spools)))
+ ;; If we did indeed read any incoming spools, we save all info.
+ (if incoming
+ (progn
+ (nnmail-save-active nnml-group-alist nnml-active-file)
+ (nnml-save-nov)
+ (run-hooks 'nnmail-read-incoming-hook)
+ (and gnus-verbose-backends
+ (message "nnml: Reading incoming mail...done"))))
+ (while incomings
+ (setq incoming (car incomings))
+ (and nnmail-delete-incoming
+ (file-exists-p incoming)
+ (file-writable-p incoming)
+ (delete-file incoming))
+ (setq incomings (cdr incomings))))))
+
+
+(defun nnml-add-nov (group article line)
+ "Add a nov line for the GROUP base."
+ (save-excursion
+ (set-buffer (nnml-open-nov group))
+ (goto-char (point-max))
+ (insert (int-to-string article) line)))
+
+(defsubst nnml-header-value ()
+ (buffer-substring (match-end 0) (save-excursion (end-of-line) (point))))
+
+(defun nnml-make-nov-line (chars)
+ "Create a nov from the current headers."
+ (let ((case-fold-search t)
+ subject from date id references lines xref in-reply-to char)
+ (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))
+ (subst-char-in-region (point-min) (point-max) ?\t ? )
+ ;; [number subject from date id references chars lines xref]
+ (save-excursion
+ (goto-char (point-min))
+ (while (re-search-forward "^\\(from\\|subject\\|message-id\\|date\\|lines\\|xref\\|references\\|in-reply-to\\): "
+ nil t)
+ (beginning-of-line)
+ (setq char (downcase (following-char)))
+ (cond
+ ((eq char ?s)
+ (setq subject (nnml-header-value)))
+ ((eq char ?f)
+ (setq from (nnml-header-value)))
+ ((eq char ?x)
+ (setq xref (nnml-header-value)))
+ ((eq char ?l)
+ (setq lines (nnml-header-value)))
+ ((eq char ?d)
+ (setq date (nnml-header-value)))
+ ((eq char ?m)
+ (setq id (setq id (nnml-header-value))))
+ ((eq char ?r)
+ (setq references (nnml-header-value)))
+ ((eq char ?i)
+ (setq in-reply-to (nnml-header-value))))
+ (forward-line 1))
+
+ (and (not references)
+ in-reply-to
+ (string-match "<[^>]+>" in-reply-to)
+ (setq references
+ (substring in-reply-to (match-beginning 0)
+ (match-end 0)))))
+ ;; [number subject from date id references chars lines xref]
+ (format "\t%s\t%s\t%s\t%s\t%s\t%d\t%s\t%s\t\n"
+ (or subject "(none)")
+ (or from "(nobody)") (or date "")
+ (or id (concat "nnml-dummy-id-"
+ (mapconcat
+ (lambda (time) (int-to-string time))
+ (current-time) "-")))
+ (or references "")
+ (or chars 0) (or lines "0") (or xref ""))))))
+
+(defun nnml-open-nov (group)
+ (or (cdr (assoc group nnml-nov-buffer-alist))
+ (let ((buffer (find-file-noselect
+ (concat (nnmail-article-pathname
+ group nnml-directory) nnml-nov-file-name))))
+ (save-excursion
+ (set-buffer buffer)
+ (buffer-disable-undo (current-buffer)))
+ (setq nnml-nov-buffer-alist
+ (cons (cons group buffer) nnml-nov-buffer-alist))
+ buffer)))
+
+(defun nnml-save-nov ()
+ (save-excursion
+ (while nnml-nov-buffer-alist
+ (if (buffer-name (cdr (car nnml-nov-buffer-alist)))
+ (progn
+ (set-buffer (cdr (car nnml-nov-buffer-alist)))
+ (and (buffer-modified-p)
+ (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 (dir)
+ "Generate nov databases in all nnml mail newsgroups."
+ (interactive
+ (progn
+ (setq nnml-group-alist nil)
+ (list nnml-directory)))
+ (nnml-open-server (or nnml-current-server ""))
+ (let ((dirs (directory-files dir t nil t)))
+ (while dirs
+ (if (and (not (string-match "/\\.\\.$" (car dirs)))
+ (not (string-match "/\\.$" (car dirs)))
+ (file-directory-p (car dirs)))
+ (nnml-generate-nov-databases (car dirs)))
+ (setq dirs (cdr dirs))))
+ (let ((files (sort
+ (mapcar
+ (function
+ (lambda (name)
+ (string-to-int name)))
+ (directory-files dir nil "^[0-9]+$" t))
+ (function <)))
+ (nov (concat dir "/" nnml-nov-file-name))
+ (nov-buffer (get-buffer-create "*nov*"))
+ nov-line chars)
+ (if files
+ (setq nnml-group-alist
+ (cons (list (nnmail-replace-chars-in-string
+ (substring (expand-file-name dir)
+ (length (expand-file-name
+ nnml-directory)))
+ ?/ ?.)
+ (cons (car files)
+ (let ((f files))
+ (while (cdr f) (setq f (cdr f)))
+ (car f))))
+ nnml-group-alist)))
+ (if files
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (if (file-exists-p nov)
+ (delete-file nov))
+ (save-excursion
+ (set-buffer nov-buffer)
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer))
+ (while files
+ (erase-buffer)
+ (insert-file-contents (concat dir "/" (int-to-string (car files))))
+ (goto-char (point-min))
+ (narrow-to-region 1 (save-excursion (search-forward "\n\n" nil t)
+ (setq chars (- (point-max)
+ (point)))
+ (point)))
+ (if (not (= 0 chars)) ; none of them empty files...
+ (progn
+ (setq nov-line (nnml-make-nov-line chars))
+ (save-excursion
+ (set-buffer nov-buffer)
+ (goto-char (point-max))
+ (insert (int-to-string (car files)) nov-line))))
+ (widen)
+ (setq files (cdr files)))
+ (save-excursion
+ (set-buffer nov-buffer)
+ (write-region 1 (point-max) (expand-file-name nov) nil
+ 'nomesg)
+ (kill-buffer (current-buffer)))))
+ (nnmail-save-active nnml-group-alist nnml-active-file)))
+
+(defun nnml-nov-delete-article (group article)
+ (save-excursion
+ (set-buffer (nnml-open-nov group))
+ (goto-char (point-min))
+ (if (re-search-forward (concat "^" (int-to-string article) "\t") nil t)
+ (delete-region (match-beginning 0) (progn (forward-line 1) (point))))
+ t))
+
+(provide 'nnml)
+
+;;; nnml.el ends here
diff --git a/lisp/nnspool.el b/lisp/nnspool.el
new file mode 100644
index 00000000000..3d1351f89bd
--- /dev/null
+++ b/lisp/nnspool.el
@@ -0,0 +1,492 @@
+;;; nnspool.el --- spool access for GNU Emacs
+;; Copyright (C) 1988,89,90,93,94,95 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'nnheader)
+(require 'nntp)
+(require 'timezone)
+
+(defvar nnspool-inews-program news-inews-program
+ "Program to post news.
+This is most commonly `inews' or `injnews'.")
+
+(defvar nnspool-inews-switches '("-h")
+ "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.")
+
+(defvar nnspool-spool-directory news-path
+ "Local news spool directory.")
+
+(defvar nnspool-nov-directory (concat nnspool-spool-directory "over.view/")
+ "Local news nov directory.")
+
+(defvar nnspool-lib-dir "/usr/lib/news/"
+ "Where the local news library files are stored.")
+
+(defvar nnspool-active-file (concat nnspool-lib-dir "active")
+ "Local news active file.")
+
+(defvar nnspool-newsgroups-file (concat nnspool-lib-dir "newsgroups")
+ "Local news newsgroups file.")
+
+(defvar nnspool-distributions-file (concat nnspool-lib-dir "distributions")
+ "Local news distributions file.")
+
+(defvar nnspool-history-file (concat nnspool-lib-dir "history")
+ "Local news history file.")
+
+(defvar nnspool-active-times-file (concat nnspool-lib-dir "active.times")
+ "Local news active date file.")
+
+(defvar 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.")
+
+(defvar 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.")
+
+
+
+(defconst nnspool-version "nnspool 2.0"
+ "Version numbers of this version of NNSPOOL.")
+
+(defvar nnspool-current-directory nil
+ "Current news group directory.")
+
+(defvar nnspool-current-group nil)
+(defvar nnspool-status-string "")
+
+
+
+(defvar nnspool-current-server nil)
+(defvar nnspool-server-alist nil)
+(defvar nnspool-server-variables
+ (list
+ (list 'nnspool-inews-program nnspool-inews-program)
+ (list 'nnspool-inews-switches nnspool-inews-switches)
+ (list 'nnspool-spool-directory nnspool-spool-directory)
+ (list 'nnspool-nov-directory nnspool-nov-directory)
+ (list 'nnspool-lib-dir nnspool-lib-dir)
+ (list 'nnspool-active-file nnspool-active-file)
+ (list 'nnspool-newsgroups-file nnspool-newsgroups-file)
+ (list 'nnspool-distributions-file nnspool-distributions-file)
+ (list 'nnspool-history-file nnspool-history-file)
+ (list 'nnspool-active-times-file nnspool-active-times-file)
+ (list 'nnspool-large-newsgroup nnspool-large-newsgroup)
+ (list 'nnspool-nov-is-evil nnspool-nov-is-evil)
+ (list 'nnspool-sift-nov-with-sed nnspool-sift-nov-with-sed)
+ '(nnspool-current-directory nil)
+ '(nnspool-current-group nil)
+ '(nnspool-status-string "")))
+
+
+;;; Interface functions.
+
+(defun nnspool-retrieve-headers (sequence &optional newsgroup server)
+ "Retrieve the headers for the articles in SEQUENCE.
+Newsgroup must be selected before calling this function."
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (let* ((number (length sequence))
+ (count 0)
+ (do-message (and (numberp nnspool-large-newsgroup)
+ (> number nnspool-large-newsgroup)))
+ file beg article)
+ (if (not (nnspool-possibly-change-directory newsgroup))
+ ()
+ (if (and (numberp (car sequence))
+ (nnspool-retrieve-headers-with-nov sequence))
+ 'nov
+ (while sequence
+ (setq article (car sequence))
+ (if (stringp article)
+ (progn
+ (setq file (nnspool-find-article-by-message-id article))
+ (setq article 0))
+ (setq file (concat nnspool-current-directory
+ (int-to-string article))))
+ (and file (file-exists-p file)
+ (progn
+ (insert (format "221 %d Article retrieved.\n" article))
+ (setq beg (point))
+ (nnheader-insert-head file)
+ (goto-char beg)
+ (search-forward "\n\n" nil t)
+ (forward-char -1)
+ (insert ".\n")
+ (delete-region (point) (point-max))))
+ (setq sequence (cdr sequence))
+
+ (and do-message
+ (zerop (% (setq count (1+ count)) 20))
+ (message "NNSPOOL: Receiving headers... %d%%"
+ (/ (* count 100) number))))
+
+ (and do-message (message "NNSPOOL: Receiving headers...done"))
+
+ ;; Fold continuation lines.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " " t t))
+ 'headers)))))
+
+(defun nnspool-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (equal server nnspool-current-server)
+ t
+ (if nnspool-current-server
+ (setq nnspool-server-alist
+ (cons (list nnspool-current-server
+ (nnheader-save-variables nnspool-server-variables))
+ nnspool-server-alist)))
+ (let ((state (assoc server nnspool-server-alist)))
+ (if state
+ (progn
+ (nnheader-restore-variables (nth 1 state))
+ (setq nnspool-server-alist (delq state nnspool-server-alist)))
+ (nnheader-set-init-variables nnspool-server-variables defs)))
+ (setq nnspool-current-server server)))
+
+(defun nnspool-close-server (&optional server)
+ t)
+
+(defun nnspool-server-opened (&optional server)
+ (and (equal server nnspool-current-server)
+ nntp-server-buffer
+ (buffer-name nntp-server-buffer)))
+
+(defun nnspool-status-message (&optional server)
+ "Return server status response as string."
+ nnspool-status-string)
+
+(defun nnspool-request-article (id &optional newsgroup server buffer)
+ "Select article by message ID (or number)."
+ (nnspool-possibly-change-directory newsgroup)
+ (let ((file (if (stringp id)
+ (nnspool-find-article-by-message-id id)
+ (concat nnspool-current-directory (prin1-to-string id))))
+ (nntp-server-buffer (or buffer nntp-server-buffer)))
+ (if (and (stringp file)
+ (file-exists-p file)
+ (not (file-directory-p file)))
+ (save-excursion
+ (nnspool-find-file file)))))
+
+(defun nnspool-request-body (id &optional newsgroup server)
+ "Select article body by message ID (or number)."
+ (nnspool-possibly-change-directory newsgroup)
+ (if (nnspool-request-article id)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (delete-region (point-min) (point)))
+ t)))
+
+(defun nnspool-request-head (id &optional newsgroup server)
+ "Select article head by message ID (or number)."
+ (nnspool-possibly-change-directory newsgroup)
+ (if (nnspool-request-article id)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (if (search-forward "\n\n" nil t)
+ (delete-region (1- (point)) (point-max)))
+ t)))
+
+(defun nnspool-request-group (group &optional server dont-check)
+ "Select news GROUP."
+ (let ((pathname (nnspool-article-pathname
+ (nnspool-replace-chars-in-string group ?. ?/)))
+ dir)
+ (if (not (file-directory-p pathname))
+ (progn
+ (setq nnspool-status-string
+ "Invalid group name (no such directory)")
+ nil)
+ (setq nnspool-current-directory pathname)
+ (setq nnspool-status-string "")
+ (if (not dont-check)
+ (progn
+ (setq dir (directory-files pathname nil "^[0-9]+$" t))
+ ;; yes, completely empty spool directories *are* possible
+ ;; Fix by Sudish Joseph <joseph@cis.ohio-state.edu>
+ (and dir
+ (setq dir
+ (sort
+ (mapcar
+ (function
+ (lambda (name)
+ (string-to-int name)))
+ dir)
+ '<)))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (if dir
+ (insert
+ (format "211 %d %d %d %s\n" (length dir) (car dir)
+ (progn (while (cdr dir) (setq dir (cdr dir)))
+ (car dir))
+ group))
+ (insert (format "211 0 0 0 %s\n" group))))))
+ t)))
+
+(defun nnspool-close-group (group &optional server)
+ t)
+
+(defun nnspool-request-list (&optional server)
+ "List active newsgroups."
+ (save-excursion
+ (nnspool-find-file nnspool-active-file)))
+
+(defun nnspool-request-list-newsgroups (&optional server)
+ "List newsgroups (defined in NNTP2)."
+ (save-excursion
+ (nnspool-find-file nnspool-newsgroups-file)))
+
+(defun nnspool-request-list-distributions (&optional server)
+ "List distributions (defined in NNTP2)."
+ (save-excursion
+ (nnspool-find-file nnspool-distributions-file)))
+
+;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
+(defun 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))
+ (setq groups (cons (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))
+
+(defun 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 (apply 'start-process "*nnspool inews*" inews-buffer
+ nnspool-inews-program nnspool-inews-switches)))
+ (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...
+ (condition-case nil
+ (process-send-eof proc)
+ (error nil))
+ t)))
+
+(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 unfolding lines.
+ (subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo)
+ (setq nnspool-status-string (buffer-string))
+ (message "nnspool: %s" nnspool-status-string)
+ ;(kill-buffer (current-buffer))
+ )))
+
+(defalias 'nnspool-request-post-buffer 'nntp-request-post-buffer)
+
+
+;;; Internal functions.
+
+(defun nnspool-retrieve-headers-with-nov (articles)
+ (if (or gnus-nov-is-evil nnspool-nov-is-evil)
+ nil
+ (let ((nov (concat (file-name-as-directory nnspool-nov-directory)
+ (nnspool-replace-chars-in-string
+ nnspool-current-group ?. ?/)
+ "/.overview"))
+ article)
+ (if (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)
+ (insert-file-contents nov)
+ ;; First we find the first wanted line. We issue a number
+ ;; of search-forwards - the first article we are lookign
+ ;; for may be expired, so we have to go on searching until
+ ;; we find one of the articles we want.
+ (while (and articles
+ (setq article (concat (int-to-string
+ (car articles)) "\t"))
+ (not (or (looking-at article)
+ (search-forward (concat "\n" article)
+ nil t))))
+ (setq articles (cdr articles)))
+ (if (not articles)
+ ()
+ (beginning-of-line)
+ (delete-region (point-min) (point))
+ ;; Then we find the last wanted line. We go to the end
+ ;; of the buffer and search backward much the same way
+ ;; we did to find the first article.
+ ;; !!! Perhaps it would be better just to do a (last articles),
+ ;; and go forward successively over each line and
+ ;; compare to avoid this (reverse), like this:
+ ;; (while (and (>= last (read nntp-server-buffer)))
+ ;; (zerop (forward-line 1))))
+ (setq articles (reverse articles))
+ (goto-char (point-max))
+ (while (and articles
+ (not (search-backward
+ (concat "\n" (int-to-string (car articles))
+ "\t") nil t)))
+ (setq articles (cdr articles)))
+ (if articles
+ (progn
+ (forward-line 2)
+ (delete-region (point) (point-max)))))
+ (or articles (progn (erase-buffer) nil))))))))
+
+(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).
+(defun nnspool-find-article-by-message-id (id)
+ "Return full pathname of an article identified by message-ID."
+ (save-excursion
+ (let ((buf (get-buffer-create " *nnspool work*")))
+ (set-buffer buf)
+ (erase-buffer)
+ (call-process "grep" nil t nil id nnspool-history-file)
+ (goto-char (point-min))
+ (if (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ \t\n]*\\)")
+ (concat nnspool-spool-directory
+ (nnspool-replace-chars-in-string
+ (buffer-substring (match-beginning 1) (match-end 1))
+ ?. ?/))))))
+
+(defun nnspool-find-file (file)
+ "Insert FILE in server buffer safely."
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (condition-case ()
+ (progn (insert-file-contents file) t)
+ (file-error nil)))
+
+(defun nnspool-possibly-change-directory (newsgroup)
+ (if newsgroup
+ (let ((pathname (nnspool-article-pathname
+ (nnspool-replace-chars-in-string newsgroup ?. ?/))))
+ (if (file-directory-p pathname)
+ (progn
+ (setq nnspool-current-directory pathname)
+ (setq nnspool-current-group newsgroup))
+ (setq nnspool-status-string
+ (format "No such newsgroup: %s" newsgroup))
+ nil))
+ t))
+
+(defun nnspool-article-pathname (group)
+ "Make pathname for GROUP."
+ (concat (file-name-as-directory nnspool-spool-directory) group "/"))
+
+(defun nnspool-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)
+ (if (= (aref string idx) from)
+ (aset string idx to))
+ (setq idx (1+ idx)))
+ string))
+
+(defun nnspool-number-base-10 (num pos)
+ (if (<= pos 0) ""
+ (setcdr num (+ (* (% (car num) 10) 65536) (cdr num)))
+ (apply
+ 'concat
+ (reverse
+ (list
+ (char-to-string
+ (aref "0123456789" (% (cdr num) 10)))
+ (progn
+ (setcdr num (/ (cdr num) 10))
+ (setcar num (/ (car num) 10))
+ (nnspool-number-base-10 num (1- pos))))))))
+
+(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)
+ (car (cdr unix)))))
+
+(provide 'nnspool)
+
+;;; nnspool.el ends here
diff --git a/lisp/nntp.el b/lisp/nntp.el
new file mode 100644
index 00000000000..3498a33be58
--- /dev/null
+++ b/lisp/nntp.el
@@ -0,0 +1,1275 @@
+;;; nntp.el --- nntp access for Gnus
+;; Copyright (C) 1987,88,89,90,92,93,94,95 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'rnews)
+(require 'sendmail)
+(require 'nnheader)
+
+(eval-when-compile (require 'cl))
+
+(eval-and-compile
+ (autoload 'news-setup "rnewspost")
+ (autoload 'news-reply-mode "rnewspost")
+ (autoload 'nnmail-request-post-buffer "nnmail")
+ (autoload 'cancel-timer "timer")
+ (autoload 'telnet "telnet" nil t)
+ (autoload 'telnet-send-input "telnet" nil t)
+ (autoload 'timezone-parse-date "timezone"))
+
+(defvar nntp-server-hook nil
+ "*Hooks for the NNTP server.
+If the kanji code of the NNTP server is different from the local kanji
+code, the correct kanji code of the buffer associated with the NNTP
+server must be specified as follows:
+
+\(setq nntp-server-hook
+ (function
+ (lambda ()
+ ;; Server's Kanji code is EUC (NEmacs hack).
+ (make-local-variable 'kanji-fileio-code)
+ (setq kanji-fileio-code 0))))
+
+If you'd like to change something depending on the server in this
+hook, use the variable `nntp-address'.")
+
+(defvar nntp-server-opened-hook nil
+ "*Hook used for sending commands to the server at startup.
+The default value is `nntp-send-mode-reader', which makes an innd
+server spawn an nnrpd server. Another useful function to put in this
+hook might be `nntp-send-authinfo', which will prompt for a password
+to allow posting from the server. Note that this is only necessary to
+do on servers that use strict access control.")
+(add-hook 'nntp-server-opened-hook 'nntp-send-mode-reader)
+
+(defvar nntp-open-server-function 'nntp-open-network-stream
+ "*Function used for connecting to a remote system.
+It will be called with the address of the remote system.
+
+Two pre-made functions are `nntp-open-network-stream', which is the
+default, and simply connects to some port or other on the remote
+system (see nntp-port-number). The other is `nntp-open-rlogin', which
+does an rlogin on the remote system, and then does a telnet to the
+NNTP server available there (see nntp-rlogin-parameters).")
+
+(defvar nntp-rlogin-parameters '("telnet" "${NNTPSERVER:=localhost}" "nntp")
+ "*Parameters to `nntp-open-login'.
+That function may be used as `nntp-open-server-function'. In that
+case, this list will be used as the parameter list given to rsh.")
+
+(defvar nntp-rlogin-user-name nil
+ "*User name on remote system when using the rlogin connect method.")
+
+(defvar nntp-address nil
+ "*The name of the NNTP server.")
+
+(defvar nntp-port-number "nntp"
+ "*Port number to connect to.")
+
+(defvar nntp-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.")
+
+(defvar nntp-buggy-select (memq system-type '(fujitsu-uts))
+ "*t if your select routine is buggy.
+If the select routine signals error or fall into infinite loop while
+waiting for the server response, the variable must be set to t. In
+case of Fujitsu UTS, it is set to T since `accept-process-output'
+doesn't work properly.")
+
+(defvar nntp-maximum-request 400
+ "*The maximum number of the requests sent to the NNTP server at one time.
+If Emacs hangs up while retrieving headers, set the variable to a
+lower value.")
+
+(defvar nntp-debug-read 10000
+ "*Display '...' every 10Kbytes of a message being received if it is non-nil.
+If it is a number, dots are displayed per the number.")
+
+(defvar nntp-nov-is-evil nil
+ "*If non-nil, nntp will never attempt to use XOVER when talking to the server.")
+
+(defvar nntp-xover-commands '("XOVER" "XOVERVIEW")
+ "*List of strings that are used as commands to fetch NOV lines from a server.
+The strings are tried in turn until a positive response is gotten. If
+none of the commands are successful, nntp will just grab headers one
+by one.")
+
+(defvar nntp-nov-gap 20
+ "*Maximum allowed gap between two articles.
+If the gap between two consecutive articles is bigger than this
+variable, split the XOVER request into two requests.")
+
+(defvar nntp-connection-timeout nil
+ "*Number of seconds to wait before an nntp connection times out.
+If this variable is nil, which is the default, no timers are set.")
+
+(defvar nntp-news-default-headers nil
+ "*If non-nil, override `mail-default-headers' when posting news.")
+
+(defvar nntp-prepare-server-hook nil
+ "*Hook run before a server is opened.
+If can be used to set up a server remotely, for instance. Say you
+have an account at the machine \"other.machine\". This machine has
+access to an NNTP server that you can't access locally. You could
+then use this hook to rsh to the remote machine and start a proxy NNTP
+server there that you can connect to.")
+
+(defvar nntp-async-number 5
+ "*How many articles should be prefetched when in asynchronous mode.")
+
+
+
+
+(defconst nntp-version "nntp 4.0"
+ "Version numbers of this version of NNTP.")
+
+(defvar nntp-server-buffer nil
+ "Buffer associated with the NNTP server process.")
+
+(defvar nntp-server-process nil
+ "The NNTP server process.
+You'd better not use this variable in NNTP front-end program, but
+instead use `nntp-server-buffer'.")
+
+(defvar nntp-status-string nil
+ "Save the server response message.
+You'd better not use this variable in NNTP front-end program but
+instead call function `nntp-status-message' to get status message.")
+
+(defvar nntp-opened-connections nil
+ "All (possibly) opened connections.")
+
+(defvar nntp-server-xover 'try)
+(defvar nntp-server-list-active-group 'try)
+(defvar nntp-current-group "")
+(defvar nntp-timeout-servers nil)
+
+(defvar nntp-async-process nil)
+(defvar nntp-async-buffer nil)
+(defvar nntp-async-articles nil)
+(defvar nntp-async-fetched nil)
+(defvar nntp-async-group-alist nil)
+
+
+
+(defvar nntp-current-server nil)
+(defvar nntp-server-alist nil)
+(defvar nntp-server-variables
+ (list
+ (list 'nntp-server-hook nntp-server-hook)
+ (list 'nntp-server-opened-hook nntp-server-opened-hook)
+ (list 'nntp-port-number nntp-port-number)
+ (list 'nntp-address nntp-address)
+ (list 'nntp-large-newsgroup nntp-large-newsgroup)
+ (list 'nntp-buggy-select nntp-buggy-select)
+ (list 'nntp-maximum-request nntp-maximum-request)
+ (list 'nntp-debug-read nntp-debug-read)
+ (list 'nntp-nov-is-evil nntp-nov-is-evil)
+ (list 'nntp-xover-commands nntp-xover-commands)
+ (list 'nntp-connection-timeout nntp-connection-timeout)
+ (list 'nntp-news-default-headers nntp-news-default-headers)
+ (list 'nntp-prepare-server-hook nntp-prepare-server-hook)
+ (list 'nntp-async-number nntp-async-number)
+ '(nntp-async-process nil)
+ '(nntp-async-buffer nil)
+ '(nntp-async-articles nil)
+ '(nntp-async-fetched nil)
+ '(nntp-async-group-alist nil)
+ '(nntp-server-process nil)
+ '(nntp-status-string nil)
+ '(nntp-server-xover try)
+ '(nntp-server-list-active-group try)
+ '(nntp-current-group "")))
+
+
+;;; Interface functions.
+
+(defun nntp-retrieve-headers (sequence &optional newsgroup server)
+ "Retrieve the headers to the articles in SEQUENCE."
+ (nntp-possibly-change-server newsgroup server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (if (and (not gnus-nov-is-evil)
+ (not nntp-nov-is-evil)
+ (nntp-retrieve-headers-with-xover sequence))
+ 'nov
+ (let ((number (length sequence))
+ (count 0)
+ (received 0)
+ (last-point (point-min)))
+ ;; Send HEAD command.
+ (while sequence
+ (nntp-send-strings-to-server
+ "HEAD" (if (numberp (car sequence)) (int-to-string (car sequence))
+ (car sequence)))
+ (setq sequence (cdr sequence)
+ count (1+ count))
+ ;; Every 400 header requests we have to read stream in order
+ ;; to avoid deadlock.
+ (if (or (null sequence) ;All requests have been sent.
+ (zerop (% count nntp-maximum-request)))
+ (progn
+ (nntp-accept-response)
+ (while (progn
+ (goto-char last-point)
+ ;; Count replies.
+ (while (re-search-forward "^[0-9]" nil t)
+ (setq received (1+ received)))
+ (setq last-point (point))
+ (< received count))
+ ;; If number of headers is greater than 100, give
+ ;; informative messages.
+ (and (numberp nntp-large-newsgroup)
+ (> number nntp-large-newsgroup)
+ (zerop (% received 20))
+ (message "NNTP: Receiving headers... %d%%"
+ (/ (* received 100) number)))
+ (nntp-accept-response)))))
+ ;; Wait for text of last command.
+ (goto-char (point-max))
+ (re-search-backward "^[0-9]" nil t)
+ (if (looking-at "^[23]")
+ (while (progn
+ (goto-char (- (point-max) 3))
+ (not (looking-at "^\\.\r?\n")))
+ (nntp-accept-response)))
+ (and (numberp nntp-large-newsgroup)
+ (> number nntp-large-newsgroup)
+ (message "NNTP: Receiving headers...done"))
+
+ ;; Now all of replies are received.
+ (setq received number)
+ ;; First, fold continuation lines.
+ (goto-char (point-min))
+ (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
+ (replace-match " "))
+ ;; Remove all "\r"'s
+ (goto-char (point-min))
+ (while (search-forward "\r" nil t)
+ (replace-match ""))
+ 'headers))))
+
+
+(defun nntp-retrieve-groups (groups &optional server)
+ (nntp-possibly-change-server nil server)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (and (eq nntp-server-list-active-group 'try)
+ (nntp-try-list-active (car groups)))
+ (erase-buffer)
+ (let ((count 0)
+ (received 0)
+ (last-point (point-min))
+ (command (if nntp-server-list-active-group
+ "LIST ACTIVE" "GROUP")))
+ (while groups
+ (nntp-send-strings-to-server command (car groups))
+ (setq groups (cdr groups))
+ (setq count (1+ count))
+ ;; Every 400 requests we have to read the stream in
+ ;; order to avoid deadlocks.
+ (if (or (null groups) ;All requests have been sent.
+ (zerop (% count nntp-maximum-request)))
+ (progn
+ (nntp-accept-response)
+ (while (progn
+ (goto-char last-point)
+ ;; Count replies.
+ (while (re-search-forward "^[0-9]" nil t)
+ (setq received (1+ received)))
+ (setq last-point (point))
+ (< received count))
+ (nntp-accept-response)))))
+
+ ;; Wait for the reply from the final command.
+ (if nntp-server-list-active-group
+ (progn
+ (goto-char (point-max))
+ (re-search-backward "^[0-9]" nil t)
+ (if (looking-at "^[23]")
+ (while (progn
+ (goto-char (- (point-max) 3))
+ (not (looking-at "^\\.\r?\n")))
+ (nntp-accept-response)))))
+
+ ;; Now all replies are received. We remove CRs.
+ (goto-char (point-min))
+ (while (search-forward "\r" nil t)
+ (replace-match "" t t))
+
+ (if nntp-server-list-active-group
+ (progn
+ ;; We have read active entries, so we just delete the
+ ;; superfluos gunk.
+ (goto-char (point-min))
+ (while (re-search-forward "^[.2-5]" nil t)
+ (delete-region (match-beginning 0)
+ (progn (forward-line 1) (point))))
+ 'active)
+ 'group))))
+
+(defun nntp-open-server (server &optional defs)
+ (nnheader-init-server-buffer)
+ (if (nntp-server-opened server)
+ t
+ (if (or (stringp (car defs))
+ (numberp (car defs)))
+ (setq defs (cons (list 'nntp-port-number (car defs)) (cdr defs))))
+ (or (assq 'nntp-address defs)
+ (setq defs (append defs (list (list 'nntp-address server)))))
+ (if (and nntp-current-server
+ (not (equal server nntp-current-server)))
+ (setq nntp-server-alist
+ (cons (list nntp-current-server
+ (nnheader-save-variables nntp-server-variables))
+ nntp-server-alist)))
+ (let ((state (assoc server nntp-server-alist)))
+ (if state
+ (progn
+ (nnheader-restore-variables (nth 1 state))
+ (setq nntp-server-alist (delq state nntp-server-alist)))
+ (nnheader-set-init-variables nntp-server-variables defs)))
+ (setq nntp-current-server server)
+ (or (nntp-server-opened server)
+ (progn
+ (if (member nntp-address nntp-timeout-servers)
+ nil
+ (run-hooks 'nntp-prepare-server-hook)
+ (nntp-open-server-semi-internal nntp-address nntp-port-number))))))
+
+(defun nntp-close-server (&optional server)
+ "Close connection to SERVER."
+ (nntp-possibly-change-server nil server)
+ (unwind-protect
+ (progn
+ ;; Un-set default sentinel function before closing connection.
+ (and nntp-server-process
+ (eq 'nntp-default-sentinel
+ (process-sentinel nntp-server-process))
+ (set-process-sentinel nntp-server-process nil))
+ ;; We cannot send QUIT command unless the process is running.
+ (if (nntp-server-opened)
+ (nntp-send-command nil "QUIT")))
+ (nntp-close-server-internal server)
+ (setq nntp-timeout-servers (delete server nntp-timeout-servers))))
+
+(defalias 'nntp-request-quit (symbol-function 'nntp-close-server))
+
+(defun nntp-request-close ()
+ "Close all server connections."
+ (let (proc)
+ (while nntp-opened-connections
+ (setq proc (pop nntp-opened-connections))
+ (and proc (delete-process proc)))
+ (and nntp-async-buffer
+ (get-buffer nntp-async-buffer)
+ (kill-buffer nntp-async-buffer))
+ (while nntp-server-alist
+ (and (setq proc (nth 1 (assq 'nntp-async-buffer
+ (car nntp-server-alist))))
+ (buffer-name proc)
+ (kill-buffer proc))
+ (setq nntp-server-alist (cdr nntp-server-alist)))
+ (setq nntp-current-server nil
+ nntp-timeout-servers nil
+ nntp-async-group-alist nil)))
+
+(defun nntp-server-opened (&optional server)
+ "Say whether a connection to SERVER has been opened."
+ (and (equal server nntp-current-server)
+ nntp-server-buffer
+ (buffer-name nntp-server-buffer)
+ nntp-server-process
+ (memq (process-status nntp-server-process) '(open run))))
+
+(defun nntp-status-message (&optional server)
+ "Return server status as a string."
+ (if (and nntp-status-string
+ ;; NNN MESSAGE
+ (string-match "[0-9][0-9][0-9][ \t]+\\([^\r]*\\).*$"
+ nntp-status-string))
+ (substring nntp-status-string (match-beginning 1) (match-end 1))
+ ;; Empty message if nothing.
+ (or nntp-status-string "")))
+
+(defun nntp-request-article (id &optional newsgroup server buffer)
+ "Request article ID (message-id or number)."
+ (nntp-possibly-change-server newsgroup server)
+
+ (let (found)
+
+ ;; First we see whether we can get the article from the async buffer.
+ (if (and (numberp id)
+ nntp-async-articles
+ (memq id nntp-async-fetched))
+ (save-excursion
+ (set-buffer nntp-async-buffer)
+ (let ((opoint (point))
+ (art (if (numberp id) (int-to-string id) id))
+ beg end)
+ (if (and (or (re-search-forward (concat "^2.. +" art) nil t)
+ (progn
+ (goto-char (point-min))
+ (re-search-forward (concat "^2.. +" art) opoint t)))
+ (progn
+ (beginning-of-line)
+ (setq beg (point)
+ end (re-search-forward "^\\.\r?\n" nil t))))
+ (progn
+ (setq found t)
+ (save-excursion
+ (set-buffer (or buffer nntp-server-buffer))
+ (erase-buffer)
+ (insert-buffer-substring nntp-async-buffer beg end)
+ (let ((nntp-server-buffer (current-buffer)))
+ (nntp-decode-text)))
+ (delete-region beg end)
+ (and nntp-async-articles
+ (nntp-async-fetch-articles id)))))))
+
+ (if found
+ t
+ ;; The article was not in the async buffer, so we fetch it now.
+ (unwind-protect
+ (progn
+ (if buffer (set-process-buffer nntp-server-process buffer))
+ (let ((nntp-server-buffer (or buffer nntp-server-buffer))
+ (art (or (and (numberp id) (int-to-string id)) id)))
+ ;; If NEmacs, end of message may look like: "\256\215" (".^M")
+ (prog1
+ (nntp-send-command "^\\.\r?\n" "ARTICLE" art)
+ (nntp-decode-text)
+ (and nntp-async-articles (nntp-async-fetch-articles id)))))
+ (if buffer (set-process-buffer
+ nntp-server-process nntp-server-buffer))))))
+
+(defun nntp-request-body (id &optional newsgroup server)
+ "Request body of article ID (message-id or number)."
+ (nntp-possibly-change-server newsgroup server)
+ (prog1
+ ;; If NEmacs, end of message may look like: "\256\215" (".^M")
+ (nntp-send-command
+ "^\\.\r?\n" "BODY" (or (and (numberp id) (int-to-string id)) id))
+ (nntp-decode-text)))
+
+(defun nntp-request-head (id &optional newsgroup server)
+ "Request head of article ID (message-id or number)."
+ (nntp-possibly-change-server newsgroup server)
+ (prog1
+ (nntp-send-command
+ "^\\.\r?\n" "HEAD" (or (and (numberp id) (int-to-string id)) id))
+ (nntp-decode-text)))
+
+(defun nntp-request-stat (id &optional newsgroup server)
+ "Request STAT of article ID (message-id or number)."
+ (nntp-possibly-change-server newsgroup server)
+ (nntp-send-command
+ "^[23].*\r?\n" "STAT" (or (and (numberp id) (int-to-string id)) id)))
+
+(defun nntp-request-group (group &optional server dont-check)
+ "Select GROUP."
+ (nntp-send-command "^.*\r?\n" "GROUP" group)
+ (setq nntp-current-group group)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (looking-at "[23]")))
+
+(defun nntp-request-asynchronous (group &optional server articles)
+ (and nntp-async-articles (nntp-async-request-group group))
+ (and
+ nntp-async-number
+ (if (not (or (nntp-async-server-opened)
+ (nntp-async-open-server)))
+ (progn
+ (message "Can't open second connection to %s" nntp-address)
+ (ding)
+ (setq nntp-async-articles nil)
+ (sit-for 2))
+ (setq nntp-async-articles articles)
+ (setq nntp-async-fetched nil)
+ (save-excursion
+ (set-buffer nntp-async-buffer)
+ (erase-buffer))
+ (nntp-async-send-strings "GROUP" group)
+ t)))
+
+(defun nntp-list-active-group (group &optional server)
+ (nntp-send-command "^.*\r?\n" "LIST ACTIVE" group))
+
+(defun nntp-request-group-description (group &optional server)
+ "Get description of GROUP."
+ (if (nntp-possibly-change-server nil server)
+ (prog1
+ (nntp-send-command "^.*\r?\n" "XGTITLE" group)
+ (nntp-decode-text))))
+
+(defun nntp-close-group (group &optional server)
+ (setq nntp-current-group nil)
+ t)
+
+(defun nntp-request-list (&optional server)
+ "List active groups."
+ (nntp-possibly-change-server nil server)
+ (prog1
+ (nntp-send-command "^\\.\r?\n" "LIST")
+ (nntp-decode-text)))
+
+(defun nntp-request-list-newsgroups (&optional server)
+ "List groups."
+ (nntp-possibly-change-server nil server)
+ (prog1
+ (nntp-send-command "^\\.\r?\n" "LIST NEWSGROUPS")
+ (nntp-decode-text)))
+
+(defun nntp-request-newgroups (date &optional server)
+ "List new groups."
+ (nntp-possibly-change-server nil server)
+ (let* ((date (timezone-parse-date date))
+ (time-string
+ (format "%s%02d%02d %s%s%s"
+ (substring (aref date 0) 2) (string-to-int (aref date 1))
+ (string-to-int (aref date 2)) (substring (aref date 3) 0 2)
+ (substring
+ (aref date 3) 3 5) (substring (aref date 3) 6 8))))
+ (prog1
+ (nntp-send-command "^\\.\r?\n" "NEWGROUPS" time-string)
+ (nntp-decode-text))))
+
+(defun nntp-request-list-distributions (&optional server)
+ "List distributions."
+ (nntp-possibly-change-server nil server)
+ (prog1
+ (nntp-send-command "^\\.\r?\n" "LIST DISTRIBUTIONS")
+ (nntp-decode-text)))
+
+(defun nntp-request-last (&optional newsgroup server)
+ "Decrease the current article pointer."
+ (nntp-possibly-change-server newsgroup server)
+ (nntp-send-command "^[23].*\r?\n" "LAST"))
+
+(defun nntp-request-next (&optional newsgroup server)
+ "Advance the current article pointer."
+ (nntp-possibly-change-server newsgroup server)
+ (nntp-send-command "^[23].*\r?\n" "NEXT"))
+
+(defun nntp-request-post (&optional server)
+ "Post the current buffer."
+ (nntp-possibly-change-server nil server)
+ (if (nntp-send-command "^[23].*\r?\n" "POST")
+ (progn
+ (nntp-encode-text)
+ (nntp-send-region-to-server (point-min) (point-max))
+ ;; 1.2a NNTP's post command is buggy. "^M" (\r) is not
+ ;; appended to end of the status message.
+ (nntp-wait-for-response "^[23].*\n"))))
+
+(defun nntp-request-post-buffer
+ (post group subject header article-buffer info follow-to respect-poster)
+ "Request a buffer suitable for composing an article.
+If POST, this is an original article; otherwise it's a followup.
+GROUP is the group to be posted to, the article should have subject
+SUBJECT. HEADER is a Gnus header vector. ARTICLE-BUFFER contains the
+article being followed up. INFO is a Gnus info list. If FOLLOW-TO,
+post to this group instead. If RESPECT-POSTER, heed the special
+\"poster\" value of the Followup-to header."
+ (if (assq 'to-address (nth 5 info))
+ (nnmail-request-post-buffer
+ post group subject header article-buffer info follow-to respect-poster)
+ (let ((mail-default-headers
+ (or nntp-news-default-headers mail-default-headers))
+ from date to followup-to newsgroups message-of
+ references distribution message-id)
+ (save-excursion
+ (set-buffer (get-buffer-create "*post-news*"))
+ (news-reply-mode)
+ (if (and (buffer-modified-p)
+ (> (buffer-size) 0)
+ (not (y-or-n-p "Unsent article being composed; erase it? ")))
+ ()
+ (erase-buffer)
+ (if post
+ (news-setup nil subject nil group nil)
+ (save-excursion
+ (set-buffer article-buffer)
+ (goto-char (point-min))
+ (narrow-to-region (point-min)
+ (progn (search-forward "\n\n") (point)))
+ (setq from (mail-header-from header))
+ (setq date (mail-header-date header))
+ (and from
+ (let ((stop-pos
+ (string-match " *at \\| *@ \\| *(\\| *<" from)))
+ (setq
+ message-of
+ (concat (if stop-pos (substring from 0 stop-pos) from)
+ "'s message of " date))))
+ (setq subject (or subject (mail-header-subject header)))
+ (or (string-match "^[Rr][Ee]:" subject)
+ (setq subject (concat "Re: " subject)))
+ (setq followup-to (mail-fetch-field "followup-to"))
+ (if (or (null respect-poster) ;Ignore followup-to: field.
+ (string-equal "" followup-to) ;Bogus header.
+ (string-equal "poster" followup-to);Poster
+ (and (eq respect-poster 'ask)
+ followup-to
+ (not (y-or-n-p (concat "Followup to "
+ followup-to "? ")))))
+ (setq followup-to nil))
+ (setq newsgroups
+ (or follow-to followup-to (mail-fetch-field "newsgroups")))
+ (setq references (mail-header-references header))
+ (setq distribution (mail-fetch-field "distribution"))
+ ;; Remove bogus distribution.
+ (and (stringp distribution)
+ (string-match "world" distribution)
+ (setq distribution nil))
+ (setq message-id (mail-header-id header))
+ (widen))
+ (setq news-reply-yank-from from)
+ (setq news-reply-yank-message-id message-id)
+ (news-setup to subject message-of
+ (if (stringp newsgroups) newsgroups "")
+ article-buffer)
+ (if (and newsgroups (listp newsgroups))
+ (progn
+ (goto-char (point-min))
+ (while newsgroups
+ (insert (car (car newsgroups)) ": "
+ (cdr (car newsgroups)) "\n")
+ (setq newsgroups (cdr newsgroups)))))
+ (nnheader-insert-references references message-id)
+ (if distribution
+ (progn
+ (mail-position-on-field "Distribution")
+ (insert distribution)))))
+ (current-buffer)))))
+
+;;; Internal functions.
+
+(defun nntp-send-mode-reader ()
+ "Send the MODE READER command to the nntp server.
+This function is supposed to be called from `nntp-server-opened-hook'.
+It will make innd servers spawn an nnrpd process to allow actual article
+reading."
+ (nntp-send-command "^.*\r?\n" "MODE READER"))
+
+(defun nntp-send-authinfo ()
+ "Send the AUTHINFO to the nntp server.
+This function is supposed to be called from `nntp-server-opened-hook'.
+It will prompt for a password."
+ (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name))
+ (nntp-send-command "^.*\r?\n" "AUTHINFO PASS"
+ (read-string "NNTP password: ")))
+
+(defun nntp-send-authinfo-from-file ()
+ "Send the AUTHINFO to the nntp server.
+This function is supposed to be called from `nntp-server-opened-hook'.
+It will prompt for a password."
+ (and (file-exists-p "~/.nntp-authinfo")
+ (save-excursion
+ (set-buffer (get-buffer-create " *tull*"))
+ (insert-file-contents "~/.nntp-authinfo")
+ (goto-char (point-min))
+ (nntp-send-command "^.*\r?\n" "AUTHINFO USER" (user-login-name))
+ (nntp-send-command "^.*\r?\n" "AUTHINFO PASS"
+ (buffer-substring (point)
+ (progn (end-of-line) (point))))
+ (kill-buffer (current-buffer)))))
+
+(defun nntp-default-sentinel (proc status)
+ "Default sentinel function for NNTP server process."
+ (let ((servers nntp-server-alist)
+ server)
+ ;; Go through the alist of server names and find the name of the
+ ;; server that the process that sent the signal is connected to.
+ ;; If you get my drift.
+ (if (equal proc nntp-server-process)
+ (setq server nntp-address)
+ (while (and servers
+ (not (equal proc (nth 1 (assq 'nntp-server-process
+ (car servers))))))
+ (setq servers (cdr servers)))
+ (setq server (car (car servers))))
+ (and server
+ (progn
+ (message "nntp: Connection closed to server %s" server)
+ (ding)))))
+
+(defun nntp-kill-connection (server)
+ (let ((proc (nth 1 (assq 'nntp-server-process
+ (assoc server nntp-server-alist)))))
+ (and proc (delete-process (process-name proc)))
+ (nntp-close-server server)
+ (setq nntp-timeout-servers (cons server nntp-timeout-servers))
+ (setq nntp-status-string
+ (message "Connection timed out to server %s." server))
+ (ding)
+ (sit-for 1)))
+
+;; Encoding and decoding of NNTP text.
+
+(defun nntp-decode-text ()
+ "Decode text transmitted by NNTP.
+0. Delete status line.
+1. Delete `^M' at end of line.
+2. Delete `.' at end of buffer (end of text mark).
+3. Delete `.' at beginning of line."
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ ;; Insert newline at end of buffer.
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))
+ ;; Delete status line.
+ (goto-char (point-min))
+ (delete-region (point) (progn (forward-line 1) (point)))
+ ;; Delete `^M' at the end of lines.
+ (while (not (eobp))
+ (end-of-line)
+ (and (= (preceding-char) ?\r)
+ (delete-char -1))
+ (forward-line 1))
+ ;; Delete `.' at end of the buffer (end of text mark).
+ (goto-char (point-max))
+ (forward-line -1)
+ (if (looking-at "^\\.\n")
+ (delete-region (point) (progn (forward-line 1) (point))))
+ ;; Replace `..' at beginning of line with `.'.
+ (goto-char (point-min))
+ ;; (replace-regexp "^\\.\\." ".")
+ (while (search-forward "\n.." nil t)
+ (delete-char -1))))
+
+(defun nntp-encode-text ()
+ "Encode text in current buffer for NNTP transmission.
+1. Insert `.' at beginning of line.
+2. Insert `.' at end of buffer (end of text mark)."
+ (save-excursion
+ ;; Insert newline at end of buffer.
+ (goto-char (point-max))
+ (or (bolp) (insert "\n"))
+ ;; Replace `.' at beginning of line with `..'.
+ (goto-char (point-min))
+ ;; (replace-regexp "^\\." "..")
+ (while (search-forward "\n." nil t)
+ (insert "."))
+ ;; Insert `.' at end of buffer (end of text mark).
+ (goto-char (point-max))
+ (insert ".\r\n")))
+
+
+;;;
+;;; Synchronous Communication with NNTP Server.
+;;;
+
+(defun nntp-send-command (response cmd &rest args)
+ "Wait for server RESPONSE after sending CMD and optional ARGS to server."
+ (save-excursion
+ ;; Clear communication buffer.
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (apply 'nntp-send-strings-to-server cmd args)
+ (if response
+ (nntp-wait-for-response response)
+ t)))
+
+(defun nntp-wait-for-response (regexp &optional slow)
+ "Wait for server response which matches REGEXP."
+ (save-excursion
+ (let ((status t)
+ (wait t)
+ (dotnum 0) ;Number of "." being displayed.
+ (dotsize ;How often "." displayed.
+ (if (numberp nntp-debug-read) nntp-debug-read 10000)))
+ (set-buffer nntp-server-buffer)
+ ;; Wait for status response (RFC977).
+ ;; 1xx - Informative message.
+ ;; 2xx - Command ok.
+ ;; 3xx - Command ok so far, send the rest of it.
+ ;; 4xx - Command was correct, but couldn't be performed for some
+ ;; reason.
+ ;; 5xx - Command unimplemented, or incorrect, or a serious
+ ;; program error occurred.
+ (nntp-accept-response)
+ (while wait
+ (goto-char (point-min))
+ (if slow
+ (progn
+ (cond ((re-search-forward "^[23][0-9][0-9]" nil t)
+ (setq wait nil))
+ ((re-search-forward "^[45][0-9][0-9]" nil t)
+ (setq status nil)
+ (setq wait nil))
+ (t (nntp-accept-response)))
+ (if (not wait) (delete-region (point-min)
+ (progn (beginning-of-line)
+ (point)))))
+ (cond ((looking-at "[23]")
+ (setq wait nil))
+ ((looking-at "[45]")
+ (setq status nil)
+ (setq wait nil))
+ (t (nntp-accept-response)))))
+ ;; Save status message.
+ (end-of-line)
+ (setq nntp-status-string
+ (buffer-substring (point-min) (point)))
+ (if status
+ (progn
+ (setq wait t)
+ (while wait
+ (goto-char (point-max))
+ (forward-line -1) ;(beginning-of-line)
+ ;;(message (buffer-substring
+ ;; (point)
+ ;; (save-excursion (end-of-line) (point))))
+ (if (looking-at regexp)
+ (setq wait nil)
+ (if nntp-debug-read
+ (let ((newnum (/ (buffer-size) dotsize)))
+ (if (not (= dotnum newnum))
+ (progn
+ (setq dotnum newnum)
+ (message "NNTP: Reading %s"
+ (make-string dotnum ?.))))))
+ (nntp-accept-response)))
+ ;; Remove "...".
+ (if (and nntp-debug-read (> dotnum 0))
+ (message ""))
+ ;; Successfully received server response.
+ t)))))
+
+
+
+;;;
+;;; Low-Level Interface to NNTP Server.
+;;;
+
+(defun nntp-retrieve-headers-with-xover (sequence)
+ (erase-buffer)
+ (cond
+
+ ;; This server does not talk NOV.
+ ((not nntp-server-xover)
+ nil)
+
+ ;; We don't care about gaps.
+ ((not nntp-nov-gap)
+ (nntp-send-xover-command
+ (car sequence) (nntp-last-element sequence) 'wait)
+
+ (goto-char (point-min))
+ (if (looking-at "[1-5][0-9][0-9] ")
+ (delete-region (point) (progn (forward-line 1) (point))))
+ (while (search-forward "\r" nil t)
+ (replace-match "" t t))
+ (goto-char (point-max))
+ (forward-line -1)
+ (if (looking-at "\\.")
+ (delete-region (point) (progn (forward-line 1) (point)))))
+
+ ;; We do it the hard way. For each gap, an XOVER command is sent
+ ;; to the server. We do not wait for a reply from the server, we
+ ;; just send them off as fast as we can. That means that we have
+ ;; to count the number of responses we get back to find out when we
+ ;; have gotten all we asked for.
+ ((numberp nntp-nov-gap)
+ (let ((count 0)
+ (received 0)
+ (last-point (point-min))
+ (buf (current-buffer))
+ first)
+ ;; We have to check `nntp-server-xover'. If it gets set to nil,
+ ;; that means that the server does not understand XOVER, but we
+ ;; won't know that until we try.
+ (while (and nntp-server-xover sequence)
+ (setq first (car sequence))
+ ;; Search forward until we find a gap, or until we run out of
+ ;; articles.
+ (while (and (cdr sequence)
+ (< (- (nth 1 sequence) (car sequence)) nntp-nov-gap))
+ (setq sequence (cdr sequence)))
+
+ (if (not (nntp-send-xover-command first (car sequence)))
+ ()
+ (setq sequence (cdr sequence)
+ count (1+ count))
+
+ ;; Every 400 requests we have to read the stream in
+ ;; order to avoid deadlocks.
+ (if (or (null sequence) ;All requests have been sent.
+ (zerop (% count nntp-maximum-request)))
+ (progn
+ (accept-process-output)
+ ;; On some Emacs versions the preceding function has
+ ;; a tendency to change the buffer. Perhaps. It's
+ ;; quite difficult to reporduce, because it only
+ ;; seems to happen once in a blue moon.
+ (set-buffer buf)
+ (while (progn
+ (goto-char last-point)
+ ;; Count replies.
+ (while (re-search-forward "^[0-9][0-9][0-9] " nil t)
+ (setq received (1+ received)))
+ (setq last-point (point))
+ (< received count))
+ (accept-process-output)
+ (set-buffer buf))))))
+
+ (if (not nntp-server-xover)
+ ()
+ ;; Wait for the reply from the final command.
+ (goto-char (point-max))
+ (re-search-backward "^[0-9][0-9][0-9] " nil t)
+ (if (looking-at "^[23]")
+ (while (progn
+ (goto-char (point-max))
+ (forward-line -1)
+ (not (looking-at "^\\.\r?\n")))
+ (nntp-accept-response)))
+
+ ;; We remove any "." lines and status lines.
+ (goto-char (point-min))
+ (while (search-forward "\r" nil t)
+ (delete-char -1))
+ (goto-char (point-min))
+ (delete-matching-lines "^\\.$\\|^[1-5][0-9][0-9] ")))))
+
+ nntp-server-xover)
+
+(defun nntp-send-xover-command (beg end &optional wait-for-reply)
+ (let ((range (format "%d-%d" beg end)))
+ (if (stringp nntp-server-xover)
+ ;; If `nntp-server-xover' is a string, then we just send this
+ ;; command.
+ (if wait-for-reply
+ (nntp-send-command "^\\.\r?\n" nntp-server-xover range)
+ ;; We do not wait for the reply.
+ (progn
+ (nntp-send-strings-to-server nntp-server-xover range)
+ t))
+ (let ((commands nntp-xover-commands))
+ ;; `nntp-xover-commands' is a list of possible XOVER commands.
+ ;; We try them all until we get at positive response.
+ (while (and commands (eq nntp-server-xover 'try))
+ (nntp-send-command "^\\.\r?\n" (car commands) range)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (and (looking-at "[23]") ; No error message.
+ ;; We also have to look at the lines. Some buggy
+ ;; servers give back simple lines with just the
+ ;; article number. How... helpful.
+ (progn
+ (forward-line 1)
+ (looking-at "[0-9]+\t...")) ; More text after number.
+ (setq nntp-server-xover (car commands))))
+ (setq commands (cdr commands)))
+ ;; If none of the commands worked, we disable XOVER.
+ (if (eq nntp-server-xover 'try)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (setq nntp-server-xover nil)))
+ nntp-server-xover))))
+
+(defun nntp-send-strings-to-server (&rest strings)
+ "Send list of STRINGS to news server as command and its arguments."
+ (let ((cmd (concat (mapconcat 'identity strings " ") "\r\n")))
+ ;; We open the nntp server if it is down.
+ (or (nntp-server-opened nntp-current-server)
+ (nntp-open-server nntp-current-server)
+ (error (nntp-status-message)))
+ ;; Send the strings.
+ (process-send-string nntp-server-process cmd)))
+
+(defun nntp-send-region-to-server (begin end)
+ "Send current buffer region (from BEGIN to END) to news server."
+ (save-excursion
+ ;; We have to work in the buffer associated with NNTP server
+ ;; process because of NEmacs hack.
+ (copy-to-buffer nntp-server-buffer begin end)
+ (set-buffer nntp-server-buffer)
+ (setq begin (point-min))
+ (setq end (point-max))
+ ;; `process-send-region' does not work if text to be sent is very
+ ;; large. I don't know maximum size of text sent correctly.
+ (let ((last nil)
+ (size 100)) ;Size of text sent at once.
+ (save-restriction
+ (narrow-to-region begin end)
+ (goto-char begin)
+ (while (not (eobp))
+ ;;(setq last (min end (+ (point) size)))
+ ;; NEmacs gets confused if character at `last' is Kanji.
+ (setq last (save-excursion
+ (goto-char (min end (+ (point) size)))
+ (or (eobp) (forward-char 1)) ;Adjust point
+ (point)))
+ (process-send-region nntp-server-process (point) last)
+ ;; I don't know whether the next codes solve the known
+ ;; problem of communication error of GNU Emacs.
+ (accept-process-output)
+ ;;(sit-for 0)
+ (goto-char last))))
+ ;; We cannot erase buffer, because reply may be received.
+ (delete-region begin end)))
+
+(defun nntp-open-server-semi-internal (server &optional service)
+ "Open SERVER.
+If SERVER is nil, use value of environment variable `NNTPSERVER'.
+If SERVICE, this this as the port number."
+ (let ((server (or server (getenv "NNTPSERVER")))
+ (status nil)
+ (timer
+ (and nntp-connection-timeout
+ (cond
+ ((fboundp 'run-at-time)
+ (run-at-time nntp-connection-timeout
+ nil 'nntp-kill-connection server))
+ ((fboundp 'start-itimer)
+ ;; Not sure if this will work or not, only one way to
+ ;; find out
+ (eval '(start-itimer "nntp-timeout"
+ (lambda ()
+ (nntp-kill-connection server))
+ nntp-connection-timeout nil)))))))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (setq nntp-status-string "")
+ (message "nntp: Connecting to server on %s..." server)
+ (cond ((and server (nntp-open-server-internal server service))
+ (setq nntp-address server)
+ (setq status
+ (condition-case nil
+ (nntp-wait-for-response "^[23].*\r?\n" 'slow)
+ (error nil)
+ (quit nil)))
+ (or status (nntp-close-server-internal server))
+ (and nntp-server-process
+ (progn
+ (set-process-sentinel
+ nntp-server-process 'nntp-default-sentinel)
+ ;; You can send commands at startup like AUTHINFO here.
+ ;; Added by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>
+ (run-hooks 'nntp-server-opened-hook))))
+ ((null server)
+ (setq nntp-status-string "NNTP server is not specified."))
+ (t ; We couldn't open the server.
+ (setq nntp-status-string
+ (buffer-substring (point-min) (point-max)))
+ (setq nntp-timeout-servers (cons server nntp-timeout-servers))))
+ (and timer (cancel-timer timer))
+ (message "")
+ (or status
+ (setq nntp-current-server nil
+ nntp-async-number nil))
+ status)))
+
+(defun nntp-open-server-internal (server &optional service)
+ "Open connection to news server on SERVER by SERVICE (default is nntp)."
+ (let (proc)
+ (save-excursion
+ ;; Use TCP/IP stream emulation package if needed.
+ (or (fboundp 'open-network-stream)
+ (require 'tcp))
+ ;; Initialize communication buffer.
+ (nnheader-init-server-buffer)
+ (set-buffer nntp-server-buffer)
+ (if (setq proc
+ (condition-case nil
+ (funcall nntp-open-server-function server)
+ (error nil)))
+ (progn
+ (setq nntp-server-process proc)
+ ;; Suggested by Hallvard B Furuseth <h.b.furuseth@usit.uio.no>.
+ (process-kill-without-query proc)
+ (setq nntp-address server)
+ ;; It is possible to change kanji-fileio-code in this hook.
+ (run-hooks 'nntp-server-hook)
+ (push proc nntp-opened-connections)
+ nntp-server-process)))))
+
+(defun nntp-open-network-stream (server)
+ (open-network-stream
+ "nntpd" nntp-server-buffer server nntp-port-number))
+
+(defun nntp-open-rlogin (server)
+ (let ((proc (start-process "nntpd" nntp-server-buffer "rsh" server)))
+ (process-send-string proc (mapconcat 'identity nntp-rlogin-parameters
+ " "))
+ (process-send-string proc "\n")))
+
+(defun nntp-telnet-to-machine ()
+ (let (b)
+ (telnet "localhost")
+ (goto-char (point-min))
+ (while (not (re-search-forward "^login: *" nil t))
+ (sit-for 1)
+ (goto-char (point-min)))
+ (goto-char (point-max))
+ (insert "larsi")
+ (telnet-send-input)
+ (setq b (point))
+ (while (not (re-search-forward ">" nil t))
+ (sit-for 1)
+ (goto-char b))
+ (goto-char (point-max))
+ (insert "ls")
+ (telnet-send-input)))
+
+(defun nntp-close-server-internal (&optional server)
+ "Close connection to news server."
+ (nntp-possibly-change-server nil server)
+ (if nntp-server-process
+ (delete-process nntp-server-process))
+ (setq nntp-server-process nil)
+ (setq nntp-address ""))
+
+(defun nntp-accept-response ()
+ "Read response of server.
+It is well-known that the communication speed will be much improved by
+defining this function as macro."
+ ;; To deal with server process exiting before
+ ;; accept-process-output is called.
+ ;; Suggested by Jason Venner <jason@violet.berkeley.edu>.
+ ;; This is a copy of `nntp-default-sentinel'.
+ (let ((buf (current-buffer)))
+ (prog1
+ (if (or (not nntp-server-process)
+ (not (memq (process-status nntp-server-process) '(open run))))
+ (error "nntp: Process connection closed; %s" (nntp-status-message))
+ (if nntp-buggy-select
+ (progn
+ ;; We cannot use `accept-process-output'.
+ ;; Fujitsu UTS requires messages during sleep-for.
+ ;; I don't know why.
+ (message "NNTP: Reading...")
+ (sleep-for 1)
+ (message ""))
+ (condition-case errorcode
+ (accept-process-output nntp-server-process)
+ (error
+ (cond ((string-equal "select error: Invalid argument"
+ (nth 1 errorcode))
+ ;; Ignore select error.
+ nil)
+ (t
+ (signal (car errorcode) (cdr errorcode))))))))
+ (set-buffer buf))))
+
+(defun nntp-last-element (list)
+ "Return last element of LIST."
+ (while (cdr list)
+ (setq list (cdr list)))
+ (car list))
+
+(defun nntp-possibly-change-server (newsgroup server)
+ ;; We see whether it is necessary to change the newsgroup.
+ (and newsgroup
+ (progn
+ (not (equal newsgroup nntp-current-group))
+ (nntp-request-group newsgroup server)))
+ (and server
+ (or (nntp-server-opened server)
+ (nntp-open-server server))))
+
+(defun nntp-try-list-active (group)
+ (nntp-list-active-group group)
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (goto-char (point-min))
+ (cond ((looking-at "5[0-9]+")
+ (setq nntp-server-list-active-group nil))
+ (t
+ (setq nntp-server-list-active-group t)))))
+
+(defun nntp-async-server-opened ()
+ (and nntp-async-process
+ (memq (process-status nntp-async-process) '(open run))))
+
+(defun nntp-async-open-server ()
+ (save-excursion
+ (set-buffer (generate-new-buffer " *async-nntp*"))
+ (setq nntp-async-buffer (current-buffer))
+ (buffer-disable-undo (current-buffer)))
+ (let ((nntp-server-process nil)
+ (nntp-server-buffer nntp-async-buffer))
+ (nntp-open-server-semi-internal nntp-address nntp-port-number)
+ (if (not (setq nntp-async-process nntp-server-process))
+ (progn
+ (setq nntp-async-number nil))
+ (set-process-buffer nntp-async-process nntp-async-buffer))))
+
+(defun nntp-async-fetch-articles (article)
+ (if (stringp article)
+ ()
+ (let ((articles (cdr (memq (assq article nntp-async-articles)
+ nntp-async-articles)))
+ (max (cond ((numberp nntp-async-number)
+ nntp-async-number)
+ ((eq nntp-async-number t)
+ (length nntp-async-articles))
+ (t 0)))
+ nart)
+ (while (and (>= (setq max (1- max)) 0)
+ articles)
+ (or (memq (setq nart (car (car articles))) nntp-async-fetched)
+ (progn
+ (nntp-async-send-strings "ARTICLE " (int-to-string nart))
+ (setq nntp-async-fetched (cons nart nntp-async-fetched))))
+ (setq articles (cdr articles))))))
+
+(defun nntp-async-send-strings (&rest strings)
+ (let ((cmd (concat (mapconcat 'identity strings " ") "\r\n")))
+ (or (nntp-async-server-opened)
+ (nntp-async-open-server)
+ (error (nntp-status-message)))
+ (process-send-string nntp-async-process cmd)))
+
+(defun nntp-async-request-group (group)
+ (if (equal group nntp-current-group)
+ ()
+ (let ((asyncs (assoc group nntp-async-group-alist)))
+ ;; A new group has been selected, so we push the current state
+ ;; of async articles on an alist, and pull the old state off.
+ (setq nntp-async-group-alist
+ (cons (list nntp-current-group
+ nntp-async-articles nntp-async-fetched
+ nntp-async-process)
+ (delq asyncs nntp-async-group-alist)))
+ (and asyncs
+ (progn
+ (setq nntp-async-articles (nth 1 asyncs))
+ (setq nntp-async-fetched (nth 2 asyncs))
+ (setq nntp-async-process (nth 3 asyncs)))))))
+
+(provide 'nntp)
+
+;;; nntp.el ends here
diff --git a/lisp/nnvirtual.el b/lisp/nnvirtual.el
new file mode 100644
index 00000000000..613b55fb502
--- /dev/null
+++ b/lisp/nnvirtual.el
@@ -0,0 +1,476 @@
+;;; nnvirtual.el --- virtual newsgroups access for Gnus
+;; Copyright (C) 1994,95 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, 675 Mass Ave, Cambridge, MA 02139, 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)
+
+
+
+(defconst nnvirtual-version "nnvirtual 1.0"
+ "Version number of this version of nnvirtual.")
+
+(defvar nnvirtual-group-alist nil)
+(defvar nnvirtual-current-group nil)
+(defvar nnvirtual-current-groups nil)
+(defvar nnvirtual-current-mapping nil)
+
+(defvar nnvirtual-do-not-open nil)
+
+(defvar nnvirtual-status-string "")
+
+
+
+;;; Interface functions.
+
+(defun nnvirtual-retrieve-headers (sequence &optional newsgroup server)
+ "Retrieve the headers for the articles in SEQUENCE."
+ (nnvirtual-possibly-change-newsgroups newsgroup server t)
+ (save-excursion
+ (set-buffer (get-buffer-create "*virtual headers*"))
+ (buffer-disable-undo (current-buffer))
+ (erase-buffer)
+ (if (stringp (car sequence))
+ 'headers
+ (let ((map nnvirtual-current-mapping)
+ (offset 0)
+ articles beg group active top article result prefix
+ fetched-articles group-method)
+ (while sequence
+ (while (< (car (car map)) (car sequence))
+ (setq offset (car (car map)))
+ (setq map (cdr map)))
+ (setq top (car (car map)))
+ (setq group (nth 1 (car map)))
+ (setq prefix (gnus-group-real-prefix group))
+ (setq active (nth 2 (car map)))
+ (setq articles nil)
+ (while (and sequence (<= (car sequence) top))
+ (setq articles (cons (- (+ active (car sequence)) offset)
+ articles))
+ (setq sequence (cdr sequence)))
+ (setq articles (nreverse articles))
+ (if (and articles
+ (setq result
+ (progn
+ (setq group-method
+ (gnus-find-method-for-group group))
+ (and (or (gnus-server-opened group-method)
+ (gnus-open-server group-method))
+ (gnus-request-group group t)
+ (gnus-retrieve-headers articles group)))))
+ (save-excursion
+ (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.
+ (and (eq result 'headers) (nnvirtual-convert-headers))
+ (goto-char (point-min))
+ (setq fetched-articles nil)
+ (while (not (eobp))
+ (setq beg (point)
+ article (read nntp-server-buffer)
+ fetched-articles (cons article fetched-articles))
+ (delete-region beg (point))
+ (insert (int-to-string (+ (- article active) offset)))
+ (beginning-of-line)
+ (looking-at
+ "[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t[^\t]*\t")
+ (goto-char (match-end 0))
+ (or (search-forward
+ "\t" (save-excursion (end-of-line) (point)) t)
+ (end-of-line))
+ (while (= (char-after (1- (point))) ? )
+ (forward-char -1)
+ (delete-char 1))
+ (if (eolp)
+ (progn
+ (end-of-line)
+ (or (= (char-after (1- (point))) ?\t)
+ (insert ?\t))
+ (insert (format "Xref: %s %s:%d\t" (system-name)
+ group article)))
+ (if (not (string= "" prefix))
+ (while (re-search-forward
+ "[^ ]+:[0-9]+"
+ (save-excursion (end-of-line) (point)) t)
+ (save-excursion
+ (goto-char (match-beginning 0))
+ (insert prefix))))
+ (end-of-line)
+ (or (= (char-after (1- (point))) ?\t)
+ (insert ?\t)))
+ (forward-line 1))))
+ (goto-char (point-max))
+ (insert-buffer-substring nntp-server-buffer)
+ ;; We have now massaged and inserted the headers from one
+ ;; group. In case some of the articles have expired or been
+ ;; cancelled, we have to mark them as read in the component
+ ;; group.
+ (let ((unfetched (gnus-sorted-complement
+ articles (nreverse fetched-articles))))
+ (and unfetched
+ (gnus-group-make-articles-read group unfetched nil))))
+ ;; 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 "*virtual headers*")
+ 'nov)
+ (kill-buffer (current-buffer)))))))
+
+(defun nnvirtual-open-server (newsgroups &optional something)
+ "Open a virtual newsgroup that contains NEWSGROUPS."
+ (nnheader-init-server-buffer))
+
+(defun nnvirtual-close-server (&rest dum)
+ "Close news server."
+ t)
+
+(defun nnvirtual-request-close ()
+ (setq nnvirtual-current-group nil
+ nnvirtual-current-groups nil
+ nnvirtual-current-mapping nil
+ nnvirtual-group-alist nil)
+ t)
+
+(defun nnvirtual-server-opened (&optional server)
+ "Return server process status, T or NIL.
+If the stream is opened, return T, otherwise return NIL."
+ (and nntp-server-buffer
+ (get-buffer nntp-server-buffer)))
+
+(defun nnvirtual-status-message (&optional server)
+ "Return server status response as string."
+ nnvirtual-status-string)
+
+(defun nnvirtual-request-article (article &optional newsgroup server buffer)
+ "Select article by message number."
+ (nnvirtual-possibly-change-newsgroups newsgroup server t)
+ (and (numberp article)
+ (let ((map nnvirtual-current-mapping)
+ (offset 0)
+ group-method)
+ (while (< (car (car map)) article)
+ (setq offset (car (car map)))
+ (setq map (cdr map)))
+ (setq group-method (gnus-find-method-for-group (nth 1 (car map))))
+ (or (gnus-server-opened group-method)
+ (gnus-open-server group-method))
+ (gnus-request-group (nth 1 (car map)) t)
+ (gnus-request-article (- (+ (nth 2 (car map)) article) offset)
+ (nth 1 (car map)) buffer))))
+
+(defun nnvirtual-request-group (group &optional server dont-check)
+ "Make GROUP the current newsgroup."
+ (nnvirtual-possibly-change-newsgroups group server dont-check)
+ (let ((map nnvirtual-current-mapping))
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (erase-buffer)
+ (if map
+ (progn
+ (while (cdr map)
+ (setq map (cdr map)))
+ (insert (format "211 %d 1 %d %s\n" (car (car map))
+ (car (car map)) group))
+ t)
+ (setq nnvirtual-status-string "No component groups")
+ (setq nnvirtual-current-group nil)
+ nil))))
+
+(defun nnvirtual-close-group (group &optional server)
+ (if (not nnvirtual-current-group)
+ ()
+ (nnvirtual-possibly-change-newsgroups group server t)
+ (nnvirtual-update-marked)
+ (setq nnvirtual-current-group nil
+ nnvirtual-current-groups nil
+ nnvirtual-current-mapping nil)
+ (setq nnvirtual-group-alist
+ (delq (assoc group nnvirtual-group-alist) nnvirtual-group-alist))))
+
+(defun nnvirtual-request-list (&optional server)
+ (setq nnvirtual-status-string "nnvirtual: LIST is not implemented.")
+ nil)
+
+(defun nnvirtual-request-newgroups (date &optional server)
+ "List new groups."
+ (setq nnvirtual-status-string "NEWGROUPS is not supported.")
+ nil)
+
+(defun nnvirtual-request-list-newsgroups (&optional server)
+ (setq nnvirtual-status-string
+ "nnvirtual: LIST NEWSGROUPS is not implemented.")
+ nil)
+
+(defalias 'nnvirtual-request-post 'nntp-request-post)
+
+(defun nnvirtual-request-post-buffer
+ (post group subject header article-buffer info follow-to respect-poster)
+ (nntp-request-post-buffer post "" subject header article-buffer
+ info follow-to respect-poster))
+
+
+;;; Internal functions.
+
+;; Convert HEAD headers into NOV headers.
+(defun nnvirtual-convert-headers ()
+ (save-excursion
+ (set-buffer nntp-server-buffer)
+ (let* ((gnus-newsgroup-dependencies (make-vector 100 0))
+ (headers (gnus-get-newsgroup-headers))
+ header)
+ (erase-buffer)
+ (while headers
+ (setq header (car headers)
+ headers (cdr headers))
+ (insert (int-to-string (mail-header-number header)) "\t"
+ (or (mail-header-subject header) "") "\t"
+ (or (mail-header-from header) "") "\t"
+ (or (mail-header-date header) "") "\t"
+ (or (mail-header-id header) "") "\t"
+ (or (mail-header-references header) "") "\t"
+ (int-to-string (or (mail-header-chars header) 0)) "\t"
+ (int-to-string (or (mail-header-lines header) 0)) "\t"
+ (if (mail-header-xref header)
+ (concat "Xref: " (mail-header-xref header) "\t")
+ "") "\n")))))
+
+(defun nnvirtual-possibly-change-newsgroups (group regexp &optional check)
+ (let ((inf t))
+ (or (not group)
+ (and nnvirtual-current-group
+ (string= group nnvirtual-current-group))
+ (and (setq inf (assoc group nnvirtual-group-alist))
+ (string= (nth 3 inf) regexp)
+ (progn
+ (setq nnvirtual-current-group (car inf))
+ (setq nnvirtual-current-groups (nth 1 inf))
+ (setq nnvirtual-current-mapping (nth 2 inf)))))
+ (if (or (not check) (not inf))
+ (progn
+ (and inf (setq nnvirtual-group-alist
+ (delq inf nnvirtual-group-alist)))
+ (setq nnvirtual-current-mapping nil)
+ (setq nnvirtual-current-group group)
+ (let ((newsrc gnus-newsrc-alist)
+ (virt-group (gnus-group-prefixed-name
+ nnvirtual-current-group '(nnvirtual ""))))
+ (setq nnvirtual-current-groups nil)
+ (while newsrc
+ (and (string-match regexp (car (car newsrc)))
+ (not (string= (car (car newsrc)) virt-group))
+ (setq nnvirtual-current-groups
+ (cons (car (car newsrc)) nnvirtual-current-groups)))
+ (setq newsrc (cdr newsrc))))
+ (if nnvirtual-current-groups
+ (progn
+ (nnvirtual-create-mapping group)
+ (setq nnvirtual-group-alist
+ (cons (list group nnvirtual-current-groups
+ nnvirtual-current-mapping regexp)
+ nnvirtual-group-alist)))
+ (setq nnvirtual-status-string
+ (format
+ "nnvirtual: No newsgroups for this virtual newsgroup"))))))
+ nnvirtual-current-groups)
+
+(defun nnvirtual-create-mapping (group)
+ (let* ((group (gnus-group-prefixed-name group (list 'nnvirtual "")))
+ (info (nth 2 (gnus-gethash group gnus-newsrc-hashtb)))
+ (groups nnvirtual-current-groups)
+ (offset 0)
+ reads unread igroup itotal ireads)
+ ;; The virtual group doesn't exist. (?)
+ (or info (error "No such group: %s" group))
+ (setq nnvirtual-current-mapping nil)
+ (while groups
+ ;; Added by Sudish Joseph <joseph@cis.ohio-state.edu>.
+ (setq igroup (car groups))
+ (let ((info (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb)))
+ (active (gnus-gethash igroup gnus-active-hashtb)))
+ ;; See if the group has had its active list read this session
+ ;; if not, we do it now.
+ (if (null active)
+ (if (gnus-activate-group igroup)
+ (progn
+ (gnus-get-unread-articles-in-group
+ info (gnus-gethash igroup gnus-active-hashtb))
+ (setq active (gnus-gethash igroup gnus-active-hashtb)))
+ (message "Couldn't open component group %s" igroup)))
+ (if (null active)
+ ()
+ ;; And then we do the mapping for this component group. If
+ ;; you feel tempted to cast your eyes to the soup below -
+ ;; don't. It'll hurt your soul. Suffice to say that it
+ ;; assigns ranges of nnvirtual article numbers to the
+ ;; different component groups. To get the article number
+ ;; from the nnvirtual number, one does something like
+ ;; (+ (- number offset) (car active)), where `offset' is the
+ ;; slice the mess below assigns, and active is the lowest
+ ;; active article in the component group.
+ (setq itotal (1+ (- (cdr active) (car active))))
+ (if (setq ireads (nth 2 info))
+ (let ((itreads
+ (if (not (listp (cdr ireads)))
+ (setq ireads (list (cons (car ireads) (cdr ireads))))
+ (setq ireads (copy-alist ireads)))))
+ (if (< (or (and (numberp (car ireads)) (car ireads))
+ (cdr (car ireads))) (car active))
+ (setq ireads (setq itreads (cdr ireads))))
+ (if (and ireads (< (or (and (numberp (car ireads))
+ (car ireads))
+ (car (car ireads))) (car active)))
+ (setcar (or (and (numberp (car ireads)) ireads)
+ (car ireads)) (1+ (car active))))
+ (while itreads
+ (setcar (or (and (numberp (car itreads)) itreads)
+ (car itreads))
+ (+ (max
+ 1 (- (if (numberp (car itreads))
+ (car itreads)
+ (car (car itreads)))
+ (car active)))
+ offset))
+ (if (not (numberp (car itreads)))
+ (setcdr (car itreads)
+ (+ (- (cdr (car itreads)) (car active)) offset)))
+ (setq itreads (cdr itreads)))
+ (setq reads (nconc reads ireads))))
+ (setq offset (+ offset (1- itotal)))
+ (setq nnvirtual-current-mapping
+ (cons (list offset igroup (car active))
+ nnvirtual-current-mapping)))
+ (setq groups (cdr groups))))
+ (setq nnvirtual-current-mapping
+ (nreverse nnvirtual-current-mapping))
+ ;; Set Gnus active info.
+ (gnus-sethash group (cons 1 (1- offset)) gnus-active-hashtb)
+ ;; Set Gnus read info.
+ (setcar (nthcdr 2 info) reads)
+
+ ;; Then we deal with the marks.
+ (let ((map nnvirtual-current-mapping)
+ (marks '(tick dormant reply expire score))
+ (offset 0)
+ tick dormant reply expire score marked active)
+ (while map
+ (setq igroup (nth 1 (car map)))
+ (setq active (nth 2 (car map)))
+ (setq marked (nth 3 (nth 2 (gnus-gethash igroup gnus-newsrc-hashtb))))
+ (let ((m marks))
+ (while m
+ (and (assq (car m) marked)
+ (set (car m)
+ (nconc (mapcar
+ (lambda (art)
+ (if (numberp art)
+ (if (< art active)
+ 0 (+ (- art active) offset))
+ (cons (+ (- (car art) active) offset)
+ (cdr art))))
+ (cdr (assq (car m) marked)))
+ (symbol-value (car m)))))
+ (setq m (cdr m))))
+ (setq offset (car (car map)))
+ (setq map (cdr map)))
+ ;; Put the list of marked articles in the info of the virtual group.
+ (let ((m marks)
+ marked)
+ (while m
+ (and (symbol-value (car m))
+ (setq marked (cons (cons (car m) (symbol-value (car m)))
+ marked)))
+ (setq m (cdr m)))
+ (if (nthcdr 3 info)
+ (setcar (nthcdr 3 info) marked)
+ (setcdr (nthcdr 2 info) (list marked)))))))
+
+(defun nnvirtual-update-marked ()
+ (let ((mark-lists '((gnus-newsgroup-marked . tick)
+ (gnus-newsgroup-dormant . dormant)
+ (gnus-newsgroup-expirable . expire)
+ (gnus-newsgroup-replied . reply)))
+ marks art-group group-alist g)
+ (while mark-lists
+ (setq marks (symbol-value (car (car mark-lists))))
+ ;; Find out what groups the mark belong to.
+ (while marks
+ (setq art-group (nnvirtual-art-group (car marks)))
+ (if (setq g (assoc (car art-group) group-alist))
+ (nconc g (list (cdr art-group)))
+ (setq group-alist (cons (list (car art-group) (cdr art-group))
+ group-alist)))
+ (setq marks (cdr marks)))
+ ;; The groups that don't have marks must have no marks. (Yup.)
+ (let ((groups nnvirtual-current-groups))
+ (while groups
+ (or (assoc (car groups) group-alist)
+ (setq group-alist (cons (list (car groups)) group-alist)))
+ (setq groups (cdr groups))))
+ ;; The we update the list of marks.
+ (while group-alist
+ (gnus-add-marked-articles
+ (car (car group-alist)) (cdr (car mark-lists))
+ (cdr (car group-alist)) nil t)
+ (gnus-group-update-group (car (car group-alist)) t)
+ (setq group-alist (cdr group-alist)))
+ (setq mark-lists (cdr mark-lists)))))
+
+(defun nnvirtual-art-group (article)
+ (let ((map nnvirtual-current-mapping)
+ (offset 0))
+ (while (< (car (car map)) (if (numberp article) article (car article)))
+ (setq offset (car (car map))
+ map (cdr map)))
+ (cons (nth 1 (car map))
+ (if (numberp article)
+ (- (+ article (nth 2 (car map))) offset)
+ (cons (- (+ (car article) (nth 2 (car map))) offset)
+ (cdr article))))))
+
+(defun nnvirtual-catchup-group (group &optional server all)
+ (nnvirtual-possibly-change-newsgroups group server)
+ (let ((gnus-group-marked nnvirtual-current-groups)
+ (gnus-expert-user t))
+ (save-excursion
+ (set-buffer gnus-group-buffer)
+ (gnus-group-catchup-current nil all))))
+
+(provide 'nnvirtual)
+
+;;; nnvirtual.el ends here