From: Lars Magne Ingebrigtsen Date: Tue, 4 Mar 1997 02:20:32 +0000 (+0000) Subject: *** empty log message *** X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=commitdiff_plain;h=7695426f0038d3b33433ed2c33f2f3cbc87a9a1b *** empty log message *** --- diff --git a/lisp/custom.el b/lisp/custom.el new file mode 100644 index 000000000..bcf825d71 --- /dev/null +++ b/lisp/custom.el @@ -0,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 diff --git a/lisp/gnus-edit.el b/lisp/gnus-edit.el new file mode 100644 index 000000000..486cd95ea --- /dev/null +++ b/lisp/gnus-edit.el @@ -0,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 diff --git a/lisp/gnus-kill.el b/lisp/gnus-kill.el index e8b896c11..b1da14900 100644 --- a/lisp/gnus-kill.el +++ b/lisp/gnus-kill.el @@ -356,38 +356,26 @@ Returns the number of articles marked as read." 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))))) + (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,9 +383,77 @@ Returns the number of articles marked as read." 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) +(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,7 +503,7 @@ COMMAND must be a lisp expression or a string representing a key sequence." (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) + (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)) diff --git a/lisp/gnus-msg.el b/lisp/gnus-msg.el index ec7dba7e1..6a86c28fe 100644 --- a/lisp/gnus-msg.el +++ b/lisp/gnus-msg.el @@ -1411,7 +1411,8 @@ mailer." (progn (save-excursion (mail-yank-original nil)) - (run-hooks 'news-reply-header-hook)) + (or mail-yank-hooks mail-citation-hook + (run-hooks 'news-reply-header-hook))) (while yank (save-window-excursion (set-buffer gnus-summary-buffer) @@ -1421,7 +1422,8 @@ mailer." (gnus-copy-article-buffer) (mail-yank-original nil) (setq end (point))) - (run-hooks 'news-reply-header-hook) + (or mail-yank-hooks mail-citation-hook + (run-hooks 'news-reply-header-hook)) (goto-char end) (setq yank (cdr yank)))) (goto-char last)) @@ -1432,7 +1434,8 @@ mailer." (interactive) (save-excursion (mail-yank-original nil)) - (run-hooks 'news-reply-header-hook)) + (or mail-yank-hooks mail-citation-hook + (run-hooks 'news-reply-header-hook))) (defun gnus-mail-send-and-exit () (interactive) diff --git a/lisp/gnus-score.el b/lisp/gnus-score.el index 9355ecb8b..8598009c0 100644 --- a/lisp/gnus-score.el +++ b/lisp/gnus-score.el @@ -119,6 +119,7 @@ of the last succesful match.") (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,19 +135,34 @@ of the last succesful match.") (?d "date") (?f "followup"))) (char-to-type - '((?e e) (?f f) (?s s) (?r r) (?b before) - (?a at) (?n now) (?< <) (?> >) (?= =))) + '((?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)) '(?p perm) '(?i now))) + (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. - (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)) + (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,15 +174,27 @@ of the last succesful match.") (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)) + (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,13 +206,25 @@ of the last succesful match.") (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)) + (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,6 +248,16 @@ of the last succesful match.") (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,7 +1393,7 @@ SCORE is the score to add." () (setq headers (gnus-get-header-by-number (gnus-summary-article-number))) - (while elem + (while (and elem headers) (setq match (funcall (car (car elem)) headers)) (gnus-summary-score-entry (nth 1 (car elem)) match @@ -1361,6 +1411,7 @@ SCORE is the score to add." (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,7 +1451,9 @@ SCORE is the score to add." 'e 's) (nth 2 (car elem)) date nil t) (setq elem (cdr elem)))) - (delete-region (point) (progn (forward-line 1) (point))))))) + (delete-region (point) (progn (forward-line 1) (point)))) + ;; Switch back to the old score file. + (gnus-score-load-file cur-score)))) ;;; ;;; Score mode. diff --git a/lisp/gnus-vis.el b/lisp/gnus-vis.el index 786033e64..8a441570a 100644 --- a/lisp/gnus-vis.el +++ b/lisp/gnus-vis.el @@ -362,6 +362,7 @@ highlight-headers-follow-url-netscape: ["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]) )) diff --git a/lisp/gnus.el b/lisp/gnus.el index a56b6b64a..0a51cacbf 100644 --- a/lisp/gnus.el +++ b/lisp/gnus.el @@ -1272,7 +1272,7 @@ variable (string, integer, character, etc).") (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" +(defconst gnus-version "(ding) Gnus v0.79" "Version number for this version of Gnus.") (defvar gnus-info-nodes @@ -1725,11 +1725,19 @@ Thank you for your help in stamping out bugs. (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) - (setq name (substring from 0 (1- (match-beginning 0))))) + (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,6 +1921,7 @@ Thank you for your help in stamping out bugs. (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,19 +3920,22 @@ ADDRESS." (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)) + (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-help" "nndoc" - (concat (file-name-as-directory (car path)) "doc.txt")) - (gnus-group-position-cursor))) + (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,11 +4363,10 @@ specify which levels you are interested in re-scanning." (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 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,6 +4374,7 @@ specify which levels you are interested in re-scanning." (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,6 +4615,7 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (progn (run-hooks 'gnus-exit-gnus-hook) (gnus-save-newsrc-file) + (gnus-offer-save-summaries) (gnus-close-backends) (gnus-clear-system)))) @@ -4631,7 +4644,6 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (progn (run-hooks 'gnus-exit-gnus-hook) (gnus-dribble-save) - (gnus-offer-save-summaries) (gnus-close-backends) (gnus-clear-system)))) @@ -4645,10 +4657,10 @@ The hook `gnus-exit-gnus-hook' is called before actually exiting." (progn (set-buffer (car buffers)) ;; We check that this is, indeed, a summary buffer. - (eq 'major-mode 'gnus-summary-mode)) + (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)))) + (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,10 +5497,10 @@ If NO-ARTICLE is non-nil, no article is selected initially." (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)))) + ;;(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,7 +5512,7 @@ If NO-ARTICLE is non-nil, no article is selected initially." (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) @@ -5514,7 +5526,14 @@ If NO-ARTICLE is non-nil, no article is selected initially." (funcall gnus-asynchronous-article-function gnus-newsgroup-threads) gnus-newsgroup-threads))) - (gnus-kill-buffer kill-buffer)) + (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,6 +7587,7 @@ current article." (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,17 +7604,16 @@ current article." (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))) + (gnus-configure-windows 'article) (if (or (null gnus-current-article) (null gnus-article-current) (/= article (cdr gnus-article-current)) @@ -7604,7 +7623,6 @@ Argument LINES specifies lines to be scrolled down." (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) @@ -7739,7 +7757,7 @@ The difference between N and the number of articles fetched is returned." (defun gnus-summary-refer-article (message-id) "Refer article specified by MESSAGE-ID. -NOTE: This command only works with newsgroup that use NNTP." +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,7 +8250,7 @@ functions. (Ie. mail newsgroups at present.)" "Import a random file into a mail newsgroup." (interactive "fImport file: ") (let ((group gnus-newsgroup-name) - attrib) + atts) (or (gnus-check-backend-function 'request-accept-article group) (error "%s does not support article importing" group)) (or (file-readable-p file) @@ -8244,9 +8262,15 @@ functions. (Ie. mail newsgroups at present.)" (erase-buffer) (insert-file-contents file) (goto-char (point-min)) - (setq attrib (file-attributes file)) - (insert "From: " (read-string "From: "))))) - + (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,7 +8730,8 @@ marked." (delete-char 1) (insert mark) (and plist (add-text-properties (1- (point)) (point) plist)) - (add-text-properties (1- (point)) (point) (list 'gnus-mark mark)) + (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,6 +9071,7 @@ If ALL is non-nil, also mark ticked and dormant articles as read." (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,7 +10120,7 @@ Provided for backwards compatability." (end-of-line 1) (let ((paragraph-start "^\\W")) (while (not (eobp)) - (and (>= (current-column) (window-width)) + (and (>= (current-column) (min fill-column (window-width))) (/= (preceding-char) ?:) (fill-paragraph nil)) (end-of-line 2)))))) @@ -10959,6 +10985,7 @@ is returned insted of the status string." (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))) diff --git a/lisp/nnbabyl.el b/lisp/nnbabyl.el index c8ac0a841..24eb53bb2 100644 --- a/lisp/nnbabyl.el +++ b/lisp/nnbabyl.el @@ -144,6 +144,8 @@ (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,8 +447,8 @@ (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) @@ -526,12 +528,9 @@ (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)) + (and nnmail-delete-incoming + (file-writable-p incoming) + (delete-file incoming)) (setq incomings (cdr incomings)))))) (provide 'nnbabyl) diff --git a/lisp/nndoc.el b/lisp/nndoc.el index 629e1cdaf..a26718ea1 100644 --- a/lisp/nndoc.el +++ b/lisp/nndoc.el @@ -36,13 +36,14 @@ (list (list 'mbox (concat "^" rmail-unix-mail-delimiter) (concat "^" rmail-unix-mail-delimiter) - nil "^$" nil) - (list 'babyl "\^_\^L *\n" "\^_" nil "^$" nil) + nil "^$" nil nil) + (list 'babyl "\^_\^L *\n" "\^_" nil "^$" nil nil) (list 'digest "^------------------------------[\n \t]+" "^------------------------------[\n \t]+" nil "^$" - "^------------------------------*[\n \t]*\n[^ ]+: ")) + "^------------------------------*[\n \t]*\n[^ ]+: " + "End of")) "Regular expressions for articles of the various types.") @@ -52,6 +53,7 @@ (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,6 +67,7 @@ '(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,7 +155,8 @@ (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-first-article (nth 4 defs)) + (setq nndoc-end-of-file (nth 5 defs))) t)) (defun nndoc-close-server (&optional server) @@ -271,6 +275,8 @@ (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))