*** pub/dgnus/lisp/custom.el Fri Jun 9 20:01:45 1995 --- dgnus/lisp/custom.el Sat Jun 10 01:39:59 1995 *************** *** 3,9 **** ;; ;; Author: Per Abrahamsen ;; Keywords: help ! ;; Version: 0.2 ;;; Commentary: ;; --- 3,9 ---- ;; ;; Author: Per Abrahamsen ;; Keywords: help ! ;; Version: 0.3 ;;; Commentary: ;; *************** *** 32,46 **** ;;; 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: --- 32,46 ---- ;;; Todo: ;; ;; - Toggle documentation in three states `none', `one-line', `full'. ;; - Function to generate a XEmacs menu from a CUSTOM. ! ;; - Write TeXinfo documentation. ! ;; - Make it possible to hide sections by clicking at the level. ;; - Declare AUC TeX variables. ;; - Declare (ding) Gnus variables. ;; - Declare Emacs variables. ;; - Implement remaining types. ;; - XEmacs port. + ;; - Allow `URL', `info', and internal hypertext buttons. ;;; Code: *************** *** 66,75 **** (or (member element (symbol-value list-var)) (set list-var (cons element (symbol-value list-var)))))) (defvar intangible nil "The symbol making text intangible") - ;; 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) --- 66,181 ---- (or (member element (symbol-value list-var)) (set list-var (cons element (symbol-value list-var)))))) + (or (fboundp 'plist-get) + ;; Introduced in Emacs 19.29. + (defun plist-get (plist prop) + "Extract a value from a property list. + PLIST is a property list, which is a list of the form + \(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value + corresponding to the given PROP, or nil if PROP is not + one of the properties on the list." + (let (result) + (while plist + (if (eq (car plist) prop) + (setq result (car (cdr plist)) + plist nil) + (set plist (cdr (cdr plist))))) + result))) + + (or (fboundp 'plist-put) + ;; Introduced in Emacs 19.29. + (defun plist-put (plist prop val) + "Change value in PLIST of PROP to VAL. + PLIST is a property list, which is a list of the form + \(PROP1 VALUE1 PROP2 VALUE2 ...). PROP is a symbol and VAL is any object. + If PROP is already a property on the list, its value is set to VAL, + otherwise the new PROP VAL pair is added. The new plist is returned; + use `(setq x (plist-put x prop val))' to be sure to use the new value. + The PLIST is modified by side effects." + (while plist + (cond ((eq (car plist) prop) + (setcar (cdr plist) val) + (setq plist nil)) + ((null (cdr (cdr plist))) + (setcdr (cdr plist) (list prop val)) + (setq plist nil)) + (t + (setq plist (cdr (cdr plist)))))))) + + (or (fboundp 'match-string) + ;; Introduced in Emacs 19.29. + (defun match-string (num &optional string) + "Return string of text matched by last search. + NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. + Zero means the entire text matched by the whole regexp or whole string. + STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring (match-beginning num) (match-end num)))))) + + (or (fboundp 'facep) + ;; Introduced in Emacs 19.29. + (defun facep (x) + "Return t if X is a face name or an internal face vector." + (and (or (internal-facep x) + (and (symbolp x) (assq x global-face-data))) + t))) + + (or (fboundp 'modify-face) + ;; Introduced in Emacs 19.29. + (defun modify-face (face foreground background stipple + bold-p italic-p underline-p) + "Change the display attributes for face FACE. + FOREGROUND and BACKGROUND should be color strings or nil. + STIPPLE should be a stipple pattern name or nil. + BOLD-P, ITALIC-P, and UNDERLINE-P specify whether the face should be set bold, + in italic, and underlined, respectively. (Yes if non-nil.) + If called interactively, prompts for a face and face attributes." + (interactive + (let* ((completion-ignore-case t) + (face (symbol-name (read-face-name "Modify face: "))) + (colors (mapcar 'list x-colors)) + (stipples (mapcar 'list + (apply 'nconc + (mapcar 'directory-files + x-bitmap-file-path)))) + (foreground (modify-face-read-string + face (face-foreground (intern face)) + "foreground" colors)) + (background (modify-face-read-string + face (face-background (intern face)) + "background" colors)) + (stipple (modify-face-read-string + face (face-stipple (intern face)) + "stipple" stipples)) + (bold-p (y-or-n-p (concat "Set face " face " bold "))) + (italic-p (y-or-n-p (concat "Set face " face " italic "))) + (underline-p (y-or-n-p (concat "Set face " face " underline ")))) + (message "Face %s: %s" face + (mapconcat 'identity + (delq nil + (list (and foreground (concat (downcase foreground) " foreground")) + (and background (concat (downcase background) " background")) + (and stipple (concat (downcase stipple) " stipple")) + (and bold-p "bold") (and italic-p "italic") + (and underline-p "underline"))) ", ")) + (list (intern face) foreground background stipple + bold-p italic-p underline-p))) + (condition-case nil (set-face-foreground face foreground) (error nil)) + (condition-case nil (set-face-background face background) (error nil)) + (condition-case nil (set-face-stipple face stipple) (error nil)) + (funcall (if bold-p 'make-face-bold 'make-face-unbold) face nil t) + (funcall (if italic-p 'make-face-italic 'make-face-unitalic) face nil t) + (set-face-underline-p face underline-p) + (and (interactive-p) (redraw-display)))) + + + ;; We can't easily check for a working intangible. (defvar intangible nil "The symbol making text intangible") (if (and (boundp 'emacs-minor-version) (or (> emacs-major-version 19) (and (> emacs-major-version 18) *************** *** 77,119 **** (setq intangible 'intangible) (setq intangible 'intangible-if-it-had-been-working)) ! (defvar custom-modified-list nil) ! ! ;;; 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: ;; --- 183,193 ---- (setq intangible 'intangible) (setq intangible 'intangible-if-it-had-been-working)) ! ;; Put it in the Help menu, if possible. ! (condition-case nil ! ;; This will not work under XEmacs. ! (global-set-key [ menu-bar help customize ] '("Customize..." . customize)) ! (error nil)) ;;; External Data: ;; *************** *** 146,155 **** (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: ;; --- 220,235 ---- (custom-assert 'field) (setq custom-name-fields (cons (cons name field) custom-name-fields)))) + (defun custom-name-field (name) + "The editing field associated with NAME." + (cdr (assq name custom-name-fields))) + (defun custom-name-value (name) "The value currently displayed for NAME in the customization buffer." ! (let* ((field (custom-name-field name)) ! (custom (custom-field-custom field))) ! (funcall (custom-property custom 'export) ! (car (custom-field-extract custom field))))) ;;; Custom Functions: ;; *************** *** 163,176 **** ;; 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) --- 243,291 ---- ;; where each CUSTOM is a leaf in the hierarchy defined by the `type' ;; property and `custom-type-properties'. + (defvar custom-file "~/.custom.el" + "Name of file with customization information.") + (defconst custom-data '((tag . "Emacs") (doc . "The extensible self-documenting text editor.") (type . group) ! (data "\n" ! ((header . nil) ! (compact . t) ! (type . group) ! (doc . "\ ! Press [Save] to save any changes permanently after you are done editing. ! You can load customization information from other files by editing the ! `File' field and pressing the [Load] button. When you press [Save] the ! customization information of all files you have loaded, plus any ! changes you might have made manually, will be stored in the file ! specified by the `File' field.") ! (data ((tag . "Load") ! (type . button) ! (query . custom-load)) ! ((tag . "Save") ! (type . button) ! (query . custom-save)) ! ((name . custom-file) ! (default . "~/.custom.el") ! (doc . "Name of file with customization information.\n") ! (tag . "File") ! (type . file)))))) "The global customization information. A custom association list.") + (defun custom-declare (path custom) + "Declare variables for customization. + PATH is a list of tags leading to the place in the customization + hierarchy the new entry should be added. CUSTOM is the entry to add." + (custom-initialize custom) + (let ((current (custom-travel-path custom-data path))) + (or (member custom (custom-data current)) + (nconc (custom-data current) (list custom))))) + + (put 'custom-declare 'lisp-indent-hook 1) + (defconst custom-type-properties '((repeat (type . default) (accept . custom-repeat-accept) *************** *** 179,199 **** (insert . custom-repeat-insert) (match . custom-repeat-match) (query . custom-repeat-query) (del-tag . "[DEL]") (add-tag . "[INS]")) (list (type . group) ! (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") --- 294,324 ---- (insert . custom-repeat-insert) (match . custom-repeat-match) (query . custom-repeat-query) + (prefix . "") (del-tag . "[DEL]") (add-tag . "[INS]")) + (pair (type . group) + (valid . (lambda (c d) (consp d))) + (extract . custom-pair-extract)) (list (type . group) ! (valid . (lambda (c d) (listp d))) ! (quote . custom-list-quote) ! (extract . custom-list-extract)) (group (type . default) + (face-tag . nil) + (initialize . custom-group-initialize) + (apply . custom-group-apply) + (reset . custom-group-reset) + (factory-reset . custom-group-factory-reset) (extract . nil) ! (validate . custom-group-validate) (query . custom-toggle-hide) (accept . custom-group-accept) ! (insert . custom-group-insert) ! (find . custom-group-find)) (toggle (type . choice) (data ((type . const) ! (tag . "On ") (default . t)) ((type . const) (tag . "Off") *************** *** 203,223 **** (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))) --- 328,467 ---- (accept . custom-choice-accept) (extract . custom-choice-extract) (validate . custom-choice-validate) (insert . custom-choice-insert) (none (tag . "Unknown") (default . __uninitialized__) (type . const))) (const (type . default) (extract . (lambda (c f) (list (custom-default c)))) (validate . (lambda (c f) nil)) (valid . custom-const-valid) + (update . custom-const-update) (insert . custom-const-insert)) + (face-doc (type . doc) + (doc . "\ + You can customize the look of Emacs by deciding which faces should be + used when. If you push one of the face buttons below, you will be + given a choice between a number of standard faces. The name of the + selected face is shown right after the face button, and it is + displayed its own face so you can see how it looks. If you know of + another standard face not listed and want to use it, you can select + `Other' and write the name in the editing field. + + If none of the standard faces suits you, you can select `Customize' to + create your own face. This will make six fields appear under the face + button. The `Fg' and `Bg' fields are the foreground and background + colors for the face, respectively. You should type the name of the + color in the field. You can use any X11 color name. A list of X11 + color names may be available in the file `/usr/lib/X11/rgb.txt' on + your system. The special color name `default' means that the face + will not change the color of the text. The `Stipple' field is weird, + so just ignore it. The three remaining fields are toggles, which will + make the text `bold', `italic', or `underline' respectively. For some + fonts `bold' or `italic' will not make any visible change.")) + (face (type . choice) + (quote . custom-face-quote) + (export . custom-face-export) + (import . custom-face-import) + (data ((tag . "None") + (default . nil) + (type . const)) + ((tag . "Default") + (default . default) + (face . custom-const-face) + (type . const)) + ((tag . "Bold") + (default . bold) + (face . custom-const-face) + (type . const)) + ((tag . "Bold-italic") + (default . bold-italic) + (face . custom-const-face) + (type . const)) + ((tag . "Italic") + (default . italic) + (face . custom-const-face) + (type . const)) + ((tag . "Underline") + (default . underline) + (face . custom-const-face) + (type . const)) + ((tag . "Highlight") + (default . highlight) + (face . custom-const-face) + (type . const)) + ((tag . "Modeline") + (default . modeline) + (face . custom-const-face) + (type . const)) + ((tag . "Region") + (default . region) + (face . custom-const-face) + (type . const)) + ((tag . "Secondary Selection") + (default . secondary-selection) + (face . custom-const-face) + (type . const)) + ((tag . "Customized") + (compact . t) + (face-tag . custom-face-hack) + (export . custom-face-export) + (data ((hidden . t) + (tag . "") + (doc . "\ + Select the properties you want this face to have.") + (default . custom-face-lookup) + (type . const)) + "\n" + ((tag . "Fg") + (hidden . t) + (default . "default") + (width . 20) + (type . string)) + ((tag . "Bg") + (default . "default") + (width . 20) + (type . string)) + ((tag . "Stipple") + (default . "default") + (width . 20) + (type . string)) + "\n" + ((tag . "Bold") + (default . nil) + (type . toggle)) + " " + ((tag . "Italic") + (default . nil) + (type . toggle)) + " " + ((tag . "Underline") + (hidden . t) + (default . nil) + (type . toggle))) + (default . (custom-face-lookup "default" "default" "default" + nil nil nil)) + (type . list)) + ((prompt . "Other") + (face . custom-field-value) + (type . symbol)))) (file (type . string) (directory . nil) (default-file . nil) (query . custom-file-query)) + (sexp (type . default) + (width . 40) + (default . (__uninitialized__ . "Uninitialized")) + (valid . custom-sexp-valid) + (quote . custom-sexp-quote) + (read . custom-sexp-read) + (write . custom-sexp-write)) + (symbol (type . default) + (width . 40) + (valid . (lambda (c d) (symbolp d))) + (quote . custom-symbol-quote) + (read . custom-symbol-read) + (write . custom-symbol-write)) (integer (type . default) (width . 10) (valid . (lambda (c d) (integerp d))) *************** *** 232,260 **** (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)... )... )'.") --- 476,517 ---- (button (type . default) (accept . ignore) (extract . nil) ! (validate . ignore) (insert . custom-button-insert)) (doc (type . default) ! (header . nil) ! (reset . ignore) (extract . nil) ! (validate . ignore) (insert . custom-documentation-insert)) (default (width . 20) (valid . (lambda (c v) t)) (insert . custom-default-insert) + (update . custom-default-update) (query . custom-default-query) (tag . nil) + (prompt . nil) (doc . nil) (header . t) (padding . ? ) (allow-padding . t) + (quote . identity) + (export . identity) + (import . identity) + (synchronize . ignore) + (initialize . custom-default-initialize) (extract . custom-default-extract) (validate . custom-default-validate) + (apply . custom-default-apply) (reset . custom-default-reset) + (factory-reset . custom-default-factory-reset) (accept . custom-default-accept) (match . custom-default-match) (name . nil) (compact . nil) + (hidden . nil) + (face . custom-default-face) + (data . nil) (default . __uninitialized__))) "Alist of default properties for type symbols. The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.") *************** *** 278,283 **** --- 535,548 ---- (custom-assert 'custom))) (cdr entry))) + (defun custom-property-set (custom property value) + "Set CUSTOM PROPERY to VALUE by side effect. + CUSTOM must have at least one property already." + (let ((entry (assq property custom))) + (if entry + (setcdr entry value) + (setcdr custom (cons (cons property value) (cdr custom)))))) + (defun custom-type (custom) "Extract `type' from CUSTOM." (cdr (assq 'type custom))) *************** *** 290,298 **** "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) --- 555,565 ---- "Extract `tag' from CUSTOM." (custom-property custom 'tag)) ! (defun custom-prompt (custom) ! "Extract `prompt' from CUSTOM. ! If none exist, default to `tag' or, failing that, `type'." ! (or (custom-property custom 'prompt) ! (custom-property custom 'tag) (capitalize (symbol-name (custom-type custom))))) (defun custom-default (custom) *************** *** 327,332 **** --- 594,607 ---- "Non-nil if CUSTOM may legally be set to VALUE." (funcall (custom-property custom 'valid) custom value)) + (defun custom-import (custom value) + "Import CUSTOM VALUE from external variable." + (funcall (custom-property custom 'import) value)) + + (defun custom-quote (custom value) + "Quote CUSTOM's VALUE if necessary." + (funcall (custom-property custom 'quote) value)) + (defun custom-write (custom value) "Convert CUSTOM VALUE to a string." (if (eq value custom-nil) *************** *** 345,350 **** --- 620,639 ---- (cons custom-nil nil) (funcall (custom-property custom 'match) custom values))) + (defun custom-initialize (custom) + "Initialize `doc' and `default' attributes of CUSTOM." + (funcall (custom-property custom 'initialize) custom)) + + (defun custom-find (custom tag) + "Find child in CUSTOM with `tag' TAG." + (funcall (custom-property custom 'find) custom tag)) + + (defun custom-travel-path (custom path) + "Find decedent of CUSTOM by looking through PATH." + (if (null path) + custom + (custom-travel-path (custom-find custom (car path)) (cdr path)))) + (defun custom-field-extract (custom field) "Extract CUSTOM's value in FIELD." (if (stringp custom) *************** *** 417,426 **** (defun custom-field-accept (field value &optional original) "Accept FIELD VALUE. ! If optional ORIGINAL is non-nil, consider VALUE for the original value." (funcall (custom-property (custom-field-custom field) 'accept) field value original)) ;;; Types: ;; ;; The following functions defines type specific actions. --- 706,729 ---- (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)) + (defun custom-field-face (field) + "The face used for highlighting FIELD." + (let ((custom (custom-field-custom field))) + (if (stringp custom) + nil + (funcall (custom-property custom 'face) field)))) + + (defun custom-field-update (field) + "Update content of FIELD." + (let ((custom (custom-field-custom field))) + (if (stringp custom) + nil + (funcall (custom-property custom 'update) field)))) + ;;; Types: ;; ;; The following functions defines type specific actions. *************** *** 471,476 **** --- 774,780 ---- (data (vector field nil start nil))) (custom-text-insert "\n") (let ((pos (point))) + (custom-text-insert (custom-property custom 'prefix)) (custom-tag-insert add-tag 'custom-repeat-add data) (set-marker start pos)) (custom-field-move field start (point)) *************** *** 481,488 **** "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)) --- 785,792 ---- "Insert entry at point in the REPEAT field." (let* ((inhibit-point-motion-hooks t) (inhibit-read-only t) ! (before-change-functions nil) ! (after-change-functions nil) (custom (custom-field-custom repeat)) (add-tag (custom-property custom 'add-tag)) (del-tag (custom-property custom 'del-tag)) *************** *** 498,503 **** --- 802,808 ---- (custom-text-insert " ") (set-marker end (point)) (goto-char start) + (custom-text-insert (custom-property custom 'prefix)) (custom-tag-insert add-tag 'custom-repeat-add data) (custom-text-insert " ") (custom-tag-insert del-tag 'custom-repeat-delete data) *************** *** 520,527 **** "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))) --- 825,832 ---- "Delete list entry." (let ((inhibit-point-motion-hooks t) (inhibit-read-only t) ! (before-change-functions nil) ! (after-change-functions nil) (parent (aref data 0)) (field (aref data 1))) (delete-region (aref data 2) (1+ (aref data 3))) *************** *** 548,558 **** (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) --- 853,860 ---- (if (eq values custom-nil) () (while values (setq result (append result (custom-field-extract data (car values))) ! values (cdr values)))) result)) (defun custom-repeat-validate (custom field) *************** *** 567,572 **** --- 869,894 ---- values (cdr values))) result)) + (defun custom-pair-extract (custom field) + "Extract cons of childrens values." + (let ((values (custom-field-value field)) + (data (custom-data custom)) + result) + (custom-assert '(eq (length values) (length data))) + (custom-assert '(eq (length values) 2)) + (while values + (setq result (append result + (custom-field-extract (car data) (car values))) + data (cdr data) + values (cdr values))) + (custom-assert '(null data)) + (list (cons (nth 0 result) (nth 1 result))))) + + (defun custom-list-quote (value) + "Quote VALUE if necessary." + (and value + (list 'quote value))) + (defun custom-list-extract (custom field) "Extract list of childrens values." (let ((values (custom-field-value field)) *************** *** 581,587 **** (custom-assert '(null data)) (list result))) ! (defun custom-list-validate (custom field) "Validate children." (let ((values (custom-field-value field)) (data (custom-data custom)) --- 903,909 ---- (custom-assert '(null data)) (list result))) ! (defun custom-group-validate (custom field) "Validate children." (let ((values (custom-field-value field)) (data (custom-data custom)) *************** *** 595,604 **** 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)) ! current) (if original (custom-field-original-set field value)) (while values --- 917,972 ---- values (cdr values))) result)) + (defun custom-group-initialize (custom) + "Initialize `doc' and `default' entries in CUSTOM." + (if (custom-name custom) + (custom-default-initialize custom) + (mapcar 'custom-initialize (custom-data custom)))) + + (defun custom-group-apply (field) + "Reset `value' in FIELD to `original'." + (let ((custom (custom-field-custom field)) + (values (custom-field-value field))) + (if (custom-name custom) + (custom-default-apply field) + (mapcar 'custom-field-apply values)))) + + (defun custom-group-reset (field) + "Reset `value' in FIELD to `original'." + (let ((custom (custom-field-custom field)) + (values (custom-field-value field))) + (if (custom-name custom) + (custom-default-reset field) + (mapcar 'custom-field-reset values)))) + + (defun custom-group-factory-reset (field) + "Reset `value' in FIELD to `default'." + (let ((custom (custom-field-custom field)) + (values (custom-field-value field))) + (if (custom-name custom) + (custom-default-factory-reset field) + (mapcar 'custom-field-factory-reset values)))) + + (defun custom-group-find (custom tag) + "Find child in CUSTOM with `tag' TAG." + (let ((data (custom-data custom)) + (result nil)) + (while (not result) + (custom-assert 'data) + (if (equal (custom-tag (car data)) tag) + (setq result (car data)) + (setq data (cdr data)))))) + (defun custom-group-accept (field value &optional original) "Enter content of editing FIELD with VALUE." ! (let* ((values (custom-field-value field)) ! (custom (custom-field-custom field)) ! (from (custom-field-start field)) ! (face-tag (custom-property custom 'face-tag)) ! current) ! (if face-tag ! (put-text-property from (+ from (length (custom-tag custom))) ! 'face (funcall face-tag field value))) (if original (custom-field-original-set field value)) (while values *************** *** 613,631 **** (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)) --- 981,1005 ---- (defun custom-group-insert (custom level) "Insert field for CUSTOM at nesting LEVEL in customization buffer." (let* ((field (custom-field-create custom nil)) ! fields hidden (from (point)) (compact (custom-compact custom)) ! (tag (custom-tag custom)) ! (face-tag (custom-property custom 'face-tag))) ! (cond (face-tag (custom-text-insert tag)) ! (tag (custom-tag-insert tag field))) (or compact (custom-documentation-insert custom)) (or compact (custom-text-insert "\n")) (let ((data (custom-data custom))) (while data (setq fields (cons (custom-insert (car data) (if level (1+ level))) fields)) + (setq hidden (or (stringp (car data)) + (custom-property (car data) 'hidden))) (setq data (cdr data)) ! (if data (custom-text-insert (cond (hidden "") ! (compact " ") ! (t "\n")))))) (if compact (custom-documentation-insert custom)) (custom-field-value-set field (nreverse fields)) (custom-field-move field from (point)) *************** *** 648,655 **** (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)) --- 1022,1029 ---- (start (custom-field-start field)) (end (custom-field-end field)) (inhibit-read-only t) ! (before-change-functions nil) ! (after-change-functions nil) from) (cond (original (setq custom-modified-list (delq field custom-modified-list)) *************** *** 683,688 **** --- 1057,1064 ---- (add-text-properties begin (point) (list 'rear-nonsticky t 'face custom-field-uninitialized-face))) + (or original + (custom-field-original-set found (custom-field-original field))) (custom-field-accept found value original) (custom-field-value-set field found) (custom-field-move field from end)))) *************** *** 704,729 **** (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" --- 1080,1109 ---- (defun custom-choice-query (field) "Choose a child." (let* ((custom (custom-field-custom field)) ! (old (custom-field-custom (custom-field-value field))) ! (default (custom-prompt old)) ! (tag (custom-prompt custom)) (data (custom-data custom)) current alist) ! (if (eq (length data) 2) ! (custom-field-accept field (custom-default (if (eq (nth 0 data) old) ! (nth 1 data) ! (nth 0 data)))) ! (while data ! (setq current (car data) ! data (cdr data)) ! (setq alist (cons (cons (custom-prompt current) current) alist))) ! (let ((answer (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" *************** *** 746,764 **** 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 --- 1126,1261 ---- default nil value) (read-file-name prompt directory default))))) + (defun custom-face-quote (value) + "Quote VALUE if necessary." + (if (symbolp value) + (custom-symbol-quote value) + value)) + + (defun custom-face-export (value) + "Modify VALUE to match external expectations." + (if (symbolp value) + value + (eval value))) + + (defun custom-face-import (value) + "Modify VALUE to match internal expectations." + (let ((name (symbol-name value))) + (if (string-match "\ + custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)" + name) + (list 'custom-face-lookup + (match-string 1 name) + (match-string 2 name) + (match-string 3 name) + (intern (match-string 4 name)) + (intern (match-string 5 name)) + (intern (match-string 6 name))) + value))) + + (defun custom-face-lookup (fg bg stipple bold italic underline) + "Lookup or create a face with specified attributes. + FG BG STIPPLE BOLD ITALIC UNDERLINE" + (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" + (or fg "default") + (or bg "default") + (or stipple "default") + bold italic underline)))) + (if (facep name) + () + (make-face name) + (modify-face name + (if (string-equal fg "default") nil fg) + (if (string-equal bg "default") nil bg) + (if (string-equal stipple "default") nil stipple) + bold italic underline)) + name)) + + (defun custom-face-hack (field value) + "Face that should be used for highlighting FIELD containing VALUE." + (funcall (custom-property (custom-field-custom field) 'export) value)) + (defun custom-const-insert (custom level) "Insert field for CUSTOM at nesting LEVEL in customization buffer." ! (let* ((field (custom-field-create custom custom-nil)) ! (face (custom-field-face field)) ! (from (point))) (custom-text-insert (custom-tag custom)) + (add-text-properties from (point) + (list 'face face + 'rear-nonsticky t)) (custom-documentation-insert custom) (custom-field-move field from (point)) field)) + (defun custom-const-update (field) + "Update face of FIELD." + (let ((from (custom-field-start field)) + (custom (custom-field-custom field))) + (put-text-property from (+ from (length (custom-tag custom))) + 'face (custom-field-face field)))) + (defun custom-const-valid (custom value) "Non-nil if CUSTOM can legally have the value VALUE." (equal (custom-default custom) value)) + (defun custom-const-face (field) + "Face used for a FIELD." + (custom-default (custom-field-custom field))) + + (defun custom-sexp-valid (custom value) + "Non-nil if CUSTOM can legally have the value VALUE." + (not (and (listp value) (eq custom-nil (car value))))) + + (defun custom-sexp-quote (value) + "Quote VALUE if necessary." + (if (or (and (symbolp value) + value + (not (eq t value))) + (and (listp value) + value + (not (memq (car value) '(quote function lambda))))) + (list 'quote value) + value)) + + (defun custom-sexp-read (custom string) + "Read from CUSTOM an STRING." + (save-match-data + (save-excursion + (set-buffer (get-buffer-create " *Custom Scratch*")) + (erase-buffer) + (insert string) + (goto-char (point-min)) + (condition-case signal + (prog1 (read (current-buffer)) + (or (looking-at + (concat (regexp-quote (char-to-string + (custom-padding custom))) + "*\\'")) + (error "Junk at end of expression"))) + (error (cons custom-nil string)))))) + + (defun custom-sexp-write (custom sexp) + "Write CUSTOM SEXP as string." + (if (and (listp sexp) (eq (car sexp) custom-nil)) + (cdr sexp) + (prin1-to-string sexp))) + + (defun custom-symbol-quote (value) + "Quote VALUE if necessary." + (if (or (null value) (eq t value)) + value + (list 'quote value))) + + (defun custom-symbol-read (custom symbol) + "Read from CUSTOM an SYMBOL." + (intern (save-match-data + (custom-strip-padding symbol (custom-padding custom))))) + + (defun custom-symbol-write (custom symbol) + "Write CUSTOM SYMBOL as string." + (symbol-name symbol)) + (defun custom-integer-read (custom integer) "Read from CUSTOM an INTEGER." (string-to-int (save-match-data *************** *** 788,793 **** --- 1285,1307 ---- (custom-documentation-insert custom) nil) + (defun custom-default-initialize (custom) + "Initialize `doc' and `default' entries in CUSTOM." + (let ((name (custom-name custom))) + (if (null name) + () + (let ((default (custom-default custom)) + (doc (custom-documentation custom)) + (vdoc (documentation-property name 'variable-documentation t))) + (if doc + (or vdoc (put name 'variable-documentation doc)) + (if vdoc (custom-property-set custom 'doc vdoc))) + (if (eq default custom-nil) + (if (boundp name) + (custom-property-set custom 'default (symbol-value name))) + (or (boundp name) + (set name default))))))) + (defun custom-default-insert (custom level) "Insert field for CUSTOM at nesting LEVEL in customization buffer." (let ((field (custom-field-create custom custom-nil)) *************** *** 807,822 **** (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) --- 1321,1351 ---- (custom-field-value-set field value) (custom-field-update field)) + (defun custom-default-apply (field) + "Apply any changes in FIELD since the last apply." + (let* ((custom (custom-field-custom field)) + (name (custom-name custom))) + (if (null name) + (error "This field cannot be applied alone")) + (custom-external-set name (custom-name-value name)) + (custom-field-reset field))) + (defun custom-default-reset (field) ! "Reset content of editing FIELD to `original'." (custom-field-accept field (custom-field-original field) t)) + (defun custom-default-factory-reset (field) + "Reset content of editing FIELD to `default'." + (let ((default (custom-default (custom-field-custom field)))) + (or (eq default custom-nil) + (custom-field-accept field default nil)))) + (defun custom-default-query (field) "Prompt for a FIELD" (let* ((custom (custom-field-custom field)) (value (custom-field-value field)) (initial (custom-write custom value)) ! (prompt (concat (custom-prompt custom) ": "))) (custom-field-accept field (custom-read custom (if (custom-valid custom value) *************** *** 842,852 **** --- 1371,1428 ---- (t (cons start "Wrong type"))))) + (defun custom-default-face (field) + "Face used for a FIELD." + (let ((value (custom-field-value field))) + (cond ((eq value custom-nil) + custom-field-uninitialized-face) + ((not (custom-valid (custom-field-custom field) value)) + custom-field-invalid-face) + ((not (equal (custom-field-original field) value)) + custom-field-modified-face) + (t + custom-field-face)))) + + (defun custom-default-update (field) + "Update the content of FIELD." + (let ((inhibit-point-motion-hooks t) + (before-change-functions nil) + (after-change-functions nil) + (start (custom-field-start field)) + (end (custom-field-end field)) + (pos (point))) + ;; Keep track of how many modified fields we have. + (cond ((equal (custom-field-value field) (custom-field-original field)) + (setq custom-modified-list (delq field custom-modified-list))) + ((memq field custom-modified-list)) + (t + (setq custom-modified-list (cons field custom-modified-list)))) + ;; Update the field. + (goto-char end) + (insert-before-markers " ") + (delete-region start (1- end)) + (goto-char start) + (custom-field-insert field) + (goto-char end) + (delete-char 1) + (goto-char pos) + (and (<= start pos) + (<= pos end) + (custom-field-enter field)))) + ;;; Create Buffer: ;; ;; Public functions to create a customization buffer and to insert ;; various forms of text, fields, and buttons in it. + (defun customize () + "Customize GNU Emacs. + Create a *Customize* buffer with editable customization information + about GNU Emacs." + (interactive) + (custom-buffer-create "*Customize*") + (custom-reset-all)) + (defun custom-buffer-create (name &optional custom types set get) "Create a customization buffer named NAME. If the optional argument CUSTOM is non-nil, use that as the custom declaration. *************** *** 870,877 **** (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)) --- 1446,1453 ---- (make-local-variable 'custom-external) (setq custom-external get)) (let ((inhibit-point-motion-hooks t) ! (before-change-functions nil) ! (after-change-functions nil)) (erase-buffer) (insert "\n") (goto-char (point-min)) *************** *** 879,889 **** (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) --- 1455,1467 ---- (custom-help-insert "\n") (custom-help-button 'custom-forward-field) (custom-help-button 'custom-enter-value) + (custom-help-button 'custom-field-factory-reset) (custom-help-button 'custom-field-reset) (custom-help-button 'custom-field-apply) (custom-help-button 'custom-toggle-documentation) (custom-help-insert "\nClick mouse-2 on any button to activate it.\n") ! (custom-text-insert "\n") ! (custom-insert custom-data 0) (goto-char (point-min)))) (defun custom-insert (custom level) *************** *** 894,901 **** 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))) --- 1472,1480 ---- nil) (and level (null (custom-property custom 'header)) (setq level nil)) ! (and level ! (> level 0) ! (custom-text-insert (concat "\n" (make-string level ?*) " "))) (let ((field (funcall (custom-property custom 'insert) custom level))) (custom-name-enter (custom-name custom) field) field))) *************** *** 944,950 **** ;; The Customization major mode and interactive commands. (defvar custom-mode-map nil ! "Keymap for Custom Mode.") (if custom-mode-map nil (setq custom-mode-map (make-sparse-keymap)) --- 1523,1529 ---- ;; 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)) *************** *** 954,959 **** --- 1533,1540 ---- (define-key custom-mode-map "\C-k" 'custom-kill-line) (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset) (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all) + (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset) + (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all) (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply) (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all) (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation)) *************** *** 970,979 **** (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) --- 1551,1560 ---- (setq major-mode 'custom-mode mode-name "Custom") (use-local-map custom-mode-map) ! (make-local-variable 'before-change-functions) ! (setq before-change-functions '(custom-before-change)) ! (make-local-variable 'after-change-functions) ! (setq after-change-functions '(custom-after-change)) (if (not (fboundp 'make-local-hook)) ;; Emacs 19.28 and earlier. (add-hook 'post-command-hook 'custom-post-command nil) *************** *** 1069,1087 **** "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 --- 1650,1696 ---- "Undo any changes in FIELD since the last apply." (interactive (list (or (get-text-property (point) 'custom-field) (get-text-property (point) 'custom-tag)))) ! (if (arrayp field) ! (let* ((custom (custom-field-custom field)) ! (name (custom-name custom))) ! (save-excursion ! (if name ! (custom-field-original-set ! field (custom-import custom (custom-external name)))) ! (if (not (custom-valid custom (custom-field-original field))) ! (error "This field cannot be reset alone") ! (funcall (custom-property custom 'reset) field) ! (funcall (custom-property custom 'synchronize) field)))))) ! ! (defun custom-factory-reset-all () ! "Reset all field to their default values." ! (interactive (and custom-modified-list ! (not (y-or-n-p "Discard all changes? ")) ! (error "Reset aborted"))) ! (let ((all custom-name-fields) ! name field custom default) ! (while all ! (setq field (cdr (car all)) ! custom (custom-field-custom field) ! default (custom-default custom) ! all (cdr all)) ! (custom-field-factory-reset field)))) ! ! (defun custom-field-factory-reset (field) ! "Reset FIELD to its default value." ! (interactive (list (or (get-text-property (point) 'custom-field) ! (get-text-property (point) 'custom-tag)))) ! (if (arrayp field) ! (let* ((custom (custom-field-custom field)) ! (default (custom-default custom))) ! (save-excursion ! (funcall (custom-property custom 'factory-reset) field))))) (defun custom-apply-all () "Apply any changes since the last reset in all fields." ! (interactive (if custom-modified-list ! nil ! (error "No changes to apply."))) (let ((all custom-name-fields) name field) (while all *************** *** 1103,1126 **** "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 --- 1712,1786 ---- "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 (arrayp field) ! (let* ((custom (custom-field-custom field)) ! (error (custom-field-validate custom field))) ! (if error ! (error (cdr error))) ! (funcall (custom-property custom 'apply) field)))) (defun custom-toggle-hide (&rest ignore) "Hide or show entry." (interactive) (error "This button is not yet implemented")) + (defun custom-save () + "Save customization information." + (interactive) + (custom-apply-all) + (let ((new custom-name-fields)) + (set-buffer (find-file-noselect custom-file)) + (goto-char (point-min)) + (save-excursion + (let ((old (condition-case nil + (read (current-buffer)) + (end-of-file (append '(setq custom-dummy + 'custom-dummy) ()))))) + (or (eq (car old) 'setq) + (error "Invalid customization file: %s" custom-file)) + (while new + (let* ((field (cdr (car new))) + (custom (custom-field-custom field)) + (value (custom-field-original field)) + (default (custom-default custom)) + (name (car (car new)))) + (setq new (cdr new)) + (custom-assert '(eq name (custom-name custom))) + (if (equal default value) + (setcdr old (custom-plist-delq name (cdr old))) + (setcdr old (plist-put (cdr old) name + (custom-quote custom value)))))) + (erase-buffer) + (insert ";; " custom-file "\ + --- Automatically generated customization information. + ;; + ;; Feel free to edit by hand, but the entire content should consist of + ;; a single setq. Any other lisp expressions will confuse the + ;; automatic configuration engine. + + \(setq ") + (setq old (cdr old)) + (while old + (prin1 (car old) (current-buffer)) + (setq old (cdr old)) + (insert " ") + (pp (car old) (current-buffer)) + (setq old (cdr old)) + (if old (insert "\n "))) + (insert ")\n") + (save-buffer) + (kill-buffer (current-buffer)))))) + + (defun custom-load () + "Save customization information." + (interactive (and custom-modified-list + (not (equal (list (custom-name-field 'custom-file)) + custom-modified-list)) + (not (y-or-n-p "Discard all changes? ")) + (error "Load aborted"))) + (load-file (custom-name-value 'custom-file)) + (custom-reset-all)) + ;;; Field Editing: ;; ;; Various internal functions for implementing the direct editing of *************** *** 1135,1141 **** (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)))))) --- 1795,1802 ---- (setq custom-modified-list (delq field custom-modified-list)) (if (arrayp field) (let ((value (custom-field-value field))) ! (cond ((null (custom-data (custom-field-custom field)))) ! ((arrayp value) (custom-field-untouch value)) ((listp value) (mapcar 'custom-field-untouch value)))))) *************** *** 1157,1211 **** '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)))) --- 1818,1833 ---- 'face (custom-field-face field) 'front-sticky t)))) (defun custom-field-read (field) ;; Read the screen content of FIELD. (custom-read (custom-field-custom field) (buffer-substring-no-properties (custom-field-start field) (custom-field-end field)))) (defun custom-field-leave (field) ;; Deactivate FIELD. ! (let ((before-change-functions nil) ! (after-change-functions nil)) (put-text-property (custom-field-start field) (custom-field-end field) 'face (custom-field-face field)))) *************** *** 1216,1223 **** (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)) --- 1838,1845 ---- (custom (custom-field-custom field)) (padding (custom-padding custom)) (allow (custom-allow-padding custom)) ! (before-change-functions nil) ! (after-change-functions nil)) (or (and (eq this-command 'self-insert-command) allow) (let ((pos end)) *************** *** 1335,1340 **** --- 1957,2052 ---- (setq string (concat (substring string 0 (match-beginning 0)) (substring string (match-end 0)))))) string) + + (defun custom-plist-memq (prop plist) + "Return non-nil if PROP is a property of PLIST. Comparison done with EQ." + (let (result) + (while plist + (if (eq (car plist) prop) + (setq result plist + plist nil) + (setq plist (cdr (cdr plist))))) + result)) + + (defun custom-plist-delq (prop plist) + "Delete property PROP from property list PLIST." + (while (eq (car plist) prop) + (setq plist (cdr (cdr plist)))) + (let ((list plist) + (next (cdr (cdr plist)))) + (while next + (if (eq (car next) prop) + (progn + (setq next (cdr (cdr next))) + (setcdr (cdr list) next)) + (setq list next + next (cdr (cdr next)))))) + plist) + + ;;; Meta Customization: + + (custom-declare '() + '((tag . "Meta Customization") + (doc . "Customization of the customization support.") + (type . group) + (data ((type . face-doc)) + ((tag . "Button Face") + (default . bold) + (doc . "Face used for tags in customization buffers.") + (name . custom-button-face) + (synchronize . (lambda (f) + (put custom-button-properties + 'face custom-button-face))) + (type . face)) + ((tag . "Mouse Face") + (default . highlight) + (doc . "\ + Face used when mouse is above a button in customization buffers.") + (name . custom-mouse-face) + (synchronize . (lambda (f) + (put custom-button-properties + 'mouse-face custom-mouse-face))) + (type . face)) + ((tag . "Field Face") + (default . italic) + (doc . "Face used for customization fields.") + (name . custom-field-face) + (type . face)) + ((tag . "Uninitialized Face") + (default . modeline) + (doc . "Face used for uninitialized customization fields.") + (name . custom-field-uninitialized-face) + (type . face)) + ((tag . "Invalid Face") + (default . highlight) + (doc . "\ + Face used for customization fields containing invalid data.") + (name . custom-field-invalid-face) + (type . face)) + ((tag . "Modified Face") + (default . bold-italic) + (doc . "Face used for modified customization fields.") + (name . custom-field-modified-face) + (type . face)) + ((tag . "Active Face") + (default . underline) + (doc . "\ + Face used for customization fields while they are being edited.") + (name . custom-field-active-face) + (type . face))))) + + (if (file-readable-p custom-file) + (load-file custom-file)) + + (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) (provide 'custom) *** pub/dgnus/lisp/gnus-cus.el Sat Jun 10 01:44:20 1995 --- dgnus/lisp/gnus-cus.el Sat Jun 10 01:39:59 1995 *************** *** 0 **** --- 1,41 ---- + ;;; gnus-cus.el --- User friendly customization of GNUS. + ;; Copyright (C) 1995 Free Software Foundation, Inc. + ;; + ;; Author: Per Abrahamsen + ;; Keywords: help, news + ;; Version: 0.0 + + ;;; Code: + + (require 'custom) + + (custom-declare '() + '((tag . "GNUS") + (doc . "\ + The coffe-brewing, all singing, all dancing, kitchen sink newsreader.") + (type . group) + (data ((tag . "Visual") + (doc . "\ + GNUS can be made colorful and fun or grey and dull as you wish.") + (type . group) + (data ((tag . "Visual") + (doc . "Enable visual features. + If `visual' is disabled, there will be no menus and no faces. All + the visual customization options below will be ignored. GNUS will use + less space and be faster as a result.") + (default . t) + (name . gnus-visual) + (type . toggle)) + ((tag . "Summary Selected Face") + (doc . "\ + Face used for highlighting the current article in the summary buffer.") + (name . gnus-summary-selected-face) + (default . underline) + (type . face)) + ;;; gnus-summary-highlight + ;;; need cons and sexp + ))))) + + (provide 'gnus-cus) + + ;;; gnus-cus.el ends here *** pub/dgnus/lisp/gnus-edit.el Fri Jun 9 20:01:45 1995 --- dgnus/lisp/gnus-edit.el Sat Jun 10 01:39:59 1995 *************** *** 3,9 **** ;; ;; Author: Per Abrahamsen ;; Keywords: news, help ! ;; Version: 0.1 ;;; Commentary: ;; --- 3,9 ---- ;; ;; Author: Per Abrahamsen ;; Keywords: news, help ! ;; Version: 0.2 ;;; Commentary: ;; *************** *** 14,21 **** (require 'custom) (require 'gnus-score) - (autoload 'gnus-score-load "gnus-score") - (defconst gnus-score-custom-data '((tag . "Score") (doc . "Customization of Gnus SCORE files. --- 14,19 ---- *************** *** 26,32 **** 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. --- 24,30 ---- sort the articles by score (`C-c C-s C-s') or to jump to the unread article with the highest score (`,').") (type . group) ! (data "\n" ((header . nil) (doc . "Name of SCORE file to customize. *************** *** 105,123 **** 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 --- 103,119 ---- Someone should explain me the difference between this and `expunge' alone or combined with `mark'.") (type . gnus-score-custom-maybe-type)) ! ((name . eval) ! (tag . "Eval") ! (doc . "\ ! Evaluate this lisp expression when the entering summary buffer.") ! (type . sexp)) ((name . read-only) (tag . "Read Only") (doc . "Read-only score files will not be updated or saved. Except from this buffer, of course!") (type . toggle)) ((type . doc) (doc . "\ Each news header has an associated list of score entries. You can use the [INS] buttons to add new score entries anywhere in the *************** *** 202,208 **** 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 --- 198,203 ---- *************** *** 248,254 **** 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. --- 243,248 ---- *************** *** 267,290 **** ((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 --- 261,406 ---- ((name . orphan) (tag . "Orphan") (doc . "Score to add to articles with no parents.") ! (type . gnus-score-custom-maybe-type)) ! ((name . adapt) ! (tag . "Adapt") ! (doc . "Adapting the score files to your newsreading habits. ! ! When you have finished reading a group GNUS can automatically create ! new score entries based on which articles you read and which you ! skipped. This is normally controled by the two global variables ! `gnus-use-adaptive-scoring' and `gnus-default-adaptive-score-alist', ! The first determines whether adaptive scoring should be enabled or ! not, while the second determines what score entries should be created. ! ! You can overwrite the setting of `gnus-use-adaptive-scoring' by ! selecting `Enable' or `Disable' by pressing the `Adapt' button. ! Selecting `Custom' will allow you to specify the exact adaption ! rules (overwriting `gnus-default-adaptive-score-alist').") ! (type . choice) ! (data ((tag . "Default") ! (default . nil) ! (type . const)) ! ((tag . "Enable") ! (default . t) ! (type . const)) ! ((tag . "Disable") ! (default . ignore) ! (type . const)) ! ((tag . "Custom") ! (doc . "Customization of adaptive scoring. ! ! Each time you read an article it will be marked as read. Likewise, if ! you delete it it will be marked as deleted, and if you tick it it will ! be marked as ticked. When you leave a group, GNUS can automatically ! create score file entries based on these marks, so next time you enter ! the group articles with subjects that you read last time have higher ! score and articles with subjects that deleted will have lower score. ! ! Below is a list of such marks. You can insert new marks to the list ! by pushing on one of the `[INS]' buttons in the left margin to create ! a new entry and then pushing the `Mark' button to select the mark. ! For each mark there is another list, this time of article headers, ! which determine how the mark should affect that header. The `[INS]' ! buttons of this list are indented to indicate that the belong to the ! mark above. Push the `Header' button to choose a header, and then ! enter a score value in the `Score' field. ! ! For each article that are marked with `Mark' when you leave the ! group, a temporary score entry for the articles `Header' with the ! value of `Score' will be added the adapt file. If the score entry ! already exists, `Score' will be added to its value. If you understood ! that, you are smart. ! ! You can select the special value `Other' when pressing the `Mark' or ! `Header' buttons. This is because Lars might add more useful values ! there. If he does, it is up to you to figure out what they are named.") ! (type . list) ! (default . ((__uninitialized__))) ! (data ((type . repeat) ! (header . nil) ! (data . ((type . list) ! (header . nil) ! (compact . t) ! (data ((type . choice) ! (tag . "Mark") ! (data ((tag . "Unread") ! (default . gnus-unread-mark) ! (type . const)) ! ((tag . "Ticked") ! (default . gnus-ticked-mark) ! (type . const)) ! ((tag . "Dormant") ! (default . gnus-dormant-mark) ! (type . const)) ! ((tag . "Deleted") ! (default . gnus-del-mark) ! (type . const)) ! ((tag . "Read") ! (default . gnus-read-mark) ! (type . const)) ! ((tag . "Expirable") ! (default . gnus-expirable-mark) ! (type . const)) ! ((tag . "Killed") ! (default . gnus-killed-mark) ! (type . const)) ! ((tag . "Kill-file") ! (default . gnus-kill-file-mark) ! (type . const)) ! ((tag . "Low-score") ! (default . gnus-low-score-mark) ! (type . const)) ! ((tag . "Catchup") ! (default . gnus-catchup-mark) ! (type . const)) ! ((tag . "Ancient") ! (default . gnus-ancient-mark) ! (type . const)) ! ((tag . "Canceled") ! (default . gnus-canceled-mark) ! (type . const)) ! ((prompt . "Other") ! (default . ??) ! (type . sexp)))) ! ((type . repeat) ! (prefix . " ") ! (data . ((type . list) ! (compact . t) ! (data ((tag . "Header") ! (type . choice) ! (data ((tag . "Subject") ! (default . subject) ! (type . const)) ! ((prompt . "From") ! (tag . "From ") ! (default . from) ! (type . const)) ! ((prompt . "Other") ! (width . 7) ! (default . nil) ! (type . symbol)))) ! ((tag . "Score") ! (type . integer)))))))))))))) ! ((name . local) ! (tag . "Local") ! (doc . "\ ! List of local variables to set when this score file is loaded. ! ! Using this entry can provide a convenient way to set variables that ! will affect the summary mode for only some specific groups, i.e. those ! groups matched by the current score file.") ! (type . list) ! (data ((type . repeat) ! (header . nil) ! (data . ((type . list) ! (compact . t) ! (data ((tag . "Name") ! (width . 26) ! (type . symbol)) ! ((tag . "Value") ! (width . 26) ! (type . sexp))))))))))) (defconst gnus-score-custom-type-properties '((gnus-score-custom-maybe-type *************** *** 303,309 **** (data ((tag . "Match") (width . 59) (type . string)) ! "\n " ((tag . "Score") (type . integer)) ((tag . "Date") --- 419,425 ---- (data ((tag . "Match") (width . 59) (type . string)) ! "\n " ((tag . "Score") (type . integer)) ((tag . "Date") *************** *** 431,437 **** (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))))))) --- 547,553 ---- (if entry (mapcar 'gnus-score-custom-sanify (cdr entry)) (setq entry (assoc name gnus-score-alist)) ! (if (memq name '(files exclude-files local adapt)) (cdr entry) (car (cdr entry))))))) *************** *** 452,463 **** (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)) ! ((listp value) (setq gnus-score-alist (cons (cons name value) gnus-score-alist))) (t (setq gnus-score-alist --- 568,579 ---- (cond ((null value) (setq gnus-score-alist (delq (assoc name gnus-score-alist) gnus-score-alist))) ! ((and (listp value) (not (eq name 'eval))) (setcdr (assoc name gnus-score-alist) value)) (t (setcdr (assoc name gnus-score-alist) (list value))))) ((null value)) ! ((and (listp value) (not (eq name 'eval))) (setq gnus-score-alist (cons (cons name value) gnus-score-alist))) (t (setq gnus-score-alist *** pub/dgnus/lisp/gnus-score.el Fri Jun 9 20:01:45 1995 --- dgnus/lisp/gnus-score.el Sat Jun 10 01:40:00 1995 *************** *** 581,587 **** (setq gnus-newsgroup-adaptive t) adapt) (t ! (setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring) gnus-default-adaptive-score-alist))) (setq gnus-summary-mark-below (or mark mark-and-expunge gnus-summary-mark-below)) --- 581,587 ---- (setq gnus-newsgroup-adaptive t) adapt) (t ! ;;(setq gnus-newsgroup-adaptive gnus-use-adaptive-scoring) gnus-default-adaptive-score-alist))) (setq gnus-summary-mark-below (or mark mark-and-expunge gnus-summary-mark-below)) *** pub/dgnus/lisp/gnus-uu.el Fri Jun 9 20:01:46 1995 --- dgnus/lisp/gnus-uu.el Sat Jun 10 01:40:00 1995 *************** *** 1471,1477 **** (make-temp-name (concat gnus-uu-tmp-dir "gnus"))) (gnus-uu-add-file gnus-uu-work-dir) (if (not (file-directory-p gnus-uu-work-dir)) ! (make-directory gnus-uu-work-dir)) (set-file-modes gnus-uu-work-dir 448) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir))) --- 1471,1477 ---- (make-temp-name (concat gnus-uu-tmp-dir "gnus"))) (gnus-uu-add-file gnus-uu-work-dir) (if (not (file-directory-p gnus-uu-work-dir)) ! (gnus-make-directory gnus-uu-work-dir)) (set-file-modes gnus-uu-work-dir 448) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir))) *** pub/dgnus/lisp/gnus-vis.el Fri Jun 9 20:01:46 1995 --- dgnus/lisp/gnus-vis.el Sat Jun 10 01:40:01 1995 *************** *** 786,826 **** (save-excursion (set-buffer gnus-article-buffer) (goto-char (point-min)) ! (search-forward "\n\n") ! (beginning-of-line 0) ! (while (not (bobp)) ! (let ((alist gnus-header-face-alist) ! (buffer-read-only nil) ! (case-fold-search t) ! (end (point)) ! (inhibit-point-motion-hooks t) ! begin entry regexp header-face field-face header-found field-found) ! (re-search-backward "^[^ \t]" nil t) ! (setq begin (point)) ! (while alist ! (setq entry (car alist) ! regexp (nth 0 entry) ! header-face (nth 1 entry) ! field-face (nth 2 entry) ! alist (cdr alist)) ! (if (looking-at regexp) ! (let ((from (point))) ! (skip-chars-forward "^:\n") ! (and (not header-found) ! header-face ! (progn ! (put-text-property from (point) 'face header-face) ! (setq header-found t))) ! (and (not field-found) ! field-face ! (progn ! (skip-chars-forward ": \t") ! (let ((from (point))) ! (goto-char end) ! (skip-chars-backward " \t") ! (put-text-property from (point) 'face field-face) ! (setq field-found t)))))) ! (goto-char begin)))))) (defun gnus-article-highlight-signature () "Highlight the signature in an article. --- 786,828 ---- (save-excursion (set-buffer gnus-article-buffer) (goto-char (point-min)) ! (if (not (search-forward "\n\n" nil t)) ! () ! (beginning-of-line 0) ! (while (not (bobp)) ! (let ((alist gnus-header-face-alist) ! (buffer-read-only nil) ! (case-fold-search t) ! (end (point)) ! (inhibit-point-motion-hooks t) ! begin entry regexp header-face field-face ! header-found field-found) ! (re-search-backward "^[^ \t]" nil t) ! (setq begin (point)) ! (while alist ! (setq entry (car alist) ! regexp (nth 0 entry) ! header-face (nth 1 entry) ! field-face (nth 2 entry) ! alist (cdr alist)) ! (if (looking-at regexp) ! (let ((from (point))) ! (skip-chars-forward "^:\n") ! (and (not header-found) ! header-face ! (progn ! (put-text-property from (point) 'face header-face) ! (setq header-found t))) ! (and (not field-found) ! field-face ! (progn ! (skip-chars-forward ": \t") ! (let ((from (point))) ! (goto-char end) ! (skip-chars-backward " \t") ! (put-text-property from (point) 'face field-face) ! (setq field-found t)))))) ! (goto-char begin))))))) (defun gnus-article-highlight-signature () "Highlight the signature in an article. *** pub/dgnus/lisp/gnus.el Fri Jun 9 20:01:50 1995 --- dgnus/lisp/gnus.el Sat Jun 10 01:40:04 1995 *************** *** 1283,1289 **** (defconst gnus-maintainer "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls & Boys)" "The mail address of the Gnus maintainers.") ! (defconst gnus-version "(ding) Gnus v0.84" "Version number for this version of Gnus.") (defvar gnus-info-nodes --- 1283,1289 ---- (defconst gnus-maintainer "gnus-bug@ifi.uio.no (The Gnus Bugfixing Girls & Boys)" "The mail address of the Gnus maintainers.") ! (defconst gnus-version "(ding) Gnus v0.85" "Version number for this version of Gnus.") (defvar gnus-info-nodes *************** *** 1470,1476 **** gnus-score-alist gnus-current-score-file gnus-summary-expunge-below gnus-summary-mark-below gnus-newsgroup-active gnus-scores-exclude-files gnus-newsgroup-history gnus-newsgroup-ancient ! gnus-newsgroup-adaptive) "Variables that are buffer-local to the summary buffers.") (defconst gnus-bug-message --- 1470,1476 ---- gnus-score-alist gnus-current-score-file gnus-summary-expunge-below gnus-summary-mark-below gnus-newsgroup-active gnus-scores-exclude-files gnus-newsgroup-history gnus-newsgroup-ancient ! (gnus-newsgroup-adaptive . gnus-use-adaptive-scoring)) "Variables that are buffer-local to the summary buffers.") (defconst gnus-bug-message *************** *** 2197,2203 **** (save-excursion (gnus-set-work-buffer) (insert subject) ! (inline gnus-simplify-buffer-fuzzy) (buffer-string)))) (defun gnus-simplify-buffer-fuzzy () --- 2197,2203 ---- (save-excursion (gnus-set-work-buffer) (insert subject) ! (inline (gnus-simplify-buffer-fuzzy)) (buffer-string)))) (defun gnus-simplify-buffer-fuzzy () *************** *** 2368,2376 **** (if (and (listp (car hor)) (eq (car (car hor)) 'horizontal)) (progn ! (split-window nil (- (frame-width) ! (floor (* (frame-width) (nth 1 (car hor))))) ! t) (setq hor (cdr hor)))) ;; Go through the rules and eval the elements that are to be --- 2368,2379 ---- (if (and (listp (car hor)) (eq (car (car hor)) 'horizontal)) (progn ! (split-window ! nil ! (if (integerp (nth 1 (car hor))) ! (nth 1 (car hor)) ! (- (frame-width) (floor (* (frame-width) (nth 1 (car hor)))))) ! t) (setq hor (cdr hor)))) ;; Go through the rules and eval the elements that are to be *************** *** 3913,3920 **** (part (or part 'info)) (winconf (current-window-configuration)) info) ! (if group (setq info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) ! (error "No group on current line")) (set-buffer (get-buffer-create gnus-group-edit-buffer)) (gnus-configure-windows 'edit-group) (gnus-add-current-to-buffer-list) --- 3916,3924 ---- (part (or part 'info)) (winconf (current-window-configuration)) info) ! (or group (error "No group on current line")) ! (or (setq info (nth 2 (gnus-gethash group gnus-newsrc-hashtb))) ! (error "Killed group; can't be edited")) (set-buffer (get-buffer-create gnus-group-edit-buffer)) (gnus-configure-windows 'edit-group) (gnus-add-current-to-buffer-list) *************** *** 7410,7417 **** ;; We have reached the final group in the group ;; buffer. (progn ! (set-buffer sumbuf) ! (gnus-summary-exit))))))))) (defun gnus-summary-prev-group (no-article) "Exit current newsgroup and then select previous unread newsgroup. --- 7414,7423 ---- ;; We have reached the final group in the group ;; buffer. (progn ! (if (buffer-name sumbuf) ! (progn ! (set-buffer sumbuf) ! (gnus-summary-exit))))))))))) (defun gnus-summary-prev-group (no-article) "Exit current newsgroup and then select previous unread newsgroup. *************** *** 7908,7920 **** (gnus-group-prefixed-name gnus-newsgroup-name (list 'nndoc "")) gnus-current-article)) (buf (current-buffer))) (if (gnus-group-read-ephemeral-group name (list 'nndoc name (list 'nndoc-address (get-buffer gnus-article-buffer)) '(nndoc-article-type digest)) t) ! () (switch-to-buffer buf) (gnus-set-global-variables) (gnus-configure-windows 'summary) --- 7914,7928 ---- (gnus-group-prefixed-name gnus-newsgroup-name (list 'nndoc "")) gnus-current-article)) + (ogroup gnus-newsgroup-name) (buf (current-buffer))) (if (gnus-group-read-ephemeral-group name (list 'nndoc name (list 'nndoc-address (get-buffer gnus-article-buffer)) '(nndoc-article-type digest)) t) ! (setcdr (nthcdr 4 (nth 2 (gnus-gethash name gnus-newsrc-hashtb))) ! (list (list (cons 'to-group ogroup)))) (switch-to-buffer buf) (gnus-set-global-variables) (gnus-configure-windows 'summary) *************** *** 11424,11430 **** (or hashtb (setq hashtb (gnus-make-hashtable (count-lines (point-min) (point-max))))) ;; Enter all the new groups in a hashtable. ! (gnus-active-to-gnus-format (car methods) hashtb))) (setq methods (cdr methods))) (and got-new (setq gnus-newsrc-last-checked-date new-date)) ;; Now all new groups from all select methods are in `hashtb'. --- 11432,11438 ---- (or hashtb (setq hashtb (gnus-make-hashtable (count-lines (point-min) (point-max))))) ;; Enter all the new groups in a hashtable. ! (gnus-active-to-gnus-format (car methods) hashtb 'ignore))) (setq methods (cdr methods))) (and got-new (setq gnus-newsrc-last-checked-date new-date)) ;; Now all new groups from all select methods are in `hashtb'. *************** *** 11436,11442 **** (member group gnus-killed-list)) ;; The group is already known. () ! (gnus-sethash group (symbol-value group-sym) gnus-active-hashtb) (let ((do-sub (gnus-matches-options-n group))) (cond ((eq do-sub 'subscribe) (setq groups (1+ groups)) --- 11444,11451 ---- (member group gnus-killed-list)) ;; The group is already known. () ! (and (symbol-value group-sym) ! (gnus-sethash group (symbol-value group-sym) gnus-active-hashtb)) (let ((do-sub (gnus-matches-options-n group))) (cond ((eq do-sub 'subscribe) (setq groups (1+ groups)) *************** *** 12015,12021 **** (setq methods (cdr methods)))))) ;; Read an active file and place the results in `gnus-active-hashtb'. ! (defun gnus-active-to-gnus-format (method &optional hashtb) (let ((cur (current-buffer)) (hashtb (or hashtb (if method --- 12024,12030 ---- (setq methods (cdr methods)))))) ;; Read an active file and place the results in `gnus-active-hashtb'. ! (defun gnus-active-to-gnus-format (method &optional hashtb ignore-errors) (let ((cur (current-buffer)) (hashtb (or hashtb (if method *************** *** 12026,12032 **** ;; Delete unnecessary lines. (goto-char (point-min)) (while (search-forward "\nto." nil t) ! (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) (or (string= gnus-ignored-newsgroups "") (progn (goto-char (point-min)) --- 12035,12042 ---- ;; Delete unnecessary lines. (goto-char (point-min)) (while (search-forward "\nto." nil t) ! (delete-region (1+ (match-beginning 0)) ! (progn (forward-line 1) (point)))) (or (string= gnus-ignored-newsgroups "") (progn (goto-char (point-min)) *************** *** 12081,12091 **** (set group nil))) (error (progn ! (ding) ! (gnus-message 3 "Warning - illegal active: %s" ! (buffer-substring ! (gnus-point-at-bol) (gnus-point-at-eol))) ! nil))) (widen) (forward-line 1)))))) --- 12091,12103 ---- (set group nil))) (error (progn ! (if ignore-errors ! (set group nil) ! (ding) ! (gnus-message 3 "Warning - illegal active: %s" ! (buffer-substring ! (gnus-point-at-bol) (gnus-point-at-eol))) ! nil)))) (widen) (forward-line 1)))))) *************** *** 12412,12419 **** (1+ gnus-level-subscribed) gnus-level-default-unsubscribed)) (nreverse reads)))) ! (setq newsrc (cons info newsrc)))) ! (forward-line 1)))) (setq newsrc (nreverse newsrc)) --- 12424,12431 ---- (1+ gnus-level-subscribed) gnus-level-default-unsubscribed)) (nreverse reads)))) ! (setq newsrc (cons info newsrc)))))) ! (forward-line 1)) (setq newsrc (nreverse newsrc)) *** pub/dgnus/lisp/nnfolder.el Fri Jun 9 20:01:50 1995 --- dgnus/lisp/nnfolder.el Sat Jun 10 01:40:04 1995 *************** *** 264,269 **** --- 264,280 ---- nnfolder-current-buffer nil) t) + (defun nnfolder-request-create-group (group &optional server) + (nnfolder-request-list) + (setq nnfolder-group-alist (nnmail-get-active)) + (or (assoc group nnfolder-group-alist) + (let (active) + (setq nnfolder-group-alist + (cons (list group (setq active (cons 0 0))) + nnfolder-group-alist)) + (nnmail-save-active nnfolder-group-alist nnfolder-active-file))) + t) + (defun nnfolder-request-list (&optional server) (if server (nnfolder-get-new-mail)) (save-excursion *************** *** 368,374 **** (insert "From nobody " (current-time-string) "\n")) (and (nnfolder-request-list) ! (progn (set-buffer buf) (goto-char (point-min)) (search-forward "\n\n" nil t) --- 379,385 ---- (insert "From nobody " (current-time-string) "\n")) (and (nnfolder-request-list) ! (save-excursion (set-buffer buf) (goto-char (point-min)) (search-forward "\n\n" nil t) *************** *** 378,387 **** (setq result (car (nnfolder-save-mail (and (stringp group) group))))) (save-excursion (set-buffer nnfolder-current-buffer) ! (insert-buffer-substring buf) ! (and last (buffer-modified-p) (save-buffer)) ! result) ! (nnmail-save-active nnfolder-group-alist nnfolder-active-file)) result)) (defun nnfolder-request-replace-article (article group buffer) --- 389,396 ---- (setq result (car (nnfolder-save-mail (and (stringp group) group))))) (save-excursion (set-buffer nnfolder-current-buffer) ! (and last (buffer-modified-p) (save-buffer)))) ! (nnmail-save-active nnfolder-group-alist nnfolder-active-file) result)) (defun nnfolder-request-replace-article (article group buffer) *************** *** 463,471 **** () (if (not (file-exists-p file)) (write-region 1 1 file t 'nomesg)) - (set-buffer (nnfolder-read-folder file)) (setq nnfolder-buffer-alist (cons (list group (current-buffer)) ! nnfolder-buffer-alist))))))) (setq nnfolder-current-group group)) (defun nnfolder-save-mail (&optional group) --- 472,480 ---- () (if (not (file-exists-p file)) (write-region 1 1 file t 'nomesg)) (setq nnfolder-buffer-alist (cons (list group (current-buffer)) ! nnfolder-buffer-alist)) ! (set-buffer (nnfolder-read-folder file))))))) (setq nnfolder-current-group group)) (defun nnfolder-save-mail (&optional group) *** pub/dgnus/lisp/nnspool.el Fri Jun 9 20:01:51 1995 --- dgnus/lisp/nnspool.el Sat Jun 10 01:40:05 1995 *************** *** 419,425 **** (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)) --- 419,425 ---- (erase-buffer) (call-process "grep" nil t nil id nnspool-history-file) (goto-char (point-min)) ! (if (looking-at "<[^>]+>[ \t]+[-0-9~]+[ \t]+\\([^ \t]*\\)") (concat nnspool-spool-directory (nnspool-replace-chars-in-string (buffer-substring (match-beginning 1) (match-end 1)) *** pub/dgnus/lisp/ChangeLog Fri Jun 9 20:01:56 1995 --- dgnus/lisp/ChangeLog Sat Jun 10 01:40:11 1995 *************** *** 1,4 **** --- 1,50 ---- + Sat Jun 10 00:15:13 1995 Lars Ingebrigtsen + + * gnus.el (gnus-ask-server-for-new-groups): Ignore errors while + reading newgroups files. + (gnus-summary-next-group): Would bug out when all articles were + expinged from scoring. + (gnus-simplify-subject-fuzzy): Totally bugged out. + + Thu Jun 8 22:27:07 1995 Per Abrahamsen + + * custom.el: Added support for faces, sexp, and pair types. Added + support for declaring emacs packages. Added support for loading, + saveing, and editing Emacs customization. Declared all user + variables in the custom package itself. + + * gnus-edit.el: Added support for `eval', `adapt', and `local' + entries. + + * gnus-cus.el: New file. + Fri Jun 9 00:07:16 1995 Lars Ingebrigtsen + + * gnus-uu.el (gnus-uu-initialize): Create tmp dir recursively. + + * gnus.el (gnus-group-edit-group): Refuse to edit killed groups. + (gnus-summary-enter-digest-group): Have followups in digest groups + go to the parent group. + (gnus-newsrc-to-gnus-format): Would infloop on empty lines. + + * gnus-score.el (gnus-score-load-file): Have adapt nil do nothing + much. + (gnus-score-load-file): Have a nil 'adapt entry mean "use current + value". + + * gnus-vis.el (gnus-article-highlight-headers): Would sometimes + bug out. + + * gnus.el (gnus-configure-windows): Accept integer hor specs. + + * nnfolder.el (nnfolder-request-create-group): Make sure new + groups that are created are, indeedn, created. + (nnfolder-request-accept-article): Would save two copies of all + mail. + + Fri Jun 9 00:07:16 1995 Lars Ingebrigtsen + + * gnus.el: 0.84 is released. * nneething.el (nneething-retrieve-headers): Check for empty files. *** pub/dgnus/texi/gnus.texi Fri Jun 9 20:01:59 1995 --- dgnus/texi/gnus.texi Sat Jun 10 01:40:12 1995 *************** *** 277,283 **** ;; use this instead. note that the final t is *essential*, ;; this must be the last thing done (add-hook 'gnus-article-display-hook ! 'gnus-article-highlight t))) @end lisp --- 277,283 ---- ;; use this instead. note that the final t is *essential*, ;; this must be the last thing done (add-hook 'gnus-article-display-hook ! 'gnus-article-maybe-highlight t))) @end lisp