diff options
| -rw-r--r-- | lisp/=custom.el | 2429 | ||||
| -rw-r--r-- | lisp/gnus-cache.el | 361 | ||||
| -rw-r--r-- | lisp/gnus-cite.el | 585 | ||||
| -rw-r--r-- | lisp/gnus-cus.el | 546 | ||||
| -rw-r--r-- | lisp/gnus-edit.el | 628 | ||||
| -rw-r--r-- | lisp/gnus-ems.el | 693 | ||||
| -rw-r--r-- | lisp/gnus-kill.el | 633 | ||||
| -rw-r--r-- | lisp/gnus-mh.el | 226 | ||||
| -rw-r--r-- | lisp/gnus-msg.el | 1803 | ||||
| -rw-r--r-- | lisp/gnus-score.el | 1643 | ||||
| -rw-r--r-- | lisp/gnus-uu.el | 1889 | ||||
| -rw-r--r-- | lisp/gnus-vis.el | 1428 | ||||
| -rw-r--r-- | lisp/gnus-vm.el | 261 | ||||
| -rw-r--r-- | lisp/gnus.el | 14136 | ||||
| -rw-r--r-- | lisp/nnbabyl.el | 578 | ||||
| -rw-r--r-- | lisp/nndir.el | 141 | ||||
| -rw-r--r-- | lisp/nndoc.el | 400 | ||||
| -rw-r--r-- | lisp/nneething.el | 334 | ||||
| -rw-r--r-- | lisp/nnfolder.el | 704 | ||||
| -rw-r--r-- | lisp/nnheader.el | 358 | ||||
| -rw-r--r-- | lisp/nnkiboze.el | 345 | ||||
| -rw-r--r-- | lisp/nnmail.el | 877 | ||||
| -rw-r--r-- | lisp/nnmbox.el | 508 | ||||
| -rw-r--r-- | lisp/nnmh.el | 516 | ||||
| -rw-r--r-- | lisp/nnml.el | 701 | ||||
| -rw-r--r-- | lisp/nnspool.el | 492 | ||||
| -rw-r--r-- | lisp/nntp.el | 1275 | ||||
| -rw-r--r-- | lisp/nnvirtual.el | 476 |
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 |