*** pub/dgnus/lisp/custom.el Mon May 29 10:31:55 1995 --- dgnus/lisp/custom.el Sun May 28 11:24:35 1995 *************** *** 0 **** --- 1,1354 ---- + ;;; custom.el --- User friendly customization support. + ;; Copyright (C) 1995 Free Software Foundation, Inc. + ;; + ;; Author: Per Abrahamsen + ;; Keywords: help + ;; Version: 0.1 + + ;;; 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'. + ;; - Add description of faces to buffer and mode. + ;; - Function to generate a XEmacs menu from a CUSTOM. + ;; - Add support for customizing packages. + ;; - Make it possible to hide sections by clicling at the level stars. + ;; - Declare AUC TeX variables. + ;; - Declare (ding) Gnus variables. + ;; - Declare Emacs variables. + ;; - Implement remaining types. + ;; - XEmacs port. + + ;;; 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)))))) + + ;; We can't easily check for a working 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)) + + ;;; Faces: + ;; + ;; The following variables define the faces used in the customization + ;; buffer. + + (defvar custom-button-face 'bold + "Face used for tags in customization buffers.") + + (defvar custom-field-uninitialized-face 'modeline + "Face used for uninitialized customization fields.") + + (defvar custom-field-invalid-face 'highlight + "Face used for customization fields containing invalid data.") + + (defvar custom-field-modified-face 'bold-italic + "Face used for modified customization fields.") + + (defvar custom-field-active-face 'underline + "Face used for customization fields while they are being edited.") + + (defvar custom-field-face 'italic + "Face used for customization fields.") + + (defvar custom-mouse-face 'highlight + "Face used for tags in customization buffers.") + + (defvar custom-documentation-properties 'custom-documentation-properties + "The properties of this symbol will be in effect for all documentation.") + (put custom-documentation-properties 'rear-nonsticky t) + + (defvar custom-button-properties 'custom-button-properties + "The properties of this symbol will be in effect for all buttons.") + (put custom-button-properties 'face custom-button-face) + (put custom-button-properties 'mouse-face custom-mouse-face) + (put custom-button-properties 'rear-nonsticky t) + + ;;; 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-value (name) + "The value currently displayed for NAME in the customization buffer." + (let ((field (cdr (assq name custom-name-fields)))) + (car (custom-field-extract (custom-field-custom field) field)))) + + ;;; 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'. + + (defconst custom-data + '((tag . "Emacs") + (doc . "The extensible self-documenting text editor.") + (type . group) + (data . nil)) + "The global customization information. + A custom association list.") + + (defconst custom-type-properties + '((repeat (type . default) + (accept . custom-repeat-accept) + (extract . custom-repeat-extract) + (validate . custom-repeat-validate) + (insert . custom-repeat-insert) + (match . custom-repeat-match) + (query . custom-repeat-query) + (del-tag . "[DEL]") + (add-tag . "[INS]")) + (list (type . group) + (accept . custom-list-accept) + (extract . custom-list-extract) + (validate . custom-list-validate) + (check . custom-list-check)) + (group (type . default) + (extract . nil) + (validate . nil) + (query . custom-toggle-hide) + (accept . custom-group-accept) + (insert . custom-group-insert)) + (toggle (type . choice) + (data ((type . const) + (tag . "On") + (default . t)) + ((type . const) + (tag . "Off") + (default . nil)))) + (choice (type . default) + (query . custom-choice-query) + (accept . custom-choice-accept) + (extract . custom-choice-extract) + (validate . custom-choice-validate) + (check . custom-choice-check) + (insert . custom-choice-insert) + (none (tag . "Unknown") + (default . __uninitialized__) + (type . const))) + (const (type . default) + (accept . ignore) + (extract . (lambda (c f) (list (custom-default c)))) + (validate . (lambda (c f) nil)) + (valid . custom-const-valid) + (insert . custom-const-insert)) + (file (type . string) + (directory . nil) + (default-file . nil) + (query . custom-file-query)) + (integer (type . default) + (width . 10) + (valid . (lambda (c d) (integerp d))) + (allow-padding . nil) + (read . custom-integer-read) + (write . custom-integer-write)) + (string (type . default) + (width . 40) + (valid . (lambda (c d) (stringp d))) + (read . custom-string-read) + (write . custom-string-write)) + (button (type . default) + (accept . ignore) + (extract . nil) + (validate . nil) + (insert . custom-button-insert)) + (doc (type . default) + (rest . nil) + (extract . nil) + (validate . nil) + (insert . custom-documentation-insert)) + (default (width . 20) + (valid . (lambda (c v) t)) + (insert . custom-default-insert) + (query . custom-default-query) + (tag . nil) + (doc . nil) + (header . t) + (padding . ? ) + (allow-padding . t) + (extract . custom-default-extract) + (validate . custom-default-validate) + (reset . custom-default-reset) + (accept . custom-default-accept) + (match . custom-default-match) + (name . nil) + (compact . 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.") + (make-variable-buffer-local 'custom-local-type-properties) + + (defconst custom-nil '__uninitialized__ + "Special value representing an uninitialized 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-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-tag-or-type (custom) + "Extract `tag' from CUSTOM. If none exist, create one from `type'" + (or (custom-property custom 'tag) + (capitalize (symbol-name (custom-type custom))))) + + (defun custom-default (custom) + "Extract `default' from CUSTOM." + (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-allow-padding (custom) + "Extract `allow-padding' from CUSTOM." + (custom-property custom 'allow-padding)) + + (defun custom-valid (custom value) + "Non-nil if CUSTOM may legally be set to VALUE." + (funcall (custom-property custom 'valid) custom value)) + + (defun custom-write (custom value) + "Convert CUSTOM VALUE to a string." + (if (eq value custom-nil) + "" + (funcall (custom-property custom 'write) custom value))) + + (defun custom-read (custom string) + "Convert CUSTOM field content STRING into external form." + (funcall (custom-property custom 'read) custom 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." + (if (memq values (list custom-nil nil)) + (cons custom-nil nil) + (funcall (custom-property custom 'match) custom values))) + + (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. + + (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) + "Accept FIELD VALUE. + If optional ORIGINAL is non-nil, concider VALUE for the original value." + (funcall (custom-property (custom-field-custom field) 'accept) + field value original)) + + ;;; Types: + ;; + ;; The following functions defines type specific actions. + + (defun custom-repeat-accept (field value &optional original) + "Enter content of editing FIELD." + (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)) + (del-tag (custom-property custom 'del-tag)) + (start (make-marker)) + (data (vector field nil start nil))) + (custom-text-insert "\n") + (let ((pos (point))) + (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-function nil) + (after-change-function 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-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-function nil) + (after-change-function 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 + ;; (message "Before values = %S result = %S" values result) + (setq result (append result (custom-field-extract data (car values))) + values (cdr values)) + ;; (message "After values = %S result = %S" values result) + )) + 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-list-accept (field value &optional original) + "Enter content of editing FIELD with VALUE." + (let ((values (custom-field-value field)) + current) + (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-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-list-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-accept (field value &optional original) + "Enter content of editing FIELD with VALUE." + (let ((values (custom-field-value field)) + value original) + (if original + (custom-field-original-set field value)) + (while values + (setq current (car values) + values (cdr values)) + (if (consp originals) + (setq new (car value) + value (cdr value)) + (setq original custom-nil)) + (if (null current) + () + (custom-field-accept current new 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 + (from (point)) + (compact (custom-compact custom)) + (tag (custom-tag custom))) + (if 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 data (cdr data)) + (if data (custom-text-insert (if compact " " "\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)) + (tag (custom-tag custom))) + (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) + "Reset content of editing FIELD." + (let ((custom (custom-field-custom field)) + (start (custom-field-start field)) + (end (custom-field-end field)) + (inhibit-read-only t) + (before-change-function nil) + (after-change-function 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) + (set-text-properties (point) (1+ (point)) + (list 'invisible t + intangible t)) + (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))) + (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)) + (default (custom-tag-or-type + (custom-field-custom (custom-field-value field)))) + (tag (custom-tag-or-type custom)) + (data (custom-data custom)) + current alist) + (while data + (setq current (car data) + data (cdr data)) + (setq alist (cons (cons (custom-tag-or-type current) current) alist))) + (let ((answer (if (listp last-input-event) + (x-popup-menu last-input-event + (list tag (cons "" (reverse alist)))) + (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-const-insert (custom level) + "Insert field for CUSTOM at nesting LEVEL in customization buffer." + (let ((field (custom-field-create custom custom-nil)) + (from (point))) + (custom-text-insert (custom-tag custom)) + (custom-documentation-insert custom) + (custom-field-move field from (point)) + field)) + + (defun custom-const-valid (custom value) + "Non-nil if CUSTOM can legally have the value VALUE." + (equal (custom-default custom) value)) + + (defun custom-integer-read (custom integer) + "Read from CUSTOM an INTEGER." + (string-to-int (save-match-data + (custom-strip-padding integer (custom-padding custom))))) + + (defun custom-integer-write (custom integer) + "Write CUSTOM INTEGER as string." + (int-to-string integer)) + + (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-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) + "Enter into FIELD the value VALUE." + (if original + (custom-field-original-set field value)) + (custom-field-value-set field value) + (custom-field-update field)) + + (defun custom-default-reset (field) + "Reset content of editing FIELD." + (custom-field-accept field (custom-field-original field) t)) + + (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-tag-or-type 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 (custom-field-start field) "Uninitialized field")) + ((custom-valid custom value) + nil) + (t + (const start "Wrong type"))))) + + ;;; Create Buffer: + ;; + ;; Public functions to create a customization buffer and to insert + ;; various forms of text, fields, and buttons in it. + + (defun custom-buffer-create (name &optional custom types set get) + "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." + (switch-to-buffer name) + (buffer-disable-undo) + (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)) + (let ((inhibit-point-motion-hooks t) + (before-change-function nil) + (after-change-function 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-enter-value) + (custom-help-button 'custom-field-reset) + (custom-help-button 'custom-field-apply) + (custom-help-button 'custom-toggle-documentation) + (custom-help-insert "\nClick mouse-2 on any button to activate it.\n") + (custom-insert custom 1) + (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)) + (if level + (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) + (set-text-properties from (point) + (list 'category custom-button-properties + '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) + (set-text-properties from (point) + (list 'category 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 'category custom-documentation-properties + 'face custom-button-face + 'mouse-face custom-mouse-face + 'custom-tag command))) + (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 [ mouse-2 ] 'custom-push-button) + (define-key custom-mode-map "\t" 'custom-forward-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-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-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-function) + (setq before-change-function 'custom-before-change) + (make-local-variable 'after-change-function) + (setq after-change-function 'custom-after-change) + (if (not (fboundp 'make-local-hook)) + ;; Emacs 19.28 and earlier. + (add-hook 'post-command-hook 'custom-post-command nil) + ;; 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) + (setq arg (1- arg)) + (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."))))) + + (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 (get custom-documentation-properties 'invisible))) + (<= (prefix-numeric-value arg) 0)))) + (put custom-documentation-properties 'invisible hide) + (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") + (set-buffer (window-buffer (posn-window (event-start event)))) + (let* ((pos (posn-point (event-start 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 name field) + (while all + (setq current (car all) + name (car current) + 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 (not (arrayp field)) + (error "No field to reset here")) + (let* ((custom (custom-field-custom field)) + (name (custom-name custom))) + (save-excursion + (if name + (custom-field-original-set field (custom-external name))) + (funcall (custom-property custom 'reset) field)))) + + (defun custom-apply-all () + "Apply any changes since the last reset in all fields." + (interactive (or custom-modified-list + (error "No changes to apply."))) + (let ((all custom-name-fields) + name 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) + current name 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)))) + (if (not (arrayp field)) + (error "No field to reset here")) + (let* ((custom (custom-field-custom field)) + (name (custom-name custom)) + (error (custom-field-validate custom field))) + (cond ((null name) + (error "This field cannot be applied alone")) + (error + (error (cdr error))) + (t + (custom-external-set name (car (custom-field-extract custom field))) + (custom-field-reset field))))) + + (defun custom-toggle-hide (&rest ignore) + "Hide or show entry." + (interactive) + (error "This button is not yet implemented")) + + ;;; Field Editing: + ;; + ;; Various internal functions for implementing the direct editing of + ;; fields in the customization buffer. + + (defvar custom-modified-list nil) + ;; List of modified fields. + (make-variable-buffer-local 'custom-modified-list) + + (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 ((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-update (field) + ;; Update the content of FIELD. + (let ((inhibit-point-motion-hooks t) + (before-change-function nil) + (after-change-function 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)))) + + (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)))) + + (defun custom-field-face (field) + ;; Face used for an inactive field 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-field-leave (field) + ;; Deactivate FIELD. + (let ((before-change-function nil) + (after-change-function 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)) + (allow (custom-allow-padding custom)) + (before-change-function nil) + (after-change-function nil)) + (or (and (eq this-command 'self-insert-command) + allow) + (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))) + + (defvar custom-field-last nil) + ;; Last field containing point. + (make-variable-buffer-local 'custom-field-last) + + (defun custom-post-command () + ;; Keep track of their active field. + (if (not (eq major-mode 'custom-mode)) + ;; BUG: Should have been local! + () + (let ((field (custom-field-property (point)))) + (if (eq field 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 custom-modified-list))) + + (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)) + (custom-field-value-set field (custom-field-read field)) + (custom-field-update 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) + + (provide 'custom) + + ;;; custom.el ends here *** pub/dgnus/lisp/gnus-edit.el Mon May 29 10:31:56 1995 --- dgnus/lisp/gnus-edit.el Sun May 28 09:25:05 1995 *************** *** 0 **** --- 1,505 ---- + ;;; gnus-edit.el --- Gnus SCORE file editing. + ;; Copyright (C) 1995 Free Software Foundation, Inc. + ;; + ;; Author: Per Abrahamsen + ;; Keywords: news, help + ;; Version: 0.0 + + ;;; Commentary: + ;; + ;; Type `M-x gnus-score-customize RET' to invoke. + + ;;; Code: + + (require 'custom) + + (autoload 'gnus-score-load "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 "" + ((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)) + ; ;; Sexp type isn't implemented yet. + ; ((name . eval) + ; (tag . "Eval") + ; (doc . "Evaluate this expression when the entering sumamry buffer.") + ; (type . sexp)) + ;; Toggle type isn't implemented yet. + ((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) + (header . nil) + (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) + (header . nil) + (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) + (header . nil) + (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))))) + ;; This is to complex for me to figure out right now. + ;`adapt' + ; This entry controls the adaptive scoring. If it is `t', the + ; default adaptive scoring rules will be used. If it is `ignore', no + ; adaptive scoring will be performed on this group. If it is a + ; list, this list will be used as the adaptive scoring rules. If it + ; isn't present, or is something other than `t' or `ignore', the + ; default adaptive scoring rules will be used. If you want to use + ; adaptive scoring on most groups, you'd set + ; `gnus-use-adaptive-scoring' to `t', and insert an `(adapt ignore)' + ; in the groups where you do not want adaptive scoring. If you only + ; want adaptive scoring in a few groups, you'd set + ; `gnus-use-adaptive-scoring' to `nil', and insert `(adapt t)' in + ; the score files of the groups where you want it. + ;; This isn't implemented in the old version of (ding) I use. + ;`local' + ; List of local variables to bind in the summary buffer. + + (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)) + (make-local-variable 'gnus-score-custom-file) + (setq gnus-score-custom-file "SCORE") + (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 (memq name '(files)) + (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))) + ((listp value) + (setcdr (assoc name gnus-score-alist) value)) + (t + (setcdr (assoc name gnus-score-alist) (list value))))) + ((null value)) + ((litsp value) + (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) + (if (null (nth 3 entry)) + 's + (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 *** pub/dgnus/lisp/gnus-kill.el Sat May 27 11:20:54 1995 --- dgnus/lisp/gnus-kill.el Sun May 28 20:31:52 1995 *************** *** 356,393 **** gnus-newsgroup-kill-headers))) (setq headers (cdr headers)))) (setq files nil)) ! (setq files (cdr files))))) ! (if gnus-newsgroup-kill-headers ! (save-excursion ! (while kill-files ! (if (file-exists-p (car kill-files)) ! (progn ! (message "Processing kill file %s..." (car kill-files)) ! (find-file (car kill-files)) ! (gnus-kill-file-mode) ! (gnus-add-current-to-buffer-list) ! (goto-char (point-min)) ! (while (progn ! (setq beg (point)) ! (setq form (condition-case nil ! (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) ""))) ! (condition-case () ! (eval form) ! (error nil)))) ! (and (buffer-modified-p) (save-buffer)) ! (message "Processing kill file %s...done" (car kill-files)))) ! (setq kill-files (cdr kill-files))))) (if beg (let ((nunreads (- unreads (length gnus-newsgroup-unreads)))) (or (eq nunreads 0) --- 356,381 ---- gnus-newsgroup-kill-headers))) (setq headers (cdr headers)))) (setq files nil)) ! (setq files (cdr files))))) ! (if (not gnus-newsgroup-kill-headers) ! () ! (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))))) ! (if beg (let ((nunreads (- unreads (length gnus-newsgroup-unreads)))) (or (eq nunreads 0) *************** *** 395,403 **** nunreads) 0))) ;; Kill changes and new format by suggested by JWZ and Sudish Joseph ;; . ! (defun gnus-kill (field regexp &optional exe-command all) "If FIELD of an article matches REGEXP, execute COMMAND. Optional 1st argument COMMAND is default to (gnus-summary-mark-as-read nil \"X\"). --- 383,459 ---- 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) ""))) + (condition-case () (eval form) (error nil)))) + (and (buffer-modified-p) (save-buffer)))) + + ;; 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 ;; . ! (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\"). *************** *** 447,453 **** (setq prev kill-list) (setq kill-list (cdr kill-list)))) (gnus-execute field kill-list command nil (not all)))))) ! (if (and (eq major-mode 'gnus-kill-file-mode) regexp) (gnus-pp-gnus-kill (nconc (list 'gnus-kill field (if (consp regexp) (list 'quote regexp) regexp)) --- 503,509 ---- (setq prev kill-list) (setq kill-list (cdr kill-list)))) (gnus-execute field kill-list command nil (not all)))))) ! (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)) *** pub/dgnus/lisp/gnus-msg.el Sat May 27 11:20:54 1995 --- dgnus/lisp/gnus-msg.el Mon May 29 09:52:52 1995 *************** *** 1411,1417 **** (progn (save-excursion (mail-yank-original nil)) ! (run-hooks 'news-reply-header-hook)) (while yank (save-window-excursion (set-buffer gnus-summary-buffer) --- 1411,1418 ---- (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) *************** *** 1421,1427 **** (gnus-copy-article-buffer) (mail-yank-original nil) (setq end (point))) ! (run-hooks 'news-reply-header-hook) (goto-char end) (setq yank (cdr yank)))) (goto-char last)) --- 1422,1429 ---- (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)) *************** *** 1432,1438 **** (interactive) (save-excursion (mail-yank-original nil)) ! (run-hooks 'news-reply-header-hook)) (defun gnus-mail-send-and-exit () (interactive) --- 1434,1441 ---- (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) *** pub/dgnus/lisp/gnus-score.el Sat May 27 11:20:54 1995 --- dgnus/lisp/gnus-score.el Sun May 28 19:11:14 1995 *************** *** 119,124 **** --- 119,125 ---- (defun gnus-summary-increase-score (score) (interactive "P") + (gnus-set-global-variables) (let* ((nscore (gnus-score-default score)) (prefix (if (< nscore 0) ?L ?I)) (increase (> nscore 0)) *************** *** 134,152 **** (?d "date") (?f "followup"))) (char-to-type ! '((?e e) (?f f) (?s s) (?r r) (?b before) ! (?a at) (?n now) (?< <) (?> >) (?= =))) (char-to-perm ! (list (list ?t (current-time-string)) '(?p perm) '(?i now))) (mimic gnus-score-mimic-keymap) hchar entry temporary tchar pchar end type) ;; First we read the header to score. ! (if mimic ! (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)) (or (setq entry (assq (downcase hchar) char-to-header)) (progn (ding) --- 135,168 ---- (?d "date") (?f "followup"))) (char-to-type ! '((?s s "substring") (?e e "exact string") (?f f "fuzzy string") ! (?r r "regexp string") ! (?b before "before date") (?a at "at date") (?n now "this date") ! (?< < "less than number") (?> > "greater than number") ! (?= = "equal to 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 ! (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 (= hchar ??)) ! () ! (setq hchar nil) ! (gnus-score-insert-help "Match on header" char-to-header 1))) ! ! (and (get-buffer "*Score Help*") ! (progn ! (delete-windows-on "*Score Help*") ! (kill-buffer "*Score Help*"))) ! (or (setq entry (assq (downcase hchar) char-to-header)) (progn (ding) *************** *** 158,172 **** (if mimic (message "%c %c" prefix hchar) (message "")) (setq type nil temporary (current-time-string))) ;; We continue reading - the type. ! (if mimic ! (message "%c %c-" prefix hchar) ! (message "%s header '%s' with match type (%s): " ! (if increase "Increase" "Lower") ! (nth 1 entry) ! (mapconcat (lambda (s) (char-to-string (car s))) ! char-to-type ""))) ! (setq tchar (read-char)) (or (setq type (nth 1 (assq (downcase tchar) char-to-type))) (progn (ding) --- 174,200 ---- (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 ! (message "%c %c-" prefix hchar) ! (message "%s header '%s' with match type (%s?): " ! (if increase "Increase" "Lower") ! (nth 1 entry) ! (mapconcat (lambda (s) (char-to-string (car s))) ! char-to-type ""))) ! (setq tchar (read-char)) ! (if (not (= tchar ??)) ! () ! (setq tchar nil) ! (gnus-score-insert-help "Match type" char-to-type 2))) ! ! (and (get-buffer "*Score Help*") ! (progn ! (delete-windows-on "*Score Help*") ! (kill-buffer "*Score Help*"))) ! (or (setq type (nth 1 (assq (downcase tchar) char-to-type))) (progn (ding) *************** *** 178,190 **** (if mimic (message "%c %c %c" prefix hchar tchar) (message "")) (setq temporary (current-time-string))) ;; We continue reading. ! (if mimic ! (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 mimic (message "%c %c %c" prefix hchar tchar pchar) (message "")) (if (setq temporary (nth 1 (assq pchar char-to-perm))) --- 206,230 ---- (if mimic (message "%c %c %c" prefix hchar tchar) (message "")) (setq temporary (current-time-string))) + ;; We continue reading. ! (while (not pchar) ! (if mimic ! (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 (= pchar ??)) ! () ! (setq pchar nil) ! (gnus-score-insert-help "Match permanence" char-to-perm 2))) ! ! (and (get-buffer "*Score Help*") ! (progn ! (delete-windows-on "*Score Help*") ! (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))) *************** *** 208,213 **** --- 248,263 ---- (not (nth 3 entry))) ; Prompt ))) + (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-summary-header (header) ;; Return HEADER for current articles, or error. (let ((article (gnus-summary-article-number))) *************** *** 1343,1349 **** () (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 --- 1393,1399 ---- () (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 *************** *** 1361,1366 **** --- 1411,1417 ---- (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. *************** *** 1400,1406 **** 'e 's) (nth 2 (car elem)) date nil t) (setq elem (cdr elem)))) ! (delete-region (point) (progn (forward-line 1) (point))))))) ;;; ;;; Score mode. --- 1451,1459 ---- '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. *** pub/dgnus/lisp/gnus-vis.el Sat May 27 11:20:56 1995 --- dgnus/lisp/gnus-vis.el Sun May 28 18:51:53 1995 *************** *** 362,367 **** --- 362,368 ---- ["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]) )) *** pub/dgnus/lisp/gnus.el Sat May 27 11:20:57 1995 --- dgnus/lisp/gnus.el Mon May 29 09:52:51 1995 *************** *** 1272,1278 **** (defconst gnus-maintainer "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls & Boys)" "The mail address of the Gnus maintainer.") ! (defconst gnus-version "(ding) Gnus v0.78" "Version number for this version of Gnus.") (defvar gnus-info-nodes --- 1272,1278 ---- (defconst gnus-maintainer "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls & Boys)" "The mail address of the Gnus maintainer.") ! (defconst gnus-version "(ding) Gnus v0.79" "Version number for this version of Gnus.") (defvar gnus-info-nodes *************** *** 1725,1735 **** (defun gnus-extract-address-components (from) (let (name address) (if (string-match "\\b[^@ \t<>]+[!@][^@ \t<>]+\\b" from) (setq address (substring from (match-beginning 0) (match-end 0)))) (and address (string-match (concat "<" (regexp-quote address) ">") from) ! (setq name (substring from 0 (1- (match-beginning 0))))) (or name (and (string-match "(.+)" from) (setq name (substring from (1+ (match-beginning 0)) --- 1725,1743 ---- (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
" format is used. (and address (string-match (concat "<" (regexp-quote address) ">") from) ! (and (setq name (substring from 0 (1- (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)) *************** *** 1913,1918 **** --- 1921,1927 ---- (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))) *************** *** 3911,3929 **** (defun gnus-group-make-help-group () "Create the (ding) Gnus documentation group." (interactive) - (and (gnus-gethash (gnus-group-prefixed-name "gnus-help" '(nndoc "")) - gnus-newsrc-hashtb) - (error "Documentation group already exists")) (let ((path load-path)) (while (and path (not (file-exists-p (concat (file-name-as-directory (car path)) "doc.txt")))) (setq path (cdr path))) (or path (error "Couldn't find doc group")) (gnus-group-make-group ! "gnus-help" "nndoc" ! (concat (file-name-as-directory (car path)) "doc.txt")) ! (gnus-group-position-cursor))) (defun gnus-group-make-doc-group (file type) "Create a group that uses a single file as the source." --- 3920,3941 ---- (defun gnus-group-make-help-group () "Create the (ding) Gnus documentation group." (interactive) (let ((path load-path)) + (and (gnus-gethash (setq name (gnus-group-prefixed-name + "gnus-help" '(nndoc "gnus-help"))) + gnus-newsrc-hashtb) + (error "Documentation group already exists")) (while (and path (not (file-exists-p (concat (file-name-as-directory (car path)) "doc.txt")))) (setq path (cdr path))) (or path (error "Couldn't find doc group")) (gnus-group-make-group ! (gnus-group-real-name name) ! (list 'nndoc name ! (list 'nndoc-address (concat (file-name-as-directory (car path)) "doc.txt")) ! (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." *************** *** 4351,4361 **** (run-hooks 'gnus-get-new-news-hook) (let ((level arg)) (if gnus-group-use-permanent-levels ! (progn ! (if level ! (setq gnus-group-default-list-level level) ! (setq level (or gnus-group-default-list-level ! gnus-level-subscribed))))) (if (and gnus-read-active-file (not level)) (progn (gnus-read-active-file) --- 4363,4372 ---- (run-hooks 'gnus-get-new-news-hook) (let ((level arg)) (if gnus-group-use-permanent-levels ! (if level ! (setq gnus-group-default-list-level level) ! (setq level (or gnus-group-default-list-level ! gnus-level-subscribed)))) (if (and gnus-read-active-file (not level)) (progn (gnus-read-active-file) *************** *** 4363,4368 **** --- 4374,4380 ---- (let ((gnus-read-active-file nil)) (gnus-get-unread-articles (or level (1+ gnus-level-subscribed))))) (gnus-group-list-groups (or (and gnus-group-use-permanent-levels level) + gnus-group-default-list-level gnus-level-subscribed) gnus-have-all-newsgroups))) *************** *** 4603,4608 **** --- 4615,4621 ---- (progn (run-hooks 'gnus-exit-gnus-hook) (gnus-save-newsrc-file) + (gnus-offer-save-summaries) (gnus-close-backends) (gnus-clear-system)))) *************** *** 4631,4637 **** (progn (run-hooks 'gnus-exit-gnus-hook) (gnus-dribble-save) - (gnus-offer-save-summaries) (gnus-close-backends) (gnus-clear-system)))) --- 4644,4649 ---- *************** *** 4645,4654 **** (progn (set-buffer (car buffers)) ;; We check that this is, indeed, a summary buffer. ! (eq 'major-mode 'gnus-summary-mode)) ;; We ask the user whether she wants to save the info. ! (not (gnus-y-or-n-p ! (format "Discard summary buffer %s? " (buffer-name)))) ;; We do it by simply exiting. (gnus-summary-exit)) (setq buffers (cdr buffers)))))) --- 4657,4666 ---- (progn (set-buffer (car buffers)) ;; We check that this is, indeed, a summary buffer. ! (eq major-mode 'gnus-summary-mode)) ;; We ask the user whether she wants to save the info. ! (gnus-y-or-n-p ! (format "Update summary buffer %s? " (buffer-name))) ;; We do it by simply exiting. (gnus-summary-exit)) (setq buffers (cdr buffers)))))) *************** *** 5485,5494 **** (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. --- 5497,5506 ---- (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. *************** *** 5500,5506 **** (if (and (not no-article) gnus-auto-select-first (gnus-summary-first-unread-article)) ! (gnus-configure-windows 'article) (gnus-configure-windows 'summary)) (gnus-set-mode-line 'summary) (gnus-summary-position-cursor) --- 5512,5518 ---- (if (and (not no-article) gnus-auto-select-first (gnus-summary-first-unread-article)) ! () (gnus-configure-windows 'summary)) (gnus-set-mode-line 'summary) (gnus-summary-position-cursor) *************** *** 5514,5520 **** (funcall gnus-asynchronous-article-function gnus-newsgroup-threads) gnus-newsgroup-threads))) ! (gnus-kill-buffer kill-buffer)) t)))) (defun gnus-summary-prepare () --- 5526,5539 ---- (funcall gnus-asynchronous-article-function gnus-newsgroup-threads) gnus-newsgroup-threads))) ! (gnus-kill-buffer kill-buffer) ! (if (not (get-buffer-window gnus-group-buffer)) ! () ! (let ((obuf (current-buffer))) ! (set-buffer gnus-group-buffer) ! (and (gnus-group-goto-group group) ! (recenter)) ! (set-buffer obuf)))) t)))) (defun gnus-summary-prepare () *************** *** 7568,7573 **** --- 7587,7593 ---- (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)) *************** *** 7584,7600 **** (gnus-message 3 "End of message")) ((null lines) (gnus-summary-next-unread-article))))) - (gnus-configure-windows 'article) (gnus-summary-recenter) (gnus-summary-position-cursor))) - (defun gnus-summary-prev-page (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))) (if (or (null gnus-current-article) (null gnus-article-current) (/= article (cdr gnus-article-current)) --- 7604,7619 ---- (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 (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)) *************** *** 7604,7610 **** (gnus-summary-recenter) (gnus-eval-in-buffer-window gnus-article-buffer (gnus-article-prev-page lines)))) - (gnus-configure-windows 'article) (gnus-summary-position-cursor)) (defun gnus-summary-scroll-up (lines) --- 7623,7628 ---- *************** *** 7739,7745 **** (defun gnus-summary-refer-article (message-id) "Refer article specified by MESSAGE-ID. ! NOTE: This command only works with newsgroup that use NNTP." (interactive "sMessage-ID: ") (if (or (not (stringp message-id)) (zerop (length message-id))) --- 7757,7763 ---- (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))) *************** *** 8232,8238 **** "Import a random file into a mail newsgroup." (interactive "fImport file: ") (let ((group gnus-newsgroup-name) ! attrib) (or (gnus-check-backend-function 'request-accept-article group) (error "%s does not support article importing" group)) (or (file-readable-p file) --- 8250,8256 ---- "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) *************** *** 8244,8252 **** (erase-buffer) (insert-file-contents file) (goto-char (point-min)) ! (setq attrib (file-attributes file)) ! (insert "From: " (read-string "From: "))))) ! (defun gnus-summary-expire-articles () "Expire all articles that are marked as expirable in the current group." --- 8262,8276 ---- (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." *************** *** 8706,8712 **** (delete-char 1) (insert mark) (and plist (add-text-properties (1- (point)) (point) plist)) ! (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) --- 8730,8737 ---- (delete-char 1) (insert mark) (and plist (add-text-properties (1- (point)) (point) plist)) ! (and (eq type 'unread) ! (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) *************** *** 9046,9051 **** --- 9071,9077 ---- (interactive) (beginning-of-line) (gnus-summary-catchup all t (point)) + (gnus-set-mode-line 'summary) (gnus-summary-position-cursor)) (defun gnus-summary-catchup-all (&optional quietly) *************** *** 10094,10100 **** (end-of-line 1) (let ((paragraph-start "^\\W")) (while (not (eobp)) ! (and (>= (current-column) (window-width)) (/= (preceding-char) ?:) (fill-paragraph nil)) (end-of-line 2)))))) --- 10120,10126 ---- (end-of-line 1) (let ((paragraph-start "^\\W")) (while (not (eobp)) ! (and (>= (current-column) (min fill-column (window-width))) (/= (preceding-char) ?:) (fill-paragraph nil)) (end-of-line 2)))))) *************** *** 10959,10964 **** --- 10985,10991 ---- (defun gnus-request-group (group &optional dont-check) (let ((method (gnus-find-method-for-group group))) + ; (and t (message "%s GROUP %s" (car method) group)) (funcall (gnus-get-function method 'request-group) (gnus-group-real-name group) (nth 1 method) dont-check))) *** pub/dgnus/lisp/nnbabyl.el Sat May 27 11:20:57 1995 --- dgnus/lisp/nnbabyl.el Mon May 29 09:52:49 1995 *************** *** 144,149 **** --- 144,151 ---- (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))) *************** *** 445,452 **** (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 - (get-buffer nnbabyl-mbox-buffer) (buffer-name nnbabyl-mbox-buffer) (save-excursion (set-buffer nnbabyl-mbox-buffer) --- 447,454 ---- (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) *************** *** 526,537 **** (set-buffer nnbabyl-mbox-buffer) (save-buffer))) (while incomings ! ;; The following has been commented away, just to make sure ! ;; that nobody ever loses any mail. If you feel safe that ! ;; nnfolder will never do anything strange, just remove those ! ;; two semicolons, and avoid having lots of "Incoming*" ! ;; files. ! ;; (and (file-writable-p incoming) (delete-file incoming)) (setq incomings (cdr incomings)))))) (provide 'nnbabyl) --- 528,536 ---- (set-buffer nnbabyl-mbox-buffer) (save-buffer))) (while incomings ! (and nnmail-delete-incoming ! (file-writable-p incoming) ! (delete-file incoming)) (setq incomings (cdr incomings)))))) (provide 'nnbabyl) *** pub/dgnus/lisp/nndoc.el Sat May 27 11:20:57 1995 --- dgnus/lisp/nndoc.el Sun May 28 10:22:15 1995 *************** *** 36,48 **** (list (list 'mbox (concat "^" rmail-unix-mail-delimiter) (concat "^" rmail-unix-mail-delimiter) ! nil "^$" nil) ! (list 'babyl "\^_\^L *\n" "\^_" nil "^$" nil) (list 'digest "^------------------------------[\n \t]+" "^------------------------------[\n \t]+" nil "^$" ! "^------------------------------*[\n \t]*\n[^ ]+: ")) "Regular expressions for articles of the various types.") --- 36,49 ---- (list (list 'mbox (concat "^" rmail-unix-mail-delimiter) (concat "^" rmail-unix-mail-delimiter) ! nil "^$" nil nil) ! (list 'babyl "\^_\^L *\n" "\^_" nil "^$" nil nil) (list 'digest "^------------------------------[\n \t]+" "^------------------------------[\n \t]+" nil "^$" ! "^------------------------------*[\n \t]*\n[^ ]+: " ! "End of")) "Regular expressions for articles of the various types.") *************** *** 52,57 **** --- 53,59 ---- (defvar nndoc-head-begin nil) (defvar nndoc-head-end nil) (defvar nndoc-first-article nil) + (defvar nndoc-end-of-file nil) (defvar nndoc-current-server nil) (defvar nndoc-server-alist nil) *************** *** 65,70 **** --- 67,73 ---- '(nndoc-first-article nil) '(nndoc-current-buffer nil) '(nndoc-group-alist nil) + '(nndoc-end-of-file nil) '(nndoc-address nil))) (defconst nndoc-version "nndoc 0.1" *************** *** 152,158 **** (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))) t)) (defun nndoc-close-server (&optional server) --- 155,162 ---- (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))) t)) (defun nndoc-close-server (&optional server) *************** *** 271,276 **** --- 275,282 ---- (goto-char (point-min)) (let ((num 0)) (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)) *** pub/dgnus/lisp/nneething.el Sat May 27 11:20:57 1995 --- dgnus/lisp/nneething.el Mon May 29 07:22:00 1995 *************** *** 133,139 **** (not (file-directory-p file)) ; It's not a dir. (save-excursion (nnmail-find-file file) ; Insert the file in the nntp buf. ! (or (nneething-article-p) ; Either it's a real article... (progn (goto-char (point-min)) (nneething-make-head file) ; ... or we fake some headers. --- 133,139 ---- (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. *************** *** 263,281 **** (and (nneething-get-head file) (insert-buffer-substring nneething-work-buffer))) - (defun nneething-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 (and (looking-at "[\t ]\\|[A-Z][^ \t]+:\\|From ") - (zerop (forward-line 1)))) - (if (not (eobp)) - nil - (widen) - t))) - (defun nneething-make-head (file) (let ((atts (file-attributes file))) (insert "Subject: " (file-name-nondirectory file) "\n" --- 263,268 ---- *************** *** 285,294 **** (1+ nneething-message-id-number))) "@" (system-name) ">\n" "Date: " (current-time-string (nth 5 atts)) "\n" ! "From: " (user-login-name (nth 2 atts)) ! "@" (system-name) " (" (user-full-name) ")\n" "Chars: " (int-to-string (nth 7 atts)) "\n"))) (defun nneething-get-head (file) (save-excursion (set-buffer (get-buffer-create nneething-work-buffer)) --- 272,295 ---- (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)) *************** *** 300,306 **** (if (or (not (file-regular-p file)) (progn (nnheader-insert-head file) ! (if (nneething-article-p) (progn (delete-region (point) (point-max)) nil)))) --- 301,307 ---- (if (or (not (file-regular-p file)) (progn (nnheader-insert-head file) ! (if (nnheader-article-p) (progn (delete-region (point) (point-max)) nil)))) *** pub/dgnus/lisp/nnfolder.el Sat May 27 11:20:57 1995 --- dgnus/lisp/nnfolder.el Mon May 29 09:52:48 1995 *************** *** 651,662 **** (and (buffer-modified-p) (save-buffer))) (setq bufs (cdr bufs))))) (while incomings ! ;; The following has been commented away, just to make sure ! ;; that nobody ever loses any mail. If you feel safe that ! ;; nnfolder will never do anything strange, just remove those ! ;; two semicolons, and avoid having lots of "Incoming*" ! ;; files. ! ;; (and (file-writable-p incoming) (delete-file incoming)) (setq incomings (cdr incomings)))))) (provide 'nnfolder) --- 651,660 ---- (and (buffer-modified-p) (save-buffer))) (setq bufs (cdr bufs))))) (while incomings ! (and ! nnmail-delete-incoming ! (file-writable-p incoming) ! (delete-file incoming)) (setq incomings (cdr incomings)))))) (provide 'nnfolder) *** pub/dgnus/lisp/nnheader.el Sat May 27 11:20:57 1995 --- dgnus/lisp/nnheader.el Sun May 28 18:50:56 1995 *************** *** 194,200 **** file nil beg (setq beg (+ chop beg))))) (prog1 (not (search-backward "\n\n" nil t)) (goto-char (point-max))))))) ! (provide 'nnheader) --- 194,211 ---- 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)))) (provide 'nnheader) *** pub/dgnus/lisp/nnmail.el Sat May 27 11:20:57 1995 --- dgnus/lisp/nnmail.el Mon May 29 10:13:50 1995 *************** *** 181,186 **** --- 181,190 ---- (mail . "mailer-daemon\\|postmaster")) "*Alist of abbrevations allowed in `nnmail-split-fancy'.") + (defvar nnmail-delete-incoming nil + "*If non-nil, the mail backends will delete incoming files after splitting. + This is nil by default for reasons of security.") + (defconst nnmail-version "nnml 0.0" *** pub/dgnus/lisp/nnmbox.el Sat May 27 11:20:57 1995 --- dgnus/lisp/nnmbox.el Mon May 29 09:52:48 1995 *************** *** 52,58 **** (defvar nnmbox-current-group nil "Current nnmbox news group directory.") ! (defconst nnmbox-mbox-buffer " *nnmbox mbox buffer*") (defvar nnmbox-status-string "") --- 52,58 ---- (defvar nnmbox-current-group nil "Current nnmbox news group directory.") ! (defconst nnmbox-mbox-buffer nil) (defvar nnmbox-status-string "") *************** *** 149,154 **** --- 149,156 ---- (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))) *************** *** 362,368 **** (delete-region (point-min) (point-max)))))) (defun nnmbox-possibly-change-newsgroup (newsgroup) ! (if (not (get-buffer nnmbox-mbox-buffer)) (save-excursion (set-buffer (setq nnmbox-mbox-buffer (find-file-noselect nnmbox-mbox-file))) --- 364,371 ---- (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 (find-file-noselect nnmbox-mbox-file))) *************** *** 415,421 **** (if (not (file-exists-p nnmbox-mbox-file)) (write-region 1 1 nnmbox-mbox-file t 'nomesg)) (if (and nnmbox-mbox-buffer - (get-buffer nnmbox-mbox-buffer) (buffer-name nnmbox-mbox-buffer) (save-excursion (set-buffer nnmbox-mbox-buffer) --- 418,423 ---- *************** *** 479,490 **** (set-buffer nnmbox-mbox-buffer) (save-buffer))) (while incomings ! ;; The following has been commented away, just to make sure ! ;; that nobody ever loses any mail. If you feel safe that ! ;; nnfolder will never do anything strange, just remove those ! ;; two semicolons, and avoid having lots of "Incoming*" ! ;; files. ! ;; (and (file-writable-p incoming) (delete-file incoming)) (setq incomings (cdr incomings)))))) --- 481,489 ---- (set-buffer nnmbox-mbox-buffer) (save-buffer))) (while incomings ! (and nnmail-delete-incoming ! (file-writable-p incoming) ! (delete-file incoming)) (setq incomings (cdr incomings)))))) *** pub/dgnus/lisp/nnmh.el Sat May 27 11:20:58 1995 --- dgnus/lisp/nnmh.el Mon May 29 09:52:47 1995 *************** *** 413,424 **** (if incoming (message "nnmh: Reading incoming mail...done")) (while incomings ! ;; The following has been commented away, just to make sure ! ;; that nobody ever loses any mail. If you feel safe that ! ;; nnfolder will never do anything strange, just remove those ! ;; two semicolons, and avoid having lots of "Incoming*" ! ;; files. ! ;; (and (file-writable-p incoming) (delete-file incoming)) (setq incomings (cdr incomings)))))) --- 413,421 ---- (if incoming (message "nnmh: Reading incoming mail...done")) (while incomings ! (and nnmail-delete-incoming ! (file-writable-p incoming) ! (delete-file incoming)) (setq incomings (cdr incomings)))))) *** pub/dgnus/lisp/nnml.el Sat May 27 11:20:58 1995 --- dgnus/lisp/nnml.el Mon May 29 10:20:42 1995 *************** *** 500,513 **** (nnmail-move-inbox (car spools) (concat nnml-directory "Incoming"))) (nnmail-split-incoming incoming 'nnml-save-mail nil group) ! (setq incomings (cons incoming incomings)) ! ;; The following has been commented away, just to make sure ! ;; that nobody ever loses any mail. If you feel safe that ! ;; nnml will never do anything strange, just remove those ! ;; two semicolons, and avoid having lots of "Incoming*" ! ;; files. ! ;; (delete-file incoming) ! )) (setq spools (cdr spools))) ;; If we did indeed read any incoming spools, we save all info. (if incoming --- 500,506 ---- (nnmail-move-inbox (car spools) (concat nnml-directory "Incoming"))) (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 *************** *** 518,529 **** (and gnus-verbose-backends (message "nnml: Reading incoming mail...done")))) (while incomings ! ;; The following has been commented away, just to make sure ! ;; that nobody ever loses any mail. If you feel safe that ! ;; nnfolder will never do anything strange, just remove those ! ;; two semicolons, and avoid having lots of "Incoming*" ! ;; files. ! ;; (and (file-writable-p incoming) (delete-file incoming)) (setq incomings (cdr incomings)))))) --- 511,519 ---- (and gnus-verbose-backends (message "nnml: Reading incoming mail...done")))) (while incomings ! (and nnmail-delete-incoming ! (file-writable-p incoming) ! (delete-file incoming)) (setq incomings (cdr incomings)))))) *** pub/dgnus/lisp/nnspool.el Sat May 27 11:20:58 1995 --- dgnus/lisp/nnspool.el Mon May 29 09:52:50 1995 *************** *** 30,39 **** (require 'timezone) (defvar nnspool-inews-program news-inews-program ! "Program to post news.") (defvar nnspool-inews-switches '("-h") ! "Switches for nnspool-request-post to pass to `inews' for posting news.") (defvar nnspool-spool-directory news-path "Local news spool directory.") --- 30,41 ---- (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.") *************** *** 129,148 **** (setq article (car sequence)) (if (stringp article) (progn ! (format "221 %d Article retrieved.\n" 0) ! (nnspool-request-article article)) (setq file (concat nnspool-current-directory ! (int-to-string article))) ! (and (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 --- 131,150 ---- (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 *************** *** 408,425 **** (1- first) (1+ last)) file))) (defun nnspool-find-article-by-message-id (id) "Return full pathname of an article identified by message-ID." (save-excursion ! (set-buffer nntp-server-buffer) ! (erase-buffer) ! (call-process "grep" nil t nil id nnspool-history-file) ! (goto-char (point-min)) ! (if (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\(.*\\)$") ! (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." --- 410,429 ---- (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]+\\(.*\\)$") ! (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." *** pub/dgnus/lisp/ChangeLog Sat May 27 11:21:00 1995 --- dgnus/lisp/ChangeLog Mon May 29 09:59:13 1995 *************** *** 1,4 **** --- 1,66 ---- + Mon May 29 09:03:02 1995 Lars Magne Ingebrigtsen + + * nnmail.el (nnmail-delete-incoming): New variable. + + * gnus.el (gnus-summary-read-group): Would scroll to the end of + the article. + + * gnus-msg.el (gnus-mail-reply-using-mail): Don't run + news-reply-header-hook if mail-yank-hooks is non-nil. + + Sun May 28 15:25:02 1995 Lars Ingebrigtsen + + * gnus.el (gnus-summary-update-mark): Would add unread marks to + articles that had been marked with the process mark. + (gnus-summary-read-group): Forcibly recenter group buffer if + visible. + + * gnus-score.el (gnus-summary-increase-score): Allow "?"s. + + * gnus.el (gnus-summary-import-article): New command and + keystroke. + + * gnus-kill.el (gnus-kill-parse-rn-kill-file): Also parse rn + killfiles. + + * gnus.el (gnus-group-get-new-news): Did not use + default-list-level properly. + + Sun May 28 10:01:10 1995 Lars Magne Ingebrigtsen + + * gnus.el (gnus-article-word-wrap): Use fill-column. + + * gnus-score.el (gnus-score-remove-lines-adaptive): Would switch + score files. + + * nnspool.el (nnspool-find-article-by-message-id): Did not work. + + * gnus-score.el (gnus-score-adaptive): Would try to score one too + many. + + * gnus.el (gnus-group-make-help-group): Use new doc backend. + + * nndoc.el (nndoc-type-to-regexp): Find out when the end of file + has been reached in digests. + + Sun May 28 01:30:59 1995 Lars Ingebrigtsen + + * nnmbox.el (nnmbox-possibly-change-newsgroup): Act more robustly + even if the user kills the mbox buffer. + + Sat May 27 20:16:34 1995 Lars Ingebrigtsen + + * nneething.el (nneething-make-head): Produced buggy From + headers. + (nneething-article-p): More strict definition. + + * gnus.el (gnus-summary-next-page): Would show end of buffer. + (gnus-group-exit): Really offer to save summaries. + (gnus-offer-save-summaries): Reverse match. + Sat May 27 09:25:52 1995 Lars Magne Ingebrigtsen + + * gnus.el: 0.78 is released. * nnmail.el (nnmail-split-incoming): Would bug out on long content-lengths. *** pub/dgnus/texi/gnus.texi Sat May 27 11:21:05 1995 --- dgnus/texi/gnus.texi Mon May 29 10:17:05 1995 *************** *** 1789,1794 **** --- 1789,1799 ---- the mail backend habitates (ie. @file{~/Mail/}), but if this variable is non-@code{nil}, it will be used instead. + @vindex nnmail-delete-incoming + If @code{nnmail-delete-incoming} is non-@code{nil}, the mail backends + will delete the temporary incoming file after splitting mail into the + proper groups. This is @code{nil} by default for reasons of security. + Gnus gives you all the opportunity you could possibly want for shooting yourself in the foot. Let's say you create a group that will contain all the mail you get from your boss. And then you accidentally *************** *** 2031,2041 **** easier for procmail users. By the way, that line up there about Gnus never expiring non-expirable ! articles is a lies. If you put @code{total-expire} in the group parameters, articles will not be marked as expirable, but all read articles will be put through the expiry process. Use with extreme caution. @node Not Reading Mail @subsubsection Not Reading Mail --- 2036,2053 ---- easier for procmail users. By the way, that line up there about Gnus never expiring non-expirable ! articles is a lie. If you put @code{total-expire} in the group parameters, articles will not be marked as expirable, but all read articles will be put through the expiry process. Use with extreme caution. + Note that at present, Gnus will not actually delete any expirable + articles automatically. You have to enter one of the expiry functions + (eg. `C-c M-c-x' in the group buffer) to actually run articles through + the expiry process. Or you can add a call to the expiry function in the + group exit hook. Gnus will probably do all this automatically in the + future. + @node Not Reading Mail @subsubsection Not Reading Mail *************** *** 5601,5626 **** --- 5613,5650 ---- @findex gnus-summary-expire-articles Expire all expirable articles in the group (@code{gnus-summary-expire-articles}). + @item B DEL @kindex B DEL (Summary) @findex gnus-summary-delete-articles Delete the mail article. This is "delete" as in "delete it from your disk forever and ever, never to return again." Use with caution. (@code{gnus-summary-delete-article}). + @item B m @kindex B m (Summary) @findex gnus-summary-move-article Move the article from one mail group to another (@code{gnus-summary-move-article}). + @item B c @kindex B c (Summary) @findex gnus-summary-copy-article Copy the article from one group (mail group or not) to a mail group (@code{gnus-summary-copy-article}). + + @item B i + @kindex B i (Summary) + @findex gnus-summary-import-article + Import a random file into the current mail newsgroup + (@code{gnus-summary-import-article}). You will be prompted for a file + name, a @code{From} header and a @code{Subject} header. + @item B r @kindex B r (Summary) @findex gnus-summary-respool-article Respool the mail article (@code{gnus-summary-move-article}). + @item B w @itemx e @kindex B w (Summary) *************** *** 5630,5635 **** --- 5654,5660 ---- Edit the current article (@code{gnus-summary-edit-article}). To finish editing and make the changes permanent, type @kbd{C-c C-c} (@kbd{gnus-summary-edit-article-done}). + @item B q @kindex B q (Summary) @findex gnus-summary-fancy-query