*** pub/rgnus/lisp/custom.el Mon Sep 9 19:29:04 1996 --- rgnus/lisp/custom.el Tue Sep 17 02:39:38 1996 *************** *** 1,2400 **** - ;;; custom.el --- User friendly customization support. - - ;; Copyright (C) 1995, 1996 Free Software Foundation, Inc. - - ;; Author: Per Abrahamsen - ;; Keywords: help - ;; Version: 0.5 - - ;; This file is part of GNU Emacs. - - ;; GNU Emacs is free software; you can redistribute it and/or modify - ;; it under the terms of the GNU General Public License as published by - ;; the Free Software Foundation; either version 2, or (at your option) - ;; any later version. - - ;; GNU Emacs is distributed in the hope that it will be useful, - ;; but WITHOUT ANY WARRANTY; without even the implied warranty of - ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;; GNU General Public License for more details. - - ;; You should have received a copy of the GNU General Public License - ;; along with GNU Emacs; see the file COPYING. If not, write to the - ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, - ;; Boston, MA 02111-1307, USA. - - ;;; 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 intent is that authors of emacs lisp packages declare the - ;; variables intended for user customization with `custom-declare'. - ;; Custom can then automatically generate a customization buffer with - ;; `custom-buffer-create' where the user can edit the package - ;; variables in a simple and intuitive way, as well as a menu with - ;; `custom-menu-create' where he can set the more commonly used - ;; variables interactively. - ;; - ;; It is also possible to use custom for modifying the properties of - ;; other objects than the package itself, by specifying extra optional - ;; arguments to `custom-buffer-create'. - ;; - ;; Custom is inspired by OPEN LOOK property windows. - - ;;; Todo: - ;; - ;; - Toggle documentation in three states `none', `one-line', `full'. - ;; - Function to generate an XEmacs menu from a CUSTOM. - ;; - Write TeXinfo documentation. - ;; - Make it possible to hide sections by clicking at the level. - ;; - Declare AUC TeX variables. - ;; - Declare (ding) Gnus variables. - ;; - Declare Emacs variables. - ;; - Implement remaining types. - ;; - XEmacs port. - ;; - Allow `URL', `info', and internal hypertext buttons. - ;; - Support meta-variables and goal directed customization. - ;; - Make it easy to declare custom types independently. - ;; - Make it possible to declare default value and type for a single - ;; variable, storing the data in a symbol property. - ;; - Syntactic sugar for CUSTOM declarations. - ;; - Use W3 for variable documentation. - - ;;; Code: - - (eval-when-compile - (require 'cl)) - - ;;; Compatibility: - - (defun custom-xmas-add-text-properties (start end props &optional object) - (add-text-properties start end props object) - (put-text-property start end 'start-open t object) - (put-text-property start end 'end-open t object)) - - (defun custom-xmas-put-text-property (start end prop value &optional object) - (put-text-property start end prop value object) - (put-text-property start end 'start-open t object) - (put-text-property start end 'end-open t object)) - - (defun custom-xmas-extent-start-open () - (map-extents (lambda (extent arg) - (set-extent-property extent 'start-open t)) - nil (point) (min (1+ (point)) (point-max)))) - - (if (string-match "XEmacs\\|Lucid" emacs-version) - (progn - (fset 'custom-add-text-properties 'custom-xmas-add-text-properties) - (fset 'custom-put-text-property 'custom-xmas-put-text-property) - (fset 'custom-extent-start-open 'custom-xmas-extent-start-open) - (fset 'custom-set-text-properties - (if (fboundp 'set-text-properties) - 'set-text-properties)) - (fset 'custom-buffer-substring-no-properties - (if (fboundp 'buffer-substring-no-properties) - 'buffer-substring-no-properties - 'custom-xmas-buffer-substring-no-properties))) - (fset 'custom-add-text-properties 'add-text-properties) - (fset 'custom-put-text-property 'put-text-property) - (fset 'custom-extent-start-open 'ignore) - (fset 'custom-set-text-properties 'set-text-properties) - (fset 'custom-buffer-substring-no-properties - 'buffer-substring-no-properties)) - - (defun custom-xmas-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))) - (custom-set-text-properties 0 (length string) nil string) - string)) - - ;; XEmacs and Emacs 19.29 facep does different things. - (defalias 'custom-facep - (cond ((fboundp 'find-face) - 'find-face) - ((fboundp 'facep) - 'facep) - (t - 'ignore))) - - (if (custom-facep 'underline) - () - ;; No underline face in XEmacs 19.12. - (and (fboundp 'make-face) - (funcall (intern "make-face") 'underline)) - ;; Must avoid calling set-face-underline-p directly, because it - ;; is a defsubst in emacs19, and will make the .elc files non - ;; portable! - (or (and (fboundp 'face-differs-from-default-p) - (face-differs-from-default-p 'underline)) - (and (fboundp 'set-face-underline-p) - (funcall 'set-face-underline-p 'underline t)))) - - (defun custom-xmas-set-text-properties (start end props &optional buffer) - (if (null buffer) - (if props - (while props - (custom-put-text-property - start end (car props) (nth 1 props) buffer) - (setq props (nthcdr 2 props))) - (remove-text-properties start end ())))) - - (or (fboundp 'event-point) - ;; Missing in Emacs 19.29. - (defun event-point (event) - "Return the character position of the given mouse-motion, button-press, - or button-release event. If the event did not occur over a window, or did - not occur over text, then this returns nil. Otherwise, it returns an index - into the buffer visible in the event's window." - (posn-point (event-start event)))) - - (eval-when-compile - (defvar x-colors nil) - (defvar custom-button-face nil) - (defvar custom-field-uninitialized-face nil) - (defvar custom-field-invalid-face nil) - (defvar custom-field-modified-face nil) - (defvar custom-field-face nil) - (defvar custom-mouse-face nil) - (defvar custom-field-active-face nil)) - - ;; We can't easily check for a working intangible. - (defconst intangible (if (and (boundp 'emacs-minor-version) - (or (> emacs-major-version 19) - (and (> emacs-major-version 18) - (> emacs-minor-version 28)))) - (setq intangible 'intangible) - (setq intangible 'intangible-if-it-had-been-working)) - "The symbol making text intangible.") - - (defconst rear-nonsticky (if (string-match "XEmacs" emacs-version) - 'end-open - 'rear-nonsticky) - "The symbol making text properties non-sticky in the rear end.") - - (defconst front-sticky (if (string-match "XEmacs" emacs-version) - 'front-closed - 'front-sticky) - "The symbol making text properties sticky in the front.") - - (defconst mouse-face (if (string-match "XEmacs" emacs-version) - 'highlight - 'mouse-face) - "Symbol used for highlighting text under mouse.") - - ;; Put it in the Help menu, if possible. - (if (string-match "XEmacs" emacs-version) - (if (featurep 'menubar) - ;; XEmacs (disabled because it doesn't work) - (and current-menubar - (add-menu-item '("Help") "Customize..." 'customize t))) - ;; Emacs 19.28 and earlier - (global-set-key [ menu-bar help customize ] - '("Customize..." . customize)) - ;; Emacs 19.29 and later - (global-set-key [ menu-bar help-menu customize ] - '("Customize..." . customize))) - - ;; XEmacs popup-menu stolen from w3.el. - (defun custom-x-really-popup-menu (pos title menudesc) - "My hacked up function to do a blocking popup menu..." - (let ((echo-keystrokes 0) - event menu) - (while menudesc - (setq menu (cons (vector (car (car menudesc)) - (list (car (car menudesc))) t) menu) - menudesc (cdr menudesc))) - (setq menu (cons title menu)) - (popup-menu menu) - (catch 'popup-done - (while t - (setq event (next-command-event event)) - (cond ((and (misc-user-event-p event) (stringp (car-safe (event-object event)))) - (throw 'popup-done (event-object event))) - ((and (misc-user-event-p event) - (or (eq (event-object event) 'abort) - (eq (event-object event) 'menu-no-selection-hook))) - nil) - ((not (popup-menu-up-p)) - (throw 'popup-done nil)) - ((button-release-event-p event);; don't beep twice - nil) - (t - (beep) - (message "please make a choice from the menu."))))))) - - ;;; Categories: - ;; - ;; XEmacs use inheritable extents for the same purpose as Emacs uses - ;; the category text property. - - (if (string-match "XEmacs" emacs-version) - (progn - ;; XEmacs categories. - (defun custom-category-create (name) - (set name (make-extent nil nil)) - "Create a text property category named NAME.") - - (defun custom-category-put (name property value) - "In CATEGORY set PROPERTY to VALUE." - (set-extent-property (symbol-value name) property value)) - - (defun custom-category-get (name property) - "In CATEGORY get PROPERTY." - (extent-property (symbol-value name) property)) - - (defun custom-category-set (from to category) - "Make text between FROM and TWO have category CATEGORY." - (let ((extent (make-extent from to))) - (set-extent-parent extent (symbol-value category))))) - - ;; Emacs categories. - (defun custom-category-create (name) - "Create a text property category named NAME." - (set name name)) - - (defun custom-category-put (name property value) - "In CATEGORY set PROPERTY to VALUE." - (put name property value)) - - (defun custom-category-get (name property) - "In CATEGORY get PROPERTY." - (get name property)) - - (defun custom-category-set (from to category) - "Make text between FROM and TWO have category CATEGORY." - (custom-put-text-property from to 'category category))) - - ;;; External Data: - ;; - ;; The following functions and variables defines the interface for - ;; connecting a CUSTOM with an external entity, by default an emacs - ;; lisp variable. - - (defvar custom-external 'default-value - "Function returning the external value of NAME.") - - (defvar custom-external-set 'set-default - "Function setting the external value of NAME to VALUE.") - - (defun custom-external (name) - "Get the external value associated with NAME." - (funcall custom-external name)) - - (defun custom-external-set (name value) - "Set the external value associated with NAME to VALUE." - (funcall custom-external-set name value)) - - (defvar custom-name-fields nil - "Alist of custom names and their associated editing field.") - (make-variable-buffer-local 'custom-name-fields) - - (defun custom-name-enter (name field) - "Associate NAME with FIELD." - (if (null name) - () - (custom-assert 'field) - (setq custom-name-fields (cons (cons name field) custom-name-fields)))) - - (defun custom-name-field (name) - "The editing field associated with NAME." - (cdr (assq name custom-name-fields))) - - (defun custom-name-value (name) - "The value currently displayed for NAME in the customization buffer." - (let* ((field (custom-name-field name)) - (custom (custom-field-custom field))) - (custom-field-parse field) - (funcall (custom-property custom 'export) custom - (car (custom-field-extract custom field))))) - - (defvar custom-save 'custom-save - "Function that will save current customization buffer.") - - ;;; Custom Functions: - ;; - ;; The following functions are part of the public interface to the - ;; CUSTOM datastructure. Each CUSTOM describes a group of variables, - ;; a single variable, or a component of a structured variable. The - ;; CUSTOM instances are part of two hierarchies, 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 hierarchy is a `is-a' type hierarchy - ;; where each CUSTOM is a leaf in the hierarchy defined by the `type' - ;; property and `custom-type-properties'. - - (defvar custom-file "~/.custom.el" - "Name of file with customization information.") - - (defconst custom-data - '((tag . "Emacs") - (doc . "The extensible self-documenting text editor.") - (type . group) - (data "\n" - ((header . nil) - (compact . t) - (type . group) - (doc . "\ - Press [Save] to save any changes permanently after you are done editing. - You can load customization information from other files by editing the - `File' field and pressing the [Load] button. When you press [Save] the - customization information of all files you have loaded, plus any - changes you might have made manually, will be stored in the file - specified by the `File' field.") - (data ((tag . "Load") - (type . button) - (query . custom-load)) - ((tag . "Save") - (type . button) - (query . custom-save)) - ((name . custom-file) - (default . "~/.custom.el") - (doc . "Name of file with customization information.\n") - (tag . "File") - (type . file)))))) - "The global customization information. - A custom association list.") - - (defun custom-declare (path custom) - "Declare variables for customization. - PATH is a list of tags leading to the place in the customization - hierarchy the new entry should be added. CUSTOM is the entry to add." - (custom-initialize custom) - (let ((current (custom-travel-path custom-data path))) - (or (member custom (custom-data current)) - (nconc (custom-data current) (list custom))))) - - (put 'custom-declare 'lisp-indent-hook 1) - - (defconst custom-type-properties - '((repeat (type . default) - ;; See `custom-match'. - (import . custom-repeat-import) - (eval . custom-repeat-eval) - (quote . custom-repeat-quote) - (accept . custom-repeat-accept) - (extract . custom-repeat-extract) - (validate . custom-repeat-validate) - (insert . custom-repeat-insert) - (match . custom-repeat-match) - (query . custom-repeat-query) - (prefix . "") - (del-tag . "[DEL]") - (add-tag . "[INS]")) - (pair (type . group) - ;; A cons-cell. - (accept . custom-pair-accept) - (eval . custom-pair-eval) - (import . custom-pair-import) - (quote . custom-pair-quote) - (valid . (lambda (c d) (consp d))) - (extract . custom-pair-extract)) - (list (type . group) - ;; A lisp list. - (quote . custom-list-quote) - (valid . (lambda (c d) - (listp d))) - (extract . custom-list-extract)) - (group (type . default) - ;; See `custom-match'. - (face-tag . nil) - (eval . custom-group-eval) - (import . custom-group-import) - (initialize . custom-group-initialize) - (apply . custom-group-apply) - (reset . custom-group-reset) - (factory-reset . custom-group-factory-reset) - (extract . nil) - (validate . custom-group-validate) - (query . custom-toggle-hide) - (accept . custom-group-accept) - (insert . custom-group-insert) - (find . custom-group-find)) - (toggle (type . choice) - ;; Booleans. - (data ((type . const) - (tag . "On ") - (default . t)) - ((type . const) - (tag . "Off") - (default . nil)))) - (triggle (type . choice) - ;; On/Off/Default. - (data ((type . const) - (tag . "On ") - (default . t)) - ((type . const) - (tag . "Off") - (default . nil)) - ((type . const) - (tag . "Def") - (default . custom:asis)))) - (choice (type . default) - ;; See `custom-match'. - (query . custom-choice-query) - (accept . custom-choice-accept) - (extract . custom-choice-extract) - (validate . custom-choice-validate) - (insert . custom-choice-insert) - (none (tag . "Unknown") - (default . __uninitialized__) - (type . const))) - (const (type . default) - ;; A `const' only matches a single lisp value. - (extract . (lambda (c f) (list (custom-default c)))) - (validate . (lambda (c f) nil)) - (valid . custom-const-valid) - (update . custom-const-update) - (insert . custom-const-insert)) - (face-doc (type . doc) - ;; A variable containing a face. - (doc . "\ - You can customize the look of Emacs by deciding which faces should be - used when. If you push one of the face buttons below, you will be - given a choice between a number of standard faces. The name of the - selected face is shown right after the face button, and it is - displayed its own face so you can see how it looks. If you know of - another standard face not listed and want to use it, you can select - `Other' and write the name in the editing field. - - If none of the standard faces suits you, you can select `Customize' to - create your own face. This will make six fields appear under the face - button. The `Fg' and `Bg' fields are the foreground and background - colors for the face, respectively. You should type the name of the - color in the field. You can use any X11 color name. A list of X11 - color names may be available in the file `/usr/lib/X11/rgb.txt' on - your system. The special color name `default' means that the face - will not change the color of the text. The `Stipple' field is weird, - so just ignore it. The three remaining fields are toggles, which will - make the text `bold', `italic', or `underline' respectively. For some - fonts `bold' or `italic' will not make any visible change.")) - (face (type . choice) - (eval . custom-face-eval) - (import . custom-face-import) - (data ((tag . "None") - (default . nil) - (type . const)) - ((tag . "Default") - (default . default) - (face . custom-const-face) - (type . const)) - ((tag . "Bold") - (default . bold) - (face . custom-const-face) - (type . const)) - ((tag . "Bold-italic") - (default . bold-italic) - (face . custom-const-face) - (type . const)) - ((tag . "Italic") - (default . italic) - (face . custom-const-face) - (type . const)) - ((tag . "Underline") - (default . underline) - (face . custom-const-face) - (type . const)) - ((tag . "Highlight") - (default . highlight) - (face . custom-const-face) - (type . const)) - ((tag . "Modeline") - (default . modeline) - (face . custom-const-face) - (type . const)) - ((tag . "Region") - (default . region) - (face . custom-const-face) - (type . const)) - ((tag . "Secondary Selection") - (default . secondary-selection) - (face . custom-const-face) - (type . const)) - ((tag . "Customized") - (compact . t) - (face-tag . custom-face-hack) - (eval . custom-face-eval) - (data ((hidden . t) - (tag . "") - (doc . "\ - Select the properties you want this face to have.") - (default . custom-face-lookup) - (type . const)) - "\n" - ((tag . "Fg") - (hidden . t) - (default . "default") - (width . 20) - (type . string)) - ((tag . "Bg") - (default . "default") - (width . 20) - (type . string)) - ((tag . "Stipple") - (default . "default") - (width . 20) - (type . string)) - "\n" - ((tag . "Bold") - (default . custom:asis) - (type . triggle)) - " " - ((tag . "Italic") - (default . custom:asis) - (type . triggle)) - " " - ((tag . "Underline") - (hidden . t) - (default . custom:asis) - (type . triggle))) - (default . (custom-face-lookup "default" "default" "default" - nil nil nil)) - (type . list)) - ((prompt . "Other") - (face . custom-field-value) - (default . __uninitialized__) - (type . symbol)))) - (file (type . string) - ;; A string containing a file or directory name. - (directory . nil) - (default-file . nil) - (query . custom-file-query)) - (sexp (type . default) - ;; Any lisp expression. - (width . 40) - (default . (__uninitialized__ . "Uninitialized")) - (read . custom-sexp-read) - (write . custom-sexp-write)) - (symbol (type . sexp) - ;; A lisp symbol. - (width . 40) - (valid . (lambda (c d) (symbolp d)))) - (integer (type . sexp) - ;; A lisp integer. - (width . 10) - (valid . (lambda (c d) (integerp d)))) - (string (type . default) - ;; A lisp string. - (width . 40) - (valid . (lambda (c d) (stringp d))) - (read . custom-string-read) - (write . custom-string-write)) - (button (type . default) - ;; Push me. - (accept . ignore) - (extract . nil) - (validate . ignore) - (insert . custom-button-insert)) - (doc (type . default) - ;; A documentation only entry with no value. - (header . nil) - (reset . ignore) - (extract . nil) - (validate . ignore) - (insert . custom-documentation-insert)) - (default (width . 20) - (valid . (lambda (c v) t)) - (insert . custom-default-insert) - (update . custom-default-update) - (query . custom-default-query) - (tag . nil) - (prompt . nil) - (doc . nil) - (header . t) - (padding . ? ) - (quote . custom-default-quote) - (eval . (lambda (c v) nil)) - (export . custom-default-export) - (import . (lambda (c v) (list v))) - (synchronize . ignore) - (initialize . custom-default-initialize) - (extract . custom-default-extract) - (validate . custom-default-validate) - (apply . custom-default-apply) - (reset . custom-default-reset) - (factory-reset . custom-default-factory-reset) - (accept . custom-default-accept) - (match . custom-default-match) - (name . nil) - (compact . nil) - (hidden . nil) - (face . custom-default-face) - (data . nil) - (calculate . nil) - (default . __uninitialized__))) - "Alist of default properties for type symbols. - The format is `((SYMBOL (PROPERTY . VALUE)... )... )'.") - - (defconst custom-local-type-properties nil - "Local type properties. - Entries in this list take precedence over `custom-type-properties'.") - - (make-variable-buffer-local 'custom-local-type-properties) - - (defconst custom-nil '__uninitialized__ - "Special value representing an uninitialized field.") - - (defconst custom-invalid '__invalid__ - "Special value representing an invalid field.") - - (defconst custom:asis 'custom:asis) - ;; Bad, ugly, and horrible kludge. - - (defun custom-property (custom property) - "Extract from CUSTOM property PROPERTY." - (let ((entry (assq property custom))) - (while (null entry) - ;; Look in superclass. - (let ((type (custom-type custom))) - (setq custom (cdr (or (assq type custom-local-type-properties) - (assq type custom-type-properties))) - entry (assq property custom)) - (custom-assert 'custom))) - (cdr entry))) - - (defun custom-super (custom property) - "Extract from CUSTOM property PROPERTY. Start with CUSTOM's superclass." - (let ((entry nil)) - (while (null entry) - ;; Look in superclass. - (let ((type (custom-type custom))) - (setq custom (cdr (or (assq type custom-local-type-properties) - (assq type custom-type-properties))) - entry (assq property custom)) - (custom-assert 'custom))) - (cdr entry))) - - (defun custom-property-set (custom property value) - "Set CUSTOM PROPERTY to VALUE by side effect. - CUSTOM must have at least one property already." - (let ((entry (assq property custom))) - (if entry - (setcdr entry value) - (setcdr custom (cons (cons property value) (cdr custom)))))) - - (defun custom-type (custom) - "Extract `type' from CUSTOM." - (cdr (assq 'type custom))) - - (defun custom-name (custom) - "Extract `name' from CUSTOM." - (custom-property custom 'name)) - - (defun custom-tag (custom) - "Extract `tag' from CUSTOM." - (custom-property custom 'tag)) - - (defun custom-face-tag (custom) - "Extract `face-tag' from CUSTOM." - (custom-property custom 'face-tag)) - - (defun custom-prompt (custom) - "Extract `prompt' from CUSTOM. - If none exist, default to `tag' or, failing that, `type'." - (or (custom-property custom 'prompt) - (custom-property custom 'tag) - (capitalize (symbol-name (custom-type custom))))) - - (defun custom-default (custom) - "Extract `default' from CUSTOM." - (let ((value (custom-property custom 'calculate))) - (if value - (eval value) - (custom-property custom 'default)))) - - (defun custom-data (custom) - "Extract the `data' from CUSTOM." - (custom-property custom 'data)) - - (defun custom-documentation (custom) - "Extract `doc' from CUSTOM." - (custom-property custom 'doc)) - - (defun custom-width (custom) - "Extract `width' from CUSTOM." - (custom-property custom 'width)) - - (defun custom-compact (custom) - "Extract `compact' from CUSTOM." - (custom-property custom 'compact)) - - (defun custom-padding (custom) - "Extract `padding' from CUSTOM." - (custom-property custom 'padding)) - - (defun custom-valid (custom value) - "Non-nil if CUSTOM may validly be set to VALUE." - (and (not (and (listp value) (eq custom-invalid (car value)))) - (funcall (custom-property custom 'valid) custom value))) - - (defun custom-import (custom value) - "Import CUSTOM VALUE from external variable. - - This function change VALUE into a form that makes it easier to edit - internally. What the internal form is exactly depends on CUSTOM. - The internal form is returned." - (if (eq custom-nil value) - (list custom-nil) - (funcall (custom-property custom 'import) custom value))) - - (defun custom-eval (custom value) - "Return non-nil if CUSTOM's VALUE needs to be evaluated." - (funcall (custom-property custom 'eval) custom value)) - - (defun custom-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (funcall (custom-property custom 'quote) custom value)) - - (defun custom-write (custom value) - "Convert CUSTOM VALUE to a string." - (cond ((eq value custom-nil) - "") - ((and (listp value) (eq (car value) custom-invalid)) - (cdr value)) - (t - (funcall (custom-property custom 'write) custom value)))) - - (defun custom-read (custom string) - "Convert CUSTOM field content STRING into lisp." - (condition-case nil - (funcall (custom-property custom 'read) custom string) - (error (cons custom-invalid string)))) - - (defun custom-match (custom values) - "Match CUSTOM with a list of VALUES. - - Return a cons-cell where the car is the sublist of VALUES matching CUSTOM, - and the cdr is the remaining VALUES. - - A CUSTOM is actually a regular expression over the alphabet of lisp - types. Most CUSTOM types are just doing a literal match, e.g. the - `symbol' type matches any lisp symbol. The exceptions are: - - group: which corresponds to a `(' and `)' group in a regular expression. - choice: which corresponds to a group of `|' in a regular expression. - repeat: which corresponds to a `*' in a regular expression. - optional: which corresponds to a `?', and isn't implemented yet." - (if (memq values (list custom-nil nil)) - ;; Nothing matches the uninitialized or empty list. - (cons custom-nil nil) - (funcall (custom-property custom 'match) custom values))) - - (defun custom-initialize (custom) - "Initialize `doc' and `default' attributes of CUSTOM." - (funcall (custom-property custom 'initialize) custom)) - - (defun custom-find (custom tag) - "Find child in CUSTOM with `tag' TAG." - (funcall (custom-property custom 'find) custom tag)) - - (defun custom-travel-path (custom path) - "Find descendent of CUSTOM by looking through PATH." - (if (null path) - custom - (custom-travel-path (custom-find custom (car path)) (cdr path)))) - - (defun custom-field-extract (custom field) - "Extract CUSTOM's value in FIELD." - (if (stringp custom) - nil - (funcall (custom-property (custom-field-custom field) 'extract) - custom field))) - - (defun custom-field-validate (custom field) - "Validate CUSTOM's value in FIELD. - Return nil if valid, otherwise return a cons-cell where the car is the - position of the error, and the cdr is a text describing the error." - (if (stringp custom) - nil - (funcall (custom-property custom 'validate) custom field))) - - ;;; Field Functions: - ;; - ;; This section defines the public functions for manipulating the - ;; FIELD datatype. The FIELD instance hold information about a - ;; specific editing field in the customization buffer. - ;; - ;; Each FIELD can be seen as an instantiation of a CUSTOM. - - (defvar custom-field-last nil) - ;; Last field containing point. - (make-variable-buffer-local 'custom-field-last) - - (defvar custom-modified-list nil) - ;; List of modified fields. - (make-variable-buffer-local 'custom-modified-list) - - (defun custom-field-create (custom value) - "Create a field structure of type CUSTOM containing VALUE. - - A field structure is an array [ CUSTOM VALUE ORIGINAL START END ], where - CUSTOM defines the type of the field, - VALUE is the current value of the field, - ORIGINAL is the original value when created, and - START and END are markers to the start and end of the field." - (vector custom value custom-nil nil nil)) - - (defun custom-field-custom (field) - "Return the `custom' attribute of FIELD." - (aref field 0)) - - (defun custom-field-value (field) - "Return the `value' attribute of FIELD." - (aref field 1)) - - (defun custom-field-original (field) - "Return the `original' attribute of FIELD." - (aref field 2)) - - (defun custom-field-start (field) - "Return the `start' attribute of FIELD." - (aref field 3)) - - (defun custom-field-end (field) - "Return the `end' attribute of FIELD." - (aref field 4)) - - (defun custom-field-value-set (field value) - "Set the `value' attribute of FIELD to VALUE." - (aset field 1 value)) - - (defun custom-field-original-set (field original) - "Set the `original' attribute of FIELD to ORIGINAL." - (aset field 2 original)) - - (defun custom-field-move (field start end) - "Set the `start'and `end' attributes of FIELD to START and END." - (set-marker (or (aref field 3) (aset field 3 (make-marker))) start) - (set-marker (or (aref field 4) (aset field 4 (make-marker))) end)) - - (defun custom-field-query (field) - "Query user for content of current field." - (funcall (custom-property (custom-field-custom field) 'query) field)) - - (defun custom-field-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE. - If optional ORIGINAL is non-nil, consider VALUE for the original value." - (let ((inhibit-point-motion-hooks t)) - (funcall (custom-property (custom-field-custom field) 'accept) - field value original))) - - (defun custom-field-face (field) - "The face used for highlighting FIELD." - (let ((custom (custom-field-custom field))) - (if (stringp custom) - nil - (let ((face (funcall (custom-property custom 'face) field))) - (if (custom-facep face) face nil))))) - - (defun custom-field-update (field) - "Update the screen appearance of FIELD to correspond with the field's value." - (let ((custom (custom-field-custom field))) - (if (stringp custom) - nil - (funcall (custom-property custom 'update) field)))) - - ;;; Types: - ;; - ;; The following functions defines type specific actions. - - (defun custom-repeat-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (if (eq value custom-nil) - nil - (let ((child (custom-data custom)) - (found nil)) - (mapcar (lambda (v) (if (custom-eval child v) (setq found t))) - value)))) - - (defun custom-repeat-quote (custom value) - "A list of CUSTOM's VALUEs quoted." - (let ((child (custom-data custom))) - (apply 'append (mapcar (lambda (v) (custom-quote child v)) - value)))) - - - (defun custom-repeat-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((child (custom-data custom))) - (apply 'append (mapcar (lambda (v) (custom-import child v)) - value)))) - - (defun custom-repeat-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let ((values (copy-sequence (custom-field-value field))) - (all (custom-field-value field)) - (start (custom-field-start field)) - current new) - (if original - (custom-field-original-set field value)) - (while (consp value) - (setq new (car value) - value (cdr value)) - (if values - ;; Change existing field. - (setq current (car values) - values (cdr values)) - ;; Insert new field if series has grown. - (goto-char start) - (setq current (custom-repeat-insert-entry field)) - (setq all (custom-insert-before all nil current)) - (custom-field-value-set field all)) - (custom-field-accept current new original)) - (while (consp values) - ;; Delete old field if series has scrunk. - (setq current (car values) - values (cdr values)) - (let ((pos (custom-field-start current)) - data) - (while (not data) - (setq pos (previous-single-property-change pos 'custom-data)) - (custom-assert 'pos) - (setq data (get-text-property pos 'custom-data)) - (or (and (arrayp data) - (> (length data) 1) - (eq current (aref data 1))) - (setq data nil))) - (custom-repeat-delete data))))) - - (defun custom-repeat-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - (add-tag (custom-property custom 'add-tag)) - (start (make-marker)) - (data (vector field nil start nil))) - (custom-text-insert "\n") - (let ((pos (point))) - (custom-text-insert (custom-property custom 'prefix)) - (custom-tag-insert add-tag 'custom-repeat-add data) - (set-marker start pos)) - (custom-field-move field start (point)) - (custom-documentation-insert custom) - field)) - - (defun custom-repeat-insert-entry (repeat) - "Insert entry at point in the REPEAT field." - (let* ((inhibit-point-motion-hooks t) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - (custom (custom-field-custom repeat)) - (add-tag (custom-property custom 'add-tag)) - (del-tag (custom-property custom 'del-tag)) - (start (make-marker)) - (end (make-marker)) - (data (vector repeat nil start end)) - field) - (custom-extent-start-open) - (insert-before-markers "\n") - (backward-char 1) - (set-marker start (point)) - (custom-text-insert " ") - (aset data 1 (setq field (custom-insert (custom-data custom) nil))) - (custom-text-insert " ") - (set-marker end (point)) - (goto-char start) - (custom-text-insert (custom-property custom 'prefix)) - (custom-tag-insert add-tag 'custom-repeat-add data) - (custom-text-insert " ") - (custom-tag-insert del-tag 'custom-repeat-delete data) - (forward-char 1) - field)) - - (defun custom-repeat-add (data) - "Add list entry." - (let ((parent (aref data 0)) - (field (aref data 1)) - (at (aref data 2)) - new) - (goto-char at) - (setq new (custom-repeat-insert-entry parent)) - (custom-field-value-set parent - (custom-insert-before (custom-field-value parent) - field new)))) - - (defun custom-repeat-delete (data) - "Delete list entry." - (let ((inhibit-point-motion-hooks t) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - (parent (aref data 0)) - (field (aref data 1))) - (delete-region (aref data 2) (1+ (aref data 3))) - (custom-field-untouch (aref data 1)) - (custom-field-value-set parent - (delq field (custom-field-value parent))))) - - (defun custom-repeat-match (custom values) - "Match CUSTOM with VALUES." - (let* ((child (custom-data custom)) - (match (custom-match child values)) - matches) - (while (not (eq (car match) custom-nil)) - (setq matches (cons (car match) matches) - values (cdr match) - match (custom-match child values))) - (cons (nreverse matches) values))) - - (defun custom-repeat-extract (custom field) - "Extract list of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - () - (while values - (setq result (append result (custom-field-extract data (car values))) - values (cdr values)))) - result)) - - (defun custom-repeat-validate (custom field) - "Validate children." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - (setq result (cons (custom-field-start field) "Uninitialized list"))) - (while (and values (not result)) - (setq result (custom-field-validate data (car values)) - values (cdr values))) - result)) - - (defun custom-pair-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (custom-group-accept field (list (car value) (cdr value)) original)) - - (defun custom-pair-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (custom-group-eval custom (list (car value) (cdr value)))) - - (defun custom-pair-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((result (car (custom-group-import custom - (list (car value) (cdr value)))))) - (custom-assert '(eq (length result) 2)) - (list (cons (nth 0 result) (nth 1 result))))) - - (defun custom-pair-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (if (custom-eval custom value) - (let ((v (car (custom-group-quote custom - (list (car value) (cdr value)))))) - (list (list 'cons (nth 0 v) (nth 1 v)))) - (custom-default-quote custom value))) - - (defun custom-pair-extract (custom field) - "Extract cons of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (custom-assert '(eq (length values) (length data))) - (while values - (setq result (append result - (custom-field-extract (car data) (car values))) - data (cdr data) - values (cdr values))) - (custom-assert '(null data)) - (list (cons (nth 0 result) (nth 1 result))))) - - (defun custom-list-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (if (custom-eval custom value) - (let ((v (car (custom-group-quote custom value)))) - (list (cons 'list v))) - (custom-default-quote custom value))) - - (defun custom-list-extract (custom field) - "Extract list of children's values." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (custom-assert '(eq (length values) (length data))) - (while values - (setq result (append result - (custom-field-extract (car data) (car values))) - data (cdr data) - values (cdr values))) - (custom-assert '(null data)) - (list result))) - - (defun custom-group-validate (custom field) - "Validate children." - (let ((values (custom-field-value field)) - (data (custom-data custom)) - result) - (if (eq values custom-nil) - (setq result (cons (custom-field-start field) "Uninitialized list")) - (custom-assert '(eq (length values) (length data)))) - (while (and values (not result)) - (setq result (custom-field-validate (car data) (car values)) - data (cdr data) - values (cdr values))) - result)) - - (defun custom-group-eval (custom value) - "Non-nil if CUSTOM's VALUE needs to be evaluated." - (let ((found nil)) - (mapcar (lambda (c) - (or (stringp c) - (let ((match (custom-match c value))) - (if (custom-eval c (car match)) - (setq found t)) - (setq value (cdr match))))) - (custom-data custom)) - found)) - - (defun custom-group-quote (custom value) - "A list of CUSTOM's VALUE members, quoted." - (list (apply 'append - (mapcar (lambda (c) - (if (stringp c) - () - (let ((match (custom-match c value))) - (prog1 (custom-quote c (car match)) - (setq value (cdr match)))))) - (custom-data custom))))) - - (defun custom-group-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (list (apply 'append - (mapcar (lambda (c) - (if (stringp c) - () - (let ((match (custom-match c value))) - (prog1 (custom-import c (car match)) - (setq value (cdr match)))))) - (custom-data custom))))) - - (defun custom-group-initialize (custom) - "Initialize `doc' and `default' entries in CUSTOM." - (if (custom-name custom) - (custom-default-initialize custom) - (mapcar 'custom-initialize (custom-data custom)))) - - (defun custom-group-apply (field) - "Reset `value' in FIELD to `original'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-apply field) - (mapcar 'custom-field-apply values)))) - - (defun custom-group-reset (field) - "Reset `value' in FIELD to `original'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-reset field) - (mapcar 'custom-field-reset values)))) - - (defun custom-group-factory-reset (field) - "Reset `value' in FIELD to `default'." - (let ((custom (custom-field-custom field)) - (values (custom-field-value field))) - (if (custom-name custom) - (custom-default-factory-reset field) - (mapcar 'custom-field-factory-reset values)))) - - (defun custom-group-find (custom tag) - "Find child in CUSTOM with `tag' TAG." - (let ((data (custom-data custom)) - (result nil)) - (while (not result) - (custom-assert 'data) - (if (equal (custom-tag (car data)) tag) - (setq result (car data)) - (setq data (cdr data)))))) - - (defun custom-group-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let* ((values (custom-field-value field)) - (custom (custom-field-custom field)) - (from (custom-field-start field)) - (face-tag (custom-face-tag custom)) - current) - (if face-tag - (custom-put-text-property from (+ from (length (custom-tag custom))) - 'face (funcall face-tag field value))) - (if original - (custom-field-original-set field value)) - (while values - (setq current (car values) - values (cdr values)) - (if current - (let* ((custom (custom-field-custom current)) - (match (custom-match custom value))) - (setq value (cdr match)) - (custom-field-accept current (car match) original)))))) - - (defun custom-group-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - fields hidden - (from (point)) - (compact (custom-compact custom)) - (tag (custom-tag custom)) - (face-tag (custom-face-tag custom))) - (cond (face-tag (custom-text-insert tag)) - (tag (custom-tag-insert tag field))) - (or compact (custom-documentation-insert custom)) - (or compact (custom-text-insert "\n")) - (let ((data (custom-data custom))) - (while data - (setq fields (cons (custom-insert (car data) (if level (1+ level))) - fields)) - (setq hidden (or (stringp (car data)) - (custom-property (car data) 'hidden))) - (setq data (cdr data)) - (if data (custom-text-insert (cond (hidden "") - (compact " ") - (t "\n")))))) - (if compact (custom-documentation-insert custom)) - (custom-field-value-set field (nreverse fields)) - (custom-field-move field from (point)) - field)) - - (defun custom-choice-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom nil)) - (from (point))) - (custom-text-insert "lars er en nisse") - (custom-field-move field from (point)) - (custom-documentation-insert custom) - (custom-field-reset field) - field)) - - (defun custom-choice-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (let ((custom (custom-field-custom field)) - (start (custom-field-start field)) - (end (custom-field-end field)) - (inhibit-read-only t) - (before-change-functions nil) - (after-change-functions nil) - from) - (cond (original - (setq custom-modified-list (delq field custom-modified-list)) - (custom-field-original-set field value)) - ((equal value (custom-field-original field)) - (setq custom-modified-list (delq field custom-modified-list))) - (t - (add-to-list 'custom-modified-list field))) - (custom-field-untouch (custom-field-value field)) - (delete-region start end) - (goto-char start) - (setq from (point)) - (insert-before-markers " ") - (backward-char 1) - (custom-category-set (point) (1+ (point)) 'custom-hidden-properties) - (custom-tag-insert (custom-tag custom) field) - (custom-text-insert ": ") - (let ((data (custom-data custom)) - found begin) - (while (and data (not found)) - (if (not (custom-valid (car data) value)) - (setq data (cdr data)) - (setq found (custom-insert (car data) nil)) - (setq data nil))) - (if found - () - (setq begin (point) - found (custom-insert (custom-property custom 'none) nil)) - (custom-add-text-properties - begin (point) - (list rear-nonsticky t - 'face custom-field-uninitialized-face))) - (or original - (custom-field-original-set found (custom-field-original field))) - (custom-field-accept found value original) - (custom-field-value-set field found) - (custom-field-move field from end)))) - - (defun custom-choice-extract (custom field) - "Extract child's value." - (let ((value (custom-field-value field))) - (custom-field-extract (custom-field-custom value) value))) - - (defun custom-choice-validate (custom field) - "Validate child's value." - (let ((value (custom-field-value field)) - (custom (custom-field-custom field))) - (if (or (eq value custom-nil) - (eq (custom-field-custom value) (custom-property custom 'none))) - (cons (custom-field-start field) "Make a choice") - (custom-field-validate (custom-field-custom value) value)))) - - (defun custom-choice-query (field) - "Choose a child." - (let* ((custom (custom-field-custom field)) - (old (custom-field-custom (custom-field-value field))) - (default (custom-prompt old)) - (tag (custom-prompt custom)) - (data (custom-data custom)) - current alist) - (if (eq (length data) 2) - (custom-field-accept field (custom-default (if (eq (nth 0 data) old) - (nth 1 data) - (nth 0 data)))) - (while data - (setq current (car data) - data (cdr data)) - (setq alist (cons (cons (custom-prompt current) current) alist))) - (let ((answer (cond ((and (fboundp 'button-press-event-p) - (fboundp 'popup-menu) - (button-press-event-p last-input-event)) - (cdr (assoc (car (custom-x-really-popup-menu - last-input-event tag - (reverse alist))) - alist))) - ((listp last-input-event) - (x-popup-menu last-input-event - (list tag (cons "" (reverse alist))))) - (t - (let ((choice (completing-read (concat tag - " (default " - default - "): ") - alist nil t))) - (if (or (null choice) (string-equal choice "")) - (setq choice default)) - (cdr (assoc choice alist))))))) - (if answer - (custom-field-accept field (custom-default answer))))))) - - (defun custom-file-query (field) - "Prompt for a file name" - (let* ((value (custom-field-value field)) - (custom (custom-field-custom field)) - (valid (custom-valid custom value)) - (directory (custom-property custom 'directory)) - (default (and (not valid) - (custom-property custom 'default-file))) - (tag (custom-tag custom)) - (prompt (if default - (concat tag " (" default "): ") - (concat tag ": ")))) - (custom-field-accept field - (if (custom-valid custom value) - (read-file-name prompt - (if (file-name-absolute-p value) - "" - directory) - default nil value) - (read-file-name prompt directory default))))) - - (defun custom-face-eval (custom value) - "Return non-nil if CUSTOM's VALUE needs to be evaluated." - (not (symbolp value))) - - (defun custom-face-import (custom value) - "Modify CUSTOM's VALUE to match internal expectations." - (let ((name (or (and (facep value) (symbol-name (face-name value))) - (symbol-name value)))) - (list (if (string-match "\ - custom-face-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)-\\(.*\\)" - name) - (list 'custom-face-lookup - (match-string 1 name) - (match-string 2 name) - (match-string 3 name) - (intern (match-string 4 name)) - (intern (match-string 5 name)) - (intern (match-string 6 name))) - value)))) - - (defun custom-face-lookup (&optional fg bg stipple bold italic underline) - "Lookup or create a face with specified attributes." - (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" - (or fg "default") - (or bg "default") - (or stipple "default") - bold italic underline)))) - (if (and (custom-facep name) - (fboundp 'make-face)) - () - (copy-face 'default name) - (when (and fg - (not (string-equal fg "default"))) - (condition-case () - (set-face-foreground name fg) - (error nil))) - (when (and bg - (not (string-equal bg "default"))) - (condition-case () - (set-face-background name bg) - (error nil))) - (when (and stipple - (not (string-equal stipple "default")) - (not (eq stipple 'custom:asis)) - (fboundp 'set-face-stipple)) - (set-face-stipple name stipple)) - (when (and bold - (not (eq bold 'custom:asis))) - (condition-case () - (make-face-bold name) - (error nil))) - (when (and italic - (not (eq italic 'custom:asis))) - (condition-case () - (make-face-italic name) - (error nil))) - (when (and underline - (not (eq underline 'custom:asis))) - (condition-case () - (set-face-underline-p name t) - (error nil)))) - name)) - - (defun custom-face-hack (field value) - "Face that should be used for highlighting FIELD containing VALUE." - (let* ((custom (custom-field-custom field)) - (form (funcall (custom-property custom 'export) custom value)) - (face (apply (car form) (cdr form)))) - (if (custom-facep face) face nil))) - - (defun custom-const-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let* ((field (custom-field-create custom custom-nil)) - (face (custom-field-face field)) - (from (point))) - (custom-text-insert (custom-tag custom)) - (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))) - (custom-put-text-property from (+ from (length (custom-tag custom))) - 'face (custom-field-face field)))) - - (defun custom-const-valid (custom value) - "Non-nil if CUSTOM can validly have the value VALUE." - (equal (custom-default custom) value)) - - (defun custom-const-face (field) - "Face used for a FIELD." - (custom-default (custom-field-custom field))) - - (defun custom-sexp-read (custom string) - "Read from CUSTOM an STRING." - (save-match-data - (save-excursion - (set-buffer (get-buffer-create " *Custom Scratch*")) - (erase-buffer) - (insert string) - (goto-char (point-min)) - (prog1 (read (current-buffer)) - (or (looking-at - (concat (regexp-quote (char-to-string - (custom-padding custom))) - "*\\'")) - (error "Junk at end of expression")))))) - - (autoload 'pp-to-string "pp") - - (defun custom-sexp-write (custom sexp) - "Write CUSTOM SEXP as string." - (let ((string (prin1-to-string sexp))) - (if (<= (length string) (custom-width custom)) - string - (setq string (pp-to-string sexp)) - (string-match "[ \t\n]*\\'" string) - (concat "\n" (substring string 0 (match-beginning 0)))))) - - (defun custom-string-read (custom string) - "Read string by ignoring trailing padding characters." - (let ((last (length string)) - (padding (custom-padding custom))) - (while (and (> last 0) - (eq (aref string (1- last)) padding)) - (setq last (1- last))) - (substring string 0 last))) - - (defun custom-string-write (custom string) - "Write raw string." - string) - - (defun custom-button-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (custom-tag-insert (concat "[" (custom-tag custom) "]") - (custom-property custom 'query)) - (custom-documentation-insert custom) - nil) - - (defun custom-default-export (custom value) - ;; Convert CUSTOM's VALUE to external representation. - ;; See `custom-import'. - (if (custom-eval custom value) - (eval (car (custom-quote custom value))) - value)) - - (defun custom-default-quote (custom value) - "Quote CUSTOM's VALUE if necessary." - (list (if (and (not (custom-eval custom value)) - (or (and (symbolp value) - value - (not (eq t value))) - (and (listp value) - value - (not (memq (car value) '(quote function lambda)))))) - (list 'quote value) - value))) - - (defun custom-default-initialize (custom) - "Initialize `doc' and `default' entries in CUSTOM." - (let ((name (custom-name custom))) - (if (null name) - () - (let ((default (custom-default custom)) - (doc (custom-documentation custom)) - (vdoc (documentation-property name 'variable-documentation t))) - (if doc - (or vdoc (put name 'variable-documentation doc)) - (if vdoc (custom-property-set custom 'doc vdoc))) - (if (eq default custom-nil) - (if (boundp name) - (custom-property-set custom 'default (symbol-value name))) - (or (boundp name) - (set name default))))))) - - (defun custom-default-insert (custom level) - "Insert field for CUSTOM at nesting LEVEL in customization buffer." - (let ((field (custom-field-create custom custom-nil)) - (tag (custom-tag custom))) - (if (null tag) - () - (custom-tag-insert tag field) - (custom-text-insert ": ")) - (custom-field-insert field) - (custom-documentation-insert custom) - field)) - - (defun custom-default-accept (field value &optional original) - "Store a new value into field FIELD, taking it from VALUE." - (if original - (custom-field-original-set field value)) - (custom-field-value-set field value) - (custom-field-update field)) - - (defun custom-default-apply (field) - "Apply any changes in FIELD since the last apply." - (let* ((custom (custom-field-custom field)) - (name (custom-name custom))) - (if (null name) - (error "This field cannot be applied alone")) - (custom-external-set name (custom-name-value name)) - (custom-field-reset field))) - - (defun custom-default-reset (field) - "Reset content of editing FIELD to `original'." - (custom-field-accept field (custom-field-original field) t)) - - (defun custom-default-factory-reset (field) - "Reset content of editing FIELD to `default'." - (let* ((custom (custom-field-custom field)) - (default (car (custom-import custom (custom-default custom))))) - (or (eq default custom-nil) - (custom-field-accept field default nil)))) - - (defun custom-default-query (field) - "Prompt for a FIELD" - (let* ((custom (custom-field-custom field)) - (value (custom-field-value field)) - (initial (custom-write custom value)) - (prompt (concat (custom-prompt custom) ": "))) - (custom-field-accept field - (custom-read custom - (if (custom-valid custom value) - (read-string prompt (cons initial 1)) - (read-string prompt)))))) - - (defun custom-default-match (custom values) - "Match CUSTOM with VALUES." - values) - - (defun custom-default-extract (custom field) - "Extract CUSTOM's content in FIELD." - (list (custom-field-value field))) - - (defun custom-default-validate (custom field) - "Validate FIELD." - (let ((value (custom-field-value field)) - (start (custom-field-start field))) - (cond ((eq value custom-nil) - (cons start "Uninitialized field")) - ((and (consp value) (eq (car value) custom-invalid)) - (cons start "Unparsable field content")) - ((custom-valid custom value) - nil) - (t - (cons start "Wrong type of field content"))))) - - (defun custom-default-face (field) - "Face used for a FIELD." - (let ((value (custom-field-value field))) - (cond ((eq value custom-nil) - custom-field-uninitialized-face) - ((not (custom-valid (custom-field-custom field) value)) - custom-field-invalid-face) - ((not (equal (custom-field-original field) value)) - custom-field-modified-face) - (t - custom-field-face)))) - - (defun custom-default-update (field) - "Update the content of FIELD." - (let ((inhibit-point-motion-hooks t) - (before-change-functions nil) - (after-change-functions nil) - (start (custom-field-start field)) - (end (custom-field-end field)) - (pos (point))) - ;; Keep track of how many modified fields we have. - (cond ((equal (custom-field-value field) (custom-field-original field)) - (setq custom-modified-list (delq field custom-modified-list))) - ((memq field custom-modified-list)) - (t - (setq custom-modified-list (cons field custom-modified-list)))) - ;; Update the field. - (goto-char end) - (insert-before-markers " ") - (delete-region start (1- end)) - (goto-char start) - (custom-field-insert field) - (goto-char end) - (delete-char 1) - (goto-char pos) - (and (<= start pos) - (<= pos end) - (custom-field-enter field)))) - - ;;; Create Buffer: - ;; - ;; Public functions to create a customization buffer and to insert - ;; various forms of text, fields, and buttons in it. - - (defun customize () - "Customize GNU Emacs. - Create a *Customize* buffer with editable customization information - about GNU Emacs." - (interactive) - (custom-buffer-create "*Customize*") - (custom-reset-all)) - - (defun custom-buffer-create (name &optional custom types set get save) - "Create a customization buffer named NAME. - If the optional argument CUSTOM is non-nil, use that as the custom declaration. - If the optional argument TYPES is non-nil, use that as the local types. - If the optional argument SET is non-nil, use that to set external data. - If the optional argument GET is non-nil, use that to get external data. - If the optional argument SAVE is non-nil, use that for saving changes." - (switch-to-buffer name) - (buffer-disable-undo (current-buffer)) - (custom-mode) - (setq custom-local-type-properties types) - (if (null custom) - () - (make-local-variable 'custom-data) - (setq custom-data custom)) - (if (null set) - () - (make-local-variable 'custom-external-set) - (setq custom-external-set set)) - (if (null get) - () - (make-local-variable 'custom-external) - (setq custom-external get)) - (if (null save) - () - (make-local-variable 'custom-save) - (setq custom-save save)) - (let ((inhibit-point-motion-hooks t) - (before-change-functions nil) - (after-change-functions nil)) - (erase-buffer) - (insert "\n") - (goto-char (point-min)) - (custom-text-insert "This is a customization buffer.\n") - (custom-help-insert "\n") - (custom-help-button 'custom-forward-field) - (custom-help-button 'custom-backward-field) - (custom-help-button 'custom-enter-value) - (custom-help-button 'custom-field-factory-reset) - (custom-help-button 'custom-field-reset) - (custom-help-button 'custom-field-apply) - (custom-help-button 'custom-save-and-exit) - (custom-help-button 'custom-toggle-documentation) - (custom-help-insert "\nClick mouse-2 on any button to activate it.\n") - (custom-text-insert "\n") - (custom-insert custom-data 0) - (goto-char (point-min)))) - - (defun custom-insert (custom level) - "Insert custom declaration CUSTOM in current buffer at level LEVEL." - (if (stringp custom) - (progn - (custom-text-insert custom) - nil) - (and level (null (custom-property custom 'header)) - (setq level nil)) - (and level - (> level 0) - (custom-text-insert (concat "\n" (make-string level ?*) " "))) - (let ((field (funcall (custom-property custom 'insert) custom level))) - (custom-name-enter (custom-name custom) field) - field))) - - (defun custom-text-insert (text) - "Insert TEXT in current buffer." - (insert text)) - - (defun custom-tag-insert (tag field &optional data) - "Insert TAG for FIELD in current buffer." - (let ((from (point))) - (insert tag) - (custom-category-set from (point) 'custom-button-properties) - (custom-put-text-property from (point) 'custom-tag field) - (if data - (custom-add-text-properties from (point) (list 'custom-data data))))) - - (defun custom-documentation-insert (custom &rest ignore) - "Insert documentation from CUSTOM in current buffer." - (let ((doc (custom-documentation custom))) - (if (null doc) - () - (custom-help-insert "\n" doc)))) - - (defun custom-help-insert (&rest args) - "Insert ARGS as documentation text." - (let ((from (point))) - (apply 'insert args) - (custom-category-set from (point) 'custom-documentation-properties))) - - (defun custom-help-button (command) - "Describe how to execute COMMAND." - (let ((from (point))) - (insert "`" (key-description (where-is-internal command nil t)) "'") - (custom-set-text-properties from (point) - (list 'face custom-button-face - mouse-face custom-mouse-face - 'custom-jump t ;Make TAB jump over it. - 'custom-tag command - 'start-open t - 'end-open t)) - (custom-category-set from (point) 'custom-documentation-properties)) - (custom-help-insert ": " (custom-first-line (documentation command)) "\n")) - - ;;; Mode: - ;; - ;; The Customization major mode and interactive commands. - - (defvar custom-mode-map nil - "Keymap for Custom Mode.") - (if custom-mode-map - nil - (setq custom-mode-map (make-sparse-keymap)) - (define-key custom-mode-map (if (string-match "XEmacs" emacs-version) [button2] [mouse-2]) 'custom-push-button) - (define-key custom-mode-map "\t" 'custom-forward-field) - (define-key custom-mode-map "\M-\t" 'custom-backward-field) - (define-key custom-mode-map "\r" 'custom-enter-value) - (define-key custom-mode-map "\C-k" 'custom-kill-line) - (define-key custom-mode-map "\C-c\C-r" 'custom-field-reset) - (define-key custom-mode-map "\C-c\M-\C-r" 'custom-reset-all) - (define-key custom-mode-map "\C-c\C-z" 'custom-field-factory-reset) - (define-key custom-mode-map "\C-c\M-\C-z" 'custom-factory-reset-all) - (define-key custom-mode-map "\C-c\C-a" 'custom-field-apply) - (define-key custom-mode-map "\C-c\M-\C-a" 'custom-apply-all) - (define-key custom-mode-map "\C-c\C-c" 'custom-save-and-exit) - (define-key custom-mode-map "\C-c\C-d" 'custom-toggle-documentation)) - - ;; C-c keymap ideas: C-a field-beginning, C-e field-end, C-f - ;; forward-field, C-b backward-field, C-n next-field, C-p - ;; previous-field, ? describe-field. - - (defun custom-mode () - "Major mode for doing customizations. - - \\{custom-mode-map}" - (kill-all-local-variables) - (setq major-mode 'custom-mode - mode-name "Custom") - (use-local-map custom-mode-map) - (make-local-variable 'before-change-functions) - (setq before-change-functions '(custom-before-change)) - (make-local-variable 'after-change-functions) - (setq after-change-functions '(custom-after-change)) - (if (not (fboundp 'make-local-hook)) - ;; Emacs 19.28 and earlier. - (add-hook 'post-command-hook - (lambda () - (if (eq major-mode 'custom-mode) - (custom-post-command)))) - ;; Emacs 19.29. - (make-local-hook 'post-command-hook) - (add-hook 'post-command-hook 'custom-post-command nil t))) - - (defun custom-forward-field (arg) - "Move point to the next field or button. - With optional ARG, move across that many fields." - (interactive "p") - (while (> arg 0) - (let ((next (if (get-text-property (point) 'custom-tag) - (next-single-property-change (point) 'custom-tag) - (point)))) - (setq next (or (next-single-property-change next 'custom-tag) - (next-single-property-change (point-min) 'custom-tag))) - (if next - (goto-char next) - (error "No customization fields in this buffer."))) - (or (get-text-property (point) 'custom-jump) - (setq arg (1- arg)))) - (while (< arg 0) - (let ((previous (if (get-text-property (1- (point)) 'custom-tag) - (previous-single-property-change (point) 'custom-tag) - (point)))) - (setq previous - (or (previous-single-property-change previous 'custom-tag) - (previous-single-property-change (point-max) 'custom-tag))) - (if previous - (goto-char previous) - (error "No customization fields in this buffer."))) - (or (get-text-property (1- (point)) 'custom-jump) - (setq arg (1+ arg))))) - - (defun custom-backward-field (arg) - "Move point to the previous field or button. - With optional ARG, move across that many fields." - (interactive "p") - (custom-forward-field (- arg))) - - (defun custom-toggle-documentation (&optional arg) - "Toggle display of documentation text. - If the optional argument is non-nil, show text iff the argument is positive." - (interactive "P") - (let ((hide (or (and (null arg) - (null (custom-category-get - 'custom-documentation-properties 'invisible))) - (<= (prefix-numeric-value arg) 0)))) - (custom-category-put 'custom-documentation-properties 'invisible hide) - (custom-category-put 'custom-documentation-properties intangible hide)) - (redraw-display)) - - (defun custom-enter-value (field data) - "Enter value for current customization field or push button." - (interactive (list (get-text-property (point) 'custom-tag) - (get-text-property (point) 'custom-data))) - (cond (data - (funcall field data)) - ((eq field 'custom-enter-value) - (error "Don't be silly")) - ((and (symbolp field) (fboundp field)) - (call-interactively field)) - (field - (custom-field-query field)) - (t - (message "Nothing to enter here")))) - - (defun custom-kill-line () - "Kill to end of field or end of line, whichever is first." - (interactive) - (let ((field (get-text-property (point) 'custom-field)) - (newline (save-excursion (search-forward "\n"))) - (next (next-single-property-change (point) 'custom-field))) - (if (and field (> newline next)) - (kill-region (point) next) - (call-interactively 'kill-line)))) - - (defun custom-push-button (event) - "Activate button below mouse pointer." - (interactive "@e") - (let* ((pos (event-point event)) - (field (get-text-property pos 'custom-field)) - (tag (get-text-property pos 'custom-tag)) - (data (get-text-property pos 'custom-data))) - (cond (data - (funcall tag data)) - ((and (symbolp tag) (fboundp tag)) - (call-interactively tag)) - (field - (call-interactively (lookup-key global-map (this-command-keys)))) - (tag - (custom-enter-value tag data)) - (t - (error "Nothing to click on here."))))) - - (defun custom-reset-all () - "Undo any changes since the last apply in all fields." - (interactive (and custom-modified-list - (not (y-or-n-p "Discard all changes? ")) - (error "Reset aborted"))) - (let ((all custom-name-fields) - current field) - (while all - (setq current (car all) - field (cdr current) - all (cdr all)) - (custom-field-reset field)))) - - (defun custom-field-reset (field) - "Undo any changes in FIELD since the last apply." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (if (arrayp field) - (let* ((custom (custom-field-custom field)) - (name (custom-name custom))) - (save-excursion - (if name - (custom-field-original-set - field (car (custom-import custom (custom-external name))))) - (if (not (custom-valid custom (custom-field-original field))) - (error "This field cannot be reset alone") - (funcall (custom-property custom 'reset) field) - (funcall (custom-property custom 'synchronize) field)))))) - - (defun custom-factory-reset-all () - "Reset all field to their default values." - (interactive (and custom-modified-list - (not (y-or-n-p "Discard all changes? ")) - (error "Reset aborted"))) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (custom-field-factory-reset field)))) - - (defun custom-field-factory-reset (field) - "Reset FIELD to its default value." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (if (arrayp field) - (save-excursion - (funcall (custom-property (custom-field-custom field) 'factory-reset) - field)))) - - (defun custom-apply-all () - "Apply any changes since the last reset in all fields." - (interactive (if custom-modified-list - nil - (error "No changes to apply."))) - (custom-field-parse custom-field-last) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (let ((error (custom-field-validate (custom-field-custom field) field))) - (if (null error) - () - (goto-char (car error)) - (error (cdr error)))))) - (let ((all custom-name-fields) - field) - (while all - (setq field (cdr (car all)) - all (cdr all)) - (custom-field-apply field)))) - - (defun custom-field-apply (field) - "Apply any changes in FIELD since the last apply." - (interactive (list (or (get-text-property (point) 'custom-field) - (get-text-property (point) 'custom-tag)))) - (custom-field-parse custom-field-last) - (if (arrayp field) - (let* ((custom (custom-field-custom field)) - (error (custom-field-validate custom field))) - (if error - (error (cdr error))) - (funcall (custom-property custom 'apply) field)))) - - (defun custom-toggle-hide (&rest ignore) - "Hide or show entry." - (interactive) - (error "This button is not yet implemented")) - - (defun custom-save-and-exit () - "Save and exit customization buffer." - (interactive "@") - (save-excursion - (funcall custom-save)) - (kill-buffer (current-buffer))) - - (defun custom-save () - "Save customization information." - (interactive) - (custom-apply-all) - (let ((new custom-name-fields)) - (set-buffer (find-file-noselect custom-file)) - (goto-char (point-min)) - (save-excursion - (let ((old (condition-case nil - (read (current-buffer)) - (end-of-file (append '(setq custom-dummy - 'custom-dummy) ()))))) - (or (eq (car old) 'setq) - (error "Invalid customization file: %s" custom-file)) - (while new - (let* ((field (cdr (car new))) - (custom (custom-field-custom field)) - (value (custom-field-original field)) - (default (car (custom-import custom (custom-default custom)))) - (name (car (car new)))) - (setq new (cdr new)) - (custom-assert '(eq name (custom-name custom))) - (if (equal default value) - (setcdr old (custom-plist-delq name (cdr old))) - (setcdr old (plist-put (cdr old) name - (car (custom-quote custom value))))))) - (erase-buffer) - (insert ";; " custom-file "\ - --- Automatically generated customization information. - ;; - ;; Feel free to edit by hand, but the entire content should consist of - ;; a single setq. Any other lisp expressions will confuse the - ;; automatic configuration engine. - - \(setq ") - (setq old (cdr old)) - (while old - (prin1 (car old) (current-buffer)) - (setq old (cdr old)) - (insert " ") - (pp (car old) (current-buffer)) - (setq old (cdr old)) - (if old (insert "\n "))) - (insert ")\n") - (save-buffer) - (kill-buffer (current-buffer)))))) - - (defun custom-load () - "Save customization information." - (interactive (and custom-modified-list - (not (equal (list (custom-name-field 'custom-file)) - custom-modified-list)) - (not (y-or-n-p "Discard all changes? ")) - (error "Load aborted"))) - (load-file (custom-name-value 'custom-file)) - (custom-reset-all)) - - ;;; Field Editing: - ;; - ;; Various internal functions for implementing the direct editing of - ;; fields in the customization buffer. - - (defun custom-field-untouch (field) - ;; Remove FIELD and its children from `custom-modified-list'. - (setq custom-modified-list (delq field custom-modified-list)) - (if (arrayp field) - (let ((value (custom-field-value field))) - (cond ((null (custom-data (custom-field-custom field)))) - ((arrayp value) - (custom-field-untouch value)) - ((listp value) - (mapcar 'custom-field-untouch value)))))) - - - (defun custom-field-insert (field) - ;; Insert editing FIELD in current buffer. - (let ((from (point)) - (custom (custom-field-custom field)) - (value (custom-field-value field))) - (insert (custom-write custom value)) - (insert-char (custom-padding custom) - (- (custom-width custom) (- (point) from))) - (custom-field-move field from (point)) - (custom-set-text-properties - from (point) - (list 'custom-field field - 'custom-tag field - 'face (custom-field-face field) - 'start-open t - 'end-open t)))) - - (defun custom-field-read (field) - ;; Read the screen content of FIELD. - (custom-read (custom-field-custom field) - (custom-buffer-substring-no-properties (custom-field-start field) - (custom-field-end field)))) - - ;; Fields are shown in a special `active' face when point is inside - ;; it. You activate the field by moving point inside (entering) it - ;; and deactivate the field by moving point outside (leaving) it. - - (defun custom-field-leave (field) - ;; Deactivate FIELD. - (let ((before-change-functions nil) - (after-change-functions nil)) - (custom-put-text-property (custom-field-start field) (custom-field-end field) - 'face (custom-field-face field)))) - - (defun custom-field-enter (field) - ;; Activate FIELD. - (let* ((start (custom-field-start field)) - (end (custom-field-end field)) - (custom (custom-field-custom field)) - (padding (custom-padding custom)) - (before-change-functions nil) - (after-change-functions nil)) - (or (eq this-command 'self-insert-command) - (let ((pos end)) - (while (and (< start pos) - (eq (char-after (1- pos)) padding)) - (setq pos (1- pos))) - (if (< pos (point)) - (goto-char pos)))) - (custom-put-text-property start end 'face custom-field-active-face))) - - (defun custom-field-resize (field) - ;; Resize FIELD after change. - (let* ((custom (custom-field-custom field)) - (begin (custom-field-start field)) - (end (custom-field-end field)) - (pos (point)) - (padding (custom-padding custom)) - (width (custom-width custom)) - (size (- end begin))) - (cond ((< size width) - (goto-char end) - (if (fboundp 'insert-before-markers-and-inherit) - ;; Emacs 19. - (insert-before-markers-and-inherit - (make-string (- width size) padding)) - ;; XEmacs: BUG: Doesn't work! - (insert-before-markers (make-string (- width size) padding))) - (goto-char pos)) - ((> size width) - (let ((start (if (and (< (+ begin width) pos) (<= pos end)) - pos - (+ begin width)))) - (goto-char end) - (while (and (< start (point)) (= (preceding-char) padding)) - (backward-delete-char 1)) - (goto-char pos)))))) - - (defvar custom-field-changed nil) - ;; List of fields changed on the screen but whose VALUE attribute has - ;; not yet been updated to reflect the new screen content. - (make-variable-buffer-local 'custom-field-changed) - - (defun custom-field-parse (field) - ;; Parse FIELD content iff changed. - (if (memq field custom-field-changed) - (progn - (setq custom-field-changed (delq field custom-field-changed)) - (custom-field-value-set field (custom-field-read field)) - (custom-field-update field)))) - - (defun custom-post-command () - ;; Keep track of their active field. - (custom-assert '(eq major-mode 'custom-mode)) - (let ((field (custom-field-property (point)))) - (if (eq field custom-field-last) - (if (memq field custom-field-changed) - (custom-field-resize field)) - (custom-field-parse custom-field-last) - (if custom-field-last - (custom-field-leave custom-field-last)) - (if field - (custom-field-enter field)) - (setq custom-field-last field)) - (set-buffer-modified-p (or custom-modified-list - custom-field-changed)))) - - (defvar custom-field-was nil) - ;; The custom data before the change. - (make-variable-buffer-local 'custom-field-was) - - (defun custom-before-change (begin end) - ;; Check that we the modification is allowed. - (if (not (eq major-mode 'custom-mode)) - (message "Aargh! Why is custom-before-change called here?") - (let ((from (custom-field-property begin)) - (to (custom-field-property end))) - (cond ((or (null from) (null to)) - (error "You can only modify the fields")) - ((not (eq from to)) - (error "Changes must be limited to a single field.")) - (t - (setq custom-field-was from)))))) - - (defun custom-after-change (begin end length) - ;; Keep track of field content. - (if (not (eq major-mode 'custom-mode)) - (message "Aargh! Why is custom-after-change called here?") - (let ((field custom-field-was)) - (custom-assert '(prog1 field (setq custom-field-was nil))) - ;; Prevent mixing fields properties. - (custom-put-text-property begin end 'custom-field field) - ;; Update the field after modification. - (if (eq (custom-field-property begin) field) - (let ((field-end (custom-field-end field))) - (if (> end field-end) - (set-marker field-end end)) - (add-to-list 'custom-field-changed field)) - ;; We deleted the entire field, reinsert it. - (custom-assert '(eq begin end)) - (save-excursion - (goto-char begin) - (custom-field-value-set field - (custom-read (custom-field-custom field) "")) - (custom-field-insert field)))))) - - (defun custom-field-property (pos) - ;; The `custom-field' text property valid for POS. - (or (get-text-property pos 'custom-field) - (and (not (eq pos (point-min))) - (get-text-property (1- pos) 'custom-field)))) - - ;;; Generic Utilities: - ;; - ;; Some utility functions that are not really specific to custom. - - (defun custom-assert (expr) - "Assert that EXPR evaluates to non-nil at this point" - (or (eval expr) - (error "Assertion failed: %S" expr))) - - (defun custom-first-line (string) - "Return the part of STRING before the first newline." - (let ((pos 0) - (len (length string))) - (while (and (< pos len) (not (eq (aref string pos) ?\n))) - (setq pos (1+ pos))) - (if (eq pos len) - string - (substring string 0 pos)))) - - (defun custom-insert-before (list old new) - "In LIST insert before OLD a NEW element." - (cond ((null list) - (list new)) - ((null old) - (nconc list (list new))) - ((eq old (car list)) - (cons new list)) - (t - (let ((list list)) - (while (not (eq old (car (cdr list)))) - (setq list (cdr list)) - (custom-assert '(cdr list))) - (setcdr list (cons new (cdr list)))) - list))) - - (defun custom-strip-padding (string padding) - "Remove padding from STRING." - (let ((regexp (concat (regexp-quote (char-to-string padding)) "+"))) - (while (string-match regexp string) - (setq string (concat (substring string 0 (match-beginning 0)) - (substring string (match-end 0)))))) - string) - - (defun custom-plist-memq (prop plist) - "Return non-nil if PROP is a property of PLIST. Comparison done with EQ." - (let (result) - (while plist - (if (eq (car plist) prop) - (setq result plist - plist nil) - (setq plist (cdr (cdr plist))))) - result)) - - (defun custom-plist-delq (prop plist) - "Delete property PROP from property list PLIST." - (while (eq (car plist) prop) - (setq plist (cdr (cdr plist)))) - (let ((list plist) - (next (cdr (cdr plist)))) - (while next - (if (eq (car next) prop) - (progn - (setq next (cdr (cdr next))) - (setcdr (cdr list) next)) - (setq list next - next (cdr (cdr next)))))) - plist) - - ;;; Meta Customization: - - (custom-declare '() - '((tag . "Meta Customization") - (doc . "Customization of the customization support.") - (type . group) - (data ((type . face-doc)) - ((tag . "Button Face") - (default . bold) - (doc . "Face used for tags in customization buffers.") - (name . custom-button-face) - (synchronize . (lambda (f) - (custom-category-put 'custom-button-properties - 'face custom-button-face))) - (type . face)) - ((tag . "Mouse Face") - (default . highlight) - (doc . "\ - Face used when mouse is above a button in customization buffers.") - (name . custom-mouse-face) - (synchronize . (lambda (f) - (custom-category-put 'custom-button-properties - mouse-face - custom-mouse-face))) - (type . face)) - ((tag . "Field Face") - (default . italic) - (doc . "Face used for customization fields.") - (name . custom-field-face) - (type . face)) - ((tag . "Uninitialized Face") - (default . modeline) - (doc . "Face used for uninitialized customization fields.") - (name . custom-field-uninitialized-face) - (type . face)) - ((tag . "Invalid Face") - (default . highlight) - (doc . "\ - Face used for customization fields containing invalid data.") - (name . custom-field-invalid-face) - (type . face)) - ((tag . "Modified Face") - (default . bold-italic) - (doc . "Face used for modified customization fields.") - (name . custom-field-modified-face) - (type . face)) - ((tag . "Active Face") - (default . underline) - (doc . "\ - Face used for customization fields while they are being edited.") - (name . custom-field-active-face) - (type . face))))) - - ;; custom.el uses two categories. - - (custom-category-create 'custom-documentation-properties) - (custom-category-put 'custom-documentation-properties rear-nonsticky t) - - (custom-category-create 'custom-button-properties) - (custom-category-put 'custom-button-properties 'face custom-button-face) - (custom-category-put 'custom-button-properties mouse-face custom-mouse-face) - (custom-category-put 'custom-button-properties rear-nonsticky t) - - (custom-category-create 'custom-hidden-properties) - (custom-category-put 'custom-hidden-properties 'invisible - (not (string-match "XEmacs" emacs-version))) - (custom-category-put 'custom-hidden-properties intangible t) - - (if (file-readable-p custom-file) - (load-file custom-file)) - - (provide 'custom) - - ;;; custom.el ends here --- 0 ---- *** pub/rgnus/lisp/gnus-art.el Mon Sep 9 19:29:44 1996 --- rgnus/lisp/gnus-art.el Tue Sep 17 02:43:23 1996 *************** *** 134,150 **** "*A hook called after an article has been prepared in the article buffer. If you want to run a special decoding program like nkf, use this hook.") ! ;(defvar gnus-article-display-hook nil ! ; "*A hook called after the article is displayed in the article buffer. ! ;The hook is designed to change the contents of the article ! ;buffer. Typical functions that this hook may contain are ! ;`gnus-article-hide-headers' (hide selected headers), ! ;`gnus-article-maybe-highlight' (perform fancy article highlighting), ! ;`gnus-article-hide-signature' (hide signature) and ! ;`gnus-article-treat-overstrike' (turn \"^H_\" into bold characters).") ! ;(add-hook 'gnus-article-display-hook 'gnus-article-hide-headers-if-wanted) ! ;(add-hook 'gnus-article-display-hook 'gnus-article-treat-overstrike) ! ;(add-hook 'gnus-article-display-hook 'gnus-article-maybe-highlight) ;;; Internal variables --- 134,208 ---- "*A hook called after an article has been prepared in the article buffer. If you want to run a special decoding program like nkf, use this hook.") ! (defvar gnus-article-button-face 'bold ! "Face used for highlighting buttons in the article buffer. ! ! An article button is a piece of text that you can activate by pressing ! `RET' or `mouse-2' above it.") ! ! (defvar gnus-article-mouse-face 'highlight ! "Face used for mouse highlighting in the article buffer. ! ! Article buttons will be displayed in this face when the cursor is ! above them.") ! ! (defvar gnus-signature-face 'italic ! "Face used for highlighting a signature in the article buffer.") ! ! (defvar gnus-header-face-alist ! (cond ! ((not (eq gnus-display-type 'color)) ! '(("" bold italic))) ! ((eq gnus-background-mode 'dark) ! (list ! (list "From" nil ! (custom-face-lookup "light blue" nil nil t t nil)) ! (list "Subject" nil ! (custom-face-lookup "pink" nil nil t t nil)) ! (list "Newsgroups:.*," nil ! (custom-face-lookup "yellow" nil nil t t nil)) ! (list ! "" ! (custom-face-lookup "cyan" nil nil t nil nil) ! (custom-face-lookup "forestgreen" nil nil nil t ! nil)))) ! (t ! (list ! (list "From" nil ! (custom-face-lookup "MidnightBlue" nil nil t t nil)) ! (list "Subject" nil ! (custom-face-lookup "firebrick" nil nil t t nil)) ! (list "Newsgroups:.*," nil ! (custom-face-lookup "indianred" nil nil t t nil)) ! (list "" ! (custom-face-lookup ! "DarkGreen" nil nil t nil nil) ! (custom-face-lookup "DarkGreen" nil nil ! nil t nil))))) ! "Controls highlighting of article header. ! ! [ This needs to be rewritten in lisp-talk ] ! ! Below is a list of article header names, and the faces used for ! displaying the name and content of the header. The `Header' field ! should contain the name of the header. The field actually contains a ! regular expression that should match the beginning of the header line, ! but if you don't know what a regular expression is, just write the ! name of the header. The second field is the `Name' field, which ! determines how the header name (i. e., the part of the header left ! of the `:') is displayed. The third field is the `Content' field, ! which determines how the content (i. e., the part of the header right of ! the `:') is displayed. ! ! If you leave the last `Header' field in the list empty, the `Name' and ! `Content' fields will determine how headers not listed above are ! displayed. ! ! If you only want to change the display of the name part for a specific ! header, specify `None' in the `Content' field. Similarly, specify ! `None' in the `Name' field if you only want to leave the name part ! alone.") ! ;;; Internal variables *** pub/rgnus/lisp/gnus-cite.el Sun Sep 8 12:09:23 1996 --- rgnus/lisp/gnus-cite.el Tue Sep 17 02:42:40 1996 *************** *** 62,82 **** (defvar gnus-cite-minimum-match-count 2 "Minimum number of identical prefixes before we believe it's a citation.") - ;see gnus-cus.el - ;(defvar gnus-cite-face-list - ; (if (eq gnus-display-type 'color) - ; (if (eq gnus-background-mode 'dark) 'light 'dark) - ; '(italic)) - ; "Faces used for displaying different citations. - ;It is either a list of face names, or one of the following special - ;values: - - ;dark: Create faces from `gnus-face-dark-name-list'. - ;light: Create faces from `gnus-face-light-name-list'. - - ;The variable `gnus-make-foreground' determines whether the created - ;faces change the foreground or the background colors.") - (defvar gnus-cite-attribution-prefix "in article\\|in <" "Regexp matching the beginning of an attribution line.") --- 62,67 ---- *************** *** 85,116 **** "Regexp matching the end of an attribution line. The text matching the first grouping will be used as a button.") ! ;see gnus-cus.el ! ;(defvar gnus-cite-attribution-face 'underline ! ; "Face used for attribution lines. ! ;It is merged with the face for the cited text belonging to the attribution.") ! ! ;see gnus-cus.el ! ;(defvar gnus-cite-hide-percentage 50 ! ; "Only hide cited text if it is larger than this percent of the body.") ! ! ;see gnus-cus.el ! ;(defvar gnus-cite-hide-absolute 10 ! ; "Only hide cited text if there is at least this number of cited lines.") ! ! ;see gnus-cus.el ! ;(defvar gnus-face-light-name-list ! ; '("light blue" "light cyan" "light yellow" "light pink" ! ; "pale green" "beige" "orange" "magenta" "violet" "medium purple" ! ; "turquoise") ! ; "Names of light colors.") ! ! ;see gnus-cus.el ! ;(defvar gnus-face-dark-name-list ! ; '("dark salmon" "firebrick" ! ; "dark green" "dark orange" "dark khaki" "dark violet" ! ; "dark turquoise") ! ; "Names of dark colors.") ;;; Internal Variables: --- 70,107 ---- "Regexp matching the end of an attribution line. The text matching the first grouping will be used as a button.") ! (defvar gnus-cite-attribution-face 'underline ! "Face used for attribution lines. ! It is merged with the face for the cited text belonging to the attribution.") ! ! (defvar gnus-cite-face-list ! (cond ((not (eq gnus-display-type 'color)) ! '(italic)) ! ((eq gnus-background-mode 'dark) ! (mapcar 'gnus-make-face ! gnus-face-light-name-list)) ! (t ! (mapcar 'gnus-make-face ! gnus-face-dark-name-list))) ! "List of faces used for highlighting citations. ! ! When there are citations from multiple articles in the same message, ! Gnus will try to give each citation from each article its own face. ! This should make it easier to see who wrote what.") ! ! (defvar gnus-cite-hide-percentage 50 ! "Only hide excess citation if above this percentage of the body.") ! ! (defvar gnus-cite-hide-absolute 10 ! "Only hide excess citation if above this number of lines in the body.") ! ! (defun gnus-custom-import-cite-face-list (custom alist) ! ;; Backward compatible grokking of light and dark. ! (cond ((eq alist 'light) ! (setq alist (mapcar 'gnus-make-face gnus-face-light-name-list))) ! ((eq alist 'dark) ! (setq alist (mapcar 'gnus-make-face gnus-face-dark-name-list)))) ! (funcall (custom-super custom 'import) custom alist)) ;;; Internal Variables: *** pub/rgnus/lisp/gnus-cus.el Mon Sep 9 19:30:50 1996 --- rgnus/lisp/gnus-cus.el Tue Sep 17 02:37:25 1996 *************** *** 1,672 **** - ;;; gnus-cus.el --- User friendly customization of Gnus - ;; Copyright (C) 1995,96 Free Software Foundation, Inc. - ;; - ;; Author: Per Abrahamsen - ;; Keywords: help, news - ;; Version: 0.1 - - ;; This file is part of GNU Emacs. - - ;; GNU Emacs is free software; you can redistribute it and/or modify - ;; it under the terms of the GNU General Public License as published by - ;; the Free Software Foundation; either version 2, or (at your option) - ;; any later version. - - ;; GNU Emacs is distributed in the hope that it will be useful, - ;; but WITHOUT ANY WARRANTY; without even the implied warranty of - ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - ;; GNU General Public License for more details. - - ;; You should have received a copy of the GNU General Public License - ;; along with GNU Emacs; see the file COPYING. If not, write to the - ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, - ;; Boston, MA 02111-1307, USA. - - ;;; Commentary: - - ;;; Code: - - (require 'gnus-load) - (require 'custom) - (require 'gnus-ems) - (require 'browse-url) - - ;; The following is just helper functions and data, not meant to be set - ;; by the user. - (defun gnus-make-face (color) - ;; Create entry for face with COLOR. - (custom-face-lookup color nil nil nil nil nil)) - - (defvar gnus-face-light-name-list - '("light blue" "light cyan" "light yellow" "light pink" - "pale green" "beige" "orange" "magenta" "violet" "medium purple" - "turquoise")) - - (defvar gnus-face-dark-name-list - '("MidnightBlue" "firebrick" "dark green" "OrangeRed" - "dark khaki" "dark violet" "SteelBlue4")) - ; CornflowerBlue SeaGreen OrangeRed SteelBlue4 DeepPink3 - ; DarkOlviveGreen4 - - (custom-declare '() - '((tag . "Gnus") - (doc . "\ - The coffee-brewing, all singing, all dancing, kitchen sink newsreader.") - (type . group) - (data - ((tag . "Visual") - (doc . "\ - Gnus can be made colorful and fun or grey and dull as you wish.") - (type . group) - (data - ((tag . "Visual") - (doc . "Enable visual features. - If `visual' is disabled, there will be no menus and few faces. Most of - the visual customization options below will be ignored. Gnus will use - less space and be faster as a result.") - (default . - (summary-highlight group-highlight - article-highlight - mouse-face - summary-menu group-menu article-menu - tree-highlight menu highlight - browse-menu server-menu - page-marker tree-menu binary-menu pick-menu - grouplens-menu)) - (name . gnus-visual) - (type . sexp)) - ((tag . "WWW Browser") - (doc . "\ - WWW Browser to call when clicking on an URL button in the article buffer. - - You can choose between one of the predefined browsers, or `Other'.") - (name . browse-url-browser-function) - (calculate . (cond ((boundp 'browse-url-browser-function) - browse-url-browser-function) - ((fboundp 'w3-fetch) - 'w3-fetch) - ((eq window-system 'x) - 'gnus-netscape-open-url))) - (type . choice) - (data - ((tag . "W3") - (type . const) - (default . w3-fetch)) - ((tag . "Netscape") - (type . const) - (default . browse-url-netscape)) - ((prompt . "Other") - (doc . "\ - You must specify the name of a Lisp function here. The lisp function - should open a WWW browser when called with an URL (a string). - ") - (default . __uninitialized__) - (type . symbol)))) - ((tag . "Mouse Face") - (doc . "\ - Face used for group or summary buffer mouse highlighting. - The line beneath the mouse pointer will be highlighted with this - face.") - (name . gnus-mouse-face) - (calculate . (condition-case () - (if (gnus-visual-p 'mouse-face 'highlight) - (if (boundp 'gnus-mouse-face) - gnus-mouse-face - 'highlight) - 'default) - (error nil))) - (type . face)) - ((tag . "Article Display") - (doc . "Controls how the article buffer will look. - - If you leave the list empty, the article will appear exactly as it is - stored on the disk. The list entries will hide or highlight various - parts of the article, making it easier to find the information you - want.") - (name . gnus-article-display-hook) - (type . list) - (calculate - . (if (and (string-match "xemacs" emacs-version) - (featurep 'xface)) - '(gnus-article-hide-headers-if-wanted - gnus-article-hide-boring-headers - gnus-article-treat-overstrike - gnus-article-maybe-highlight - gnus-article-display-x-face) - '(gnus-article-hide-headers-if-wanted - gnus-article-hide-boring-headers - gnus-article-treat-overstrike - gnus-article-maybe-highlight))) - (data - ((type . repeat) - (header . nil) - (data - (tag . "Filter") - (type . choice) - (data - ((tag . "Treat Overstrike") - (doc . "\ - Convert use of overstrike into bold and underline. - - Two identical letters separated by a backspace are displayed as a - single bold letter, while a letter followed by a backspace and an - underscore will be displayed as a single underlined letter. This - technique was developed for old line printers (think about it), and is - still in use on some newsgroups, in particular the ClariNet - hierarchy. - ") - (type . const) - (default . - gnus-article-treat-overstrike)) - ((tag . "Word Wrap") - (doc . "\ - Format too long lines. - ") - (type . const) - (default . gnus-article-word-wrap)) - ((tag . "Remove CR") - (doc . "\ - Remove carriage returns from an article. - ") - (type . const) - (default . gnus-article-remove-cr)) - ((tag . "Display X-Face") - (doc . "\ - Look for an X-Face header and display it if present. - - See also `X Face Command' for a definition of the external command - used for decoding and displaying the face. - ") - (type . const) - (default . gnus-article-display-x-face)) - ((tag . "Unquote Printable") - (doc . "\ - Transform MIME quoted printable into 8-bit characters. - - Quoted printable is often seen by strings like `=EF' where you would - expect a non-English letter. - ") - (type . const) - (default . - gnus-article-de-quoted-unreadable)) - ((tag . "Universal Time") - (doc . "\ - Convert date header to universal time. - ") - (type . const) - (default . gnus-article-date-ut)) - ((tag . "Local Time") - (doc . "\ - Convert date header to local timezone. - ") - (type . const) - (default . gnus-article-date-local)) - ((tag . "Lapsed Time") - (doc . "\ - Replace date header with a header showing the articles age. - ") - (type . const) - (default . gnus-article-date-lapsed)) - ((tag . "Highlight") - (doc . "\ - Highlight headers, citations, signature, and buttons. - ") - (type . const) - (default . gnus-article-highlight)) - ((tag . "Maybe Highlight") - (doc . "\ - Highlight headers, signature, and buttons if `Visual' is turned on. - ") - (type . const) - (default . - gnus-article-maybe-highlight)) - ((tag . "Highlight Some") - (doc . "\ - Highlight headers, signature, and buttons. - ") - (type . const) - (default . gnus-article-highlight-some)) - ((tag . "Highlight Headers") - (doc . "\ - Highlight headers as specified by `Article Header Highlighting'. - ") - (type . const) - (default . - gnus-article-highlight-headers)) - ((tag . "Highlight Signature") - (doc . "\ - Highlight the signature as specified by `Article Signature Face'. - ") - (type . const) - (default . - gnus-article-highlight-signature)) - ((tag . "Citation") - (doc . "\ - Highlight the citations as specified by `Citation Faces'. - ") - (type . const) - (default . - gnus-article-highlight-citation)) - ((tag . "Hide") - (doc . "\ - Hide unwanted headers, excess citation, and the signature. - ") - (type . const) - (default . gnus-article-hide)) - ((tag . "Hide Headers If Wanted") - (doc . "\ - Hide headers, but allow user to display them with `t' or `v'. - ") - (type . const) - (default . - gnus-article-hide-headers-if-wanted)) - ((tag . "Hide Headers") - (doc . "\ - Hide unwanted headers and possibly sort them as well. - Most likely you want to use `Hide Headers If Wanted' instead. - ") - (type . const) - (default . gnus-article-hide-headers)) - ((tag . "Hide Signature") - (doc . "\ - Hide the signature. - ") - (type . const) - (default . gnus-article-hide-signature)) - ((tag . "Hide Excess Citations") - (doc . "\ - Hide excess citation. - - Excess is defined by `Citation Hide Percentage' and `Citation Hide Absolute'. - ") - (type . const) - (default . - gnus-article-hide-citation-maybe)) - ((tag . "Hide Citations") - (doc . "\ - Hide all cited text. - ") - (type . const) - (default . gnus-article-hide-citation)) - ((tag . "Add Buttons") - (doc . "\ - Make URLs into clickable buttons. - ") - (type . const) - (default . gnus-article-add-buttons)) - ((prompt . "Other") - (doc . "\ - Name of Lisp function to call. - - Push the `Filter' button to select one of the predefined filters. - ") - (type . symbol))))))) - ((tag . "Article Button Face") - (doc . "\ - Face used for highlighting buttons in the article buffer. - - An article button is a piece of text that you can activate by pressing - `RET' or `mouse-2' above it.") - (name . gnus-article-button-face) - (default . bold) - (type . face)) - ((tag . "Article Mouse Face") - (doc . "\ - Face used for mouse highlighting in the article buffer. - - Article buttons will be displayed in this face when the cursor is - above them.") - (name . gnus-article-mouse-face) - (default . highlight) - (type . face)) - ((tag . "Article Signature Face") - (doc . "\ - Face used for highlighting a signature in the article buffer.") - (name . gnus-signature-face) - (default . italic) - (type . face)) - ((tag . "Article Header Highlighting") - (doc . "\ - Controls highlighting of article header. - - Below is a list of article header names, and the faces used for - displaying the name and content of the header. The `Header' field - should contain the name of the header. The field actually contains a - regular expression that should match the beginning of the header line, - but if you don't know what a regular expression is, just write the - name of the header. The second field is the `Name' field, which - determines how the header name (i. e., the part of the header left - of the `:') is displayed. The third field is the `Content' field, - which determines how the content (i. e., the part of the header right of - the `:') is displayed. - - If you leave the last `Header' field in the list empty, the `Name' and - `Content' fields will determine how headers not listed above are - displayed. - - If you only want to change the display of the name part for a specific - header, specify `None' in the `Content' field. Similarly, specify - `None' in the `Name' field if you only want to leave the name part - alone.") - (name . gnus-header-face-alist) - (type . list) - (calculate - . (cond - ((not (eq gnus-display-type 'color)) - '(("" bold italic))) - ((eq gnus-background-mode 'dark) - (list - (list "From" nil - (custom-face-lookup "light blue" nil nil t t nil)) - (list "Subject" nil - (custom-face-lookup "pink" nil nil t t nil)) - (list "Newsgroups:.*," nil - (custom-face-lookup "yellow" nil nil t t nil)) - (list - "" - (custom-face-lookup "cyan" nil nil t nil nil) - (custom-face-lookup "forestgreen" nil nil nil t - nil)))) - (t - (list - (list "From" nil - (custom-face-lookup "MidnightBlue" nil nil t t nil)) - (list "Subject" nil - (custom-face-lookup "firebrick" nil nil t t nil)) - (list "Newsgroups:.*," nil - (custom-face-lookup "indianred" nil nil t t nil)) - (list "" - (custom-face-lookup - "DarkGreen" nil nil t nil nil) - (custom-face-lookup "DarkGreen" nil nil - nil t nil)))))) - (data - ((type . repeat) - (header . nil) - (data - (type . list) - (compact . t) - (data - ((type . string) - (prompt . "Header") - (tag . "Header ")) - "\n " - ((type . face) - (prompt . "Name") - (tag . "Name ")) - "\n " - ((type . face) - (tag . "Content")) - "\n"))))) - ((tag . "Attribution Face") - (doc . "\ - Face used for attribution lines. - It is merged with the face for the cited text belonging to the attribution.") - (name . gnus-cite-attribution-face) - (default . underline) - (type . face)) - ((tag . "Citation Faces") - (doc . "\ - List of faces used for highlighting citations. - - When there are citations from multiple articles in the same message, - Gnus will try to give each citation from each article its own face. - This should make it easier to see who wrote what.") - (name . gnus-cite-face-list) - (import . gnus-custom-import-cite-face-list) - (type . list) - (calculate . (cond ((not (eq gnus-display-type 'color)) - '(italic)) - ((eq gnus-background-mode 'dark) - (mapcar 'gnus-make-face - gnus-face-light-name-list)) - (t - (mapcar 'gnus-make-face - gnus-face-dark-name-list)))) - (data - ((type . repeat) - (header . nil) - (data (type . face) - (tag . "Face"))))) - ((tag . "Citation Hide Percentage") - (doc . "\ - Only hide excess citation if above this percentage of the body.") - (name . gnus-cite-hide-percentage) - (default . 50) - (type . integer)) - ((tag . "Citation Hide Absolute") - (doc . "\ - Only hide excess citation if above this number of lines in the body.") - (name . gnus-cite-hide-absolute) - (default . 10) - (type . integer)) - ((tag . "Summary Selected Face") - (doc . "\ - Face used for highlighting the current article in the summary buffer.") - (name . gnus-summary-selected-face) - (default . underline) - (type . face)) - ((tag . "Summary Line Highlighting") - (doc . "\ - Controls the highlighting of summary buffer lines. - - Below is a list of `Form'/`Face' pairs. When deciding how a a - particular summary line should be displayed, each form is - evaluated. The content of the face field after the first true form is - used. You can change how those summary lines are displayed, by - editing the face field. - - It is also possible to change and add form fields, but currently that - requires an understanding of Lisp expressions. Hopefully this will - change in a future release. For now, you can use the following - variables in the Lisp expression: - - score: The article's score - default: The default article score. - below: The score below which articles are automatically marked as read. - mark: The article's mark.") - (name . gnus-summary-highlight) - (type . list) - (calculate - . (cond - ((not (eq gnus-display-type 'color)) - '(((> score default) . bold) - ((< score default) . italic))) - ((eq gnus-background-mode 'dark) - (list - (cons - '(= mark gnus-canceled-mark) - (custom-face-lookup "yellow" "black" nil - nil nil nil)) - (cons '(and (> score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) - (custom-face-lookup - "pink" nil nil t nil nil)) - (cons '(and (< score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) - (custom-face-lookup "pink" nil nil - nil t nil)) - (cons '(or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark)) - (custom-face-lookup - "pink" nil nil nil nil nil)) - - (cons - '(and (> score default) (= mark gnus-ancient-mark)) - (custom-face-lookup "medium blue" nil nil t - nil nil)) - (cons - '(and (< score default) (= mark gnus-ancient-mark)) - (custom-face-lookup "SkyBlue" nil nil - nil t nil)) - (cons - '(= mark gnus-ancient-mark) - (custom-face-lookup "SkyBlue" nil nil - nil nil nil)) - (cons '(and (> score default) (= mark gnus-unread-mark)) - (custom-face-lookup "white" nil nil t - nil nil)) - (cons '(and (< score default) (= mark gnus-unread-mark)) - (custom-face-lookup "white" nil nil - nil t nil)) - (cons '(= mark gnus-unread-mark) - (custom-face-lookup - "white" nil nil nil nil nil)) - - (cons '(> score default) 'bold) - (cons '(< score default) 'italic))) - (t - (list - (cons - '(= mark gnus-canceled-mark) - (custom-face-lookup - "yellow" "black" nil nil nil nil)) - (cons '(and (> score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) - (custom-face-lookup "firebrick" nil nil - t nil nil)) - (cons '(and (< score default) - (or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark))) - (custom-face-lookup "firebrick" nil nil - nil t nil)) - (cons - '(or (= mark gnus-dormant-mark) - (= mark gnus-ticked-mark)) - (custom-face-lookup - "firebrick" nil nil nil nil nil)) - - (cons '(and (> score default) (= mark gnus-ancient-mark)) - (custom-face-lookup "RoyalBlue" nil nil - t nil nil)) - (cons '(and (< score default) (= mark gnus-ancient-mark)) - (custom-face-lookup "RoyalBlue" nil nil - nil t nil)) - (cons - '(= mark gnus-ancient-mark) - (custom-face-lookup - "RoyalBlue" nil nil nil nil nil)) - - (cons '(and (> score default) (/= mark gnus-unread-mark)) - (custom-face-lookup "DarkGreen" nil nil - t nil nil)) - (cons '(and (< score default) (/= mark gnus-unread-mark)) - (custom-face-lookup "DarkGreen" nil nil - nil t nil)) - (cons - '(/= mark gnus-unread-mark) - (custom-face-lookup "DarkGreen" nil nil - nil nil nil)) - - (cons '(> score default) 'bold) - (cons '(< score default) 'italic))))) - (data - ((type . repeat) - (header . nil) - (data (type . pair) - (compact . t) - (data ((type . sexp) - (width . 60) - (tag . "Form")) - "\n " - ((type . face) - (tag . "Face")) - "\n"))))) - - ((tag . "Group Line Highlighting") - (doc . "\ - Controls the highlighting of group buffer lines. - - Below is a list of `Form'/`Face' pairs. When deciding how a a - particular group line should be displayed, each form is - evaluated. The content of the face field after the first true form is - used. You can change how those group lines are displayed by - editing the face field. - - It is also possible to change and add form fields, but currently that - requires an understanding of Lisp expressions. Hopefully this will - change in a future release. For now, you can use the following - variables in the Lisp expression: - - group: The name of the group. - unread: The number of unread articles in the group. - method: The select method used. - mailp: Whether it's a mail group or not. - level: The level of the group. - score: The score of the group. - ticked: The number of ticked articles.") - (name . gnus-group-highlight) - (type . list) - (calculate - . (cond - ((not (eq gnus-display-type 'color)) - '((mailp . bold) - ((= unread 0) . italic))) - ((eq gnus-background-mode 'dark) - `(((and (not mailp) (eq level 1)) . - ,(custom-face-lookup "PaleTurquoise" nil nil t)) - ((and (not mailp) (eq level 2)) . - ,(custom-face-lookup "turquoise" nil nil t)) - ((and (not mailp) (eq level 3)) . - ,(custom-face-lookup "MediumTurquoise" nil nil t)) - ((and (not mailp) (>= level 4)) . - ,(custom-face-lookup "DarkTurquoise" nil nil t)) - ((and mailp (eq level 1)) . - ,(custom-face-lookup "aquamarine1" nil nil t)) - ((and mailp (eq level 2)) . - ,(custom-face-lookup "aquamarine2" nil nil t)) - ((and mailp (eq level 3)) . - ,(custom-face-lookup "aquamarine3" nil nil t)) - ((and mailp (>= level 4)) . - ,(custom-face-lookup "aquamarine4" nil nil t)) - )) - (t - `(((and (not mailp) (<= level 3)) . - ,(custom-face-lookup "ForestGreen" nil nil t)) - ((and (not mailp) (eq level 4)) . - ,(custom-face-lookup "DarkGreen" nil nil t)) - ((and (not mailp) (eq level 5)) . - ,(custom-face-lookup "CadetBlue4" nil nil t)) - ((and mailp (eq level 1)) . - ,(custom-face-lookup "DeepPink3" nil nil t)) - ((and mailp (eq level 2)) . - ,(custom-face-lookup "HotPink3" nil nil t)) - ((and mailp (eq level 3)) . - ,(custom-face-lookup "dark magenta" nil nil t)) - ((and mailp (eq level 4)) . - ,(custom-face-lookup "DeepPink4" nil nil t)) - ((and mailp (> level 4)) . - ,(custom-face-lookup "DarkOrchid4" nil nil t)) - )))) - (data - ((type . repeat) - (header . nil) - (data (type . pair) - (compact . t) - (data ((type . sexp) - (width . 60) - (tag . "Form")) - "\n " - ((type . face) - (tag . "Face")) - "\n"))))) - - ;; Do not define `gnus-button-alist' before we have - ;; some `complexity' attribute so we can hide it from - ;; beginners. - ))))) - - (defun gnus-custom-import-cite-face-list (custom alist) - ;; Backward compatible grokking of light and dark. - (cond ((eq alist 'light) - (setq alist (mapcar 'gnus-make-face gnus-face-light-name-list))) - ((eq alist 'dark) - (setq alist (mapcar 'gnus-make-face gnus-face-dark-name-list)))) - (funcall (custom-super custom 'import) custom alist)) - - (provide 'gnus-cus) - - ;;; gnus-cus.el ends here --- 0 ---- *** pub/rgnus/lisp/gnus-edit.el Sun Sep 8 12:09:24 1996 --- rgnus/lisp/gnus-edit.el Tue Sep 17 02:39:37 1996 *************** *** 1,631 **** - ;;; gnus-edit.el --- Gnus SCORE file editing - ;; Copyright (C) 1995,96 Free Software Foundation, Inc. - ;; - ;; Author: Per Abrahamsen - ;; Keywords: news, help - ;; Version: 0.2 - - ;;; Commentary: - ;; - ;; Type `M-x gnus-score-customize RET' to invoke. - - ;;; Code: - - (require 'custom) - (require 'gnus-score) - (require 'gnus-load) - (require 'gnus-sum) - - (defconst gnus-score-custom-data - '((tag . "Score") - (doc . "Customization of Gnus SCORE files. - - SCORE files allow you to assign a score to each article when you enter - a group, and automatically mark the articles as read or delete them - based on the score. In the summary buffer you can use the score to - sort the articles by score (`C-c C-s C-s') or to jump to the unread - article with the highest score (`,').") - (type . group) - (data "\n" - ((header . nil) - (doc . "Name of SCORE file to customize. - - Enter the name in the `File' field, then push the [Load] button to - load it. When done editing, push the [Save] button to save the file. - - Several score files may apply to each group, and several groups may - use the same score file. This is controlled implicitly by the name of - the score file and the value of the global variable - `gnus-score-find-score-files-function', and explicitly by the - `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 . gnus-kill-files-directory) - (default-file . "SCORE") - (type . file)))) - ((name . files) - (tag . "Files") - (doc . "\ - List of score files to load when 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 . gnus-kill-files-directory))))) - ((name . exclude-files) - (tag . "Exclude Files") - (doc . "\ - List of score files to exclude when 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 . gnus-kill-files-directory))))) - ((name . mark) - (tag . "Mark") - (doc . "\ - Articles below this score will be automatically marked as read. - - This means that when you enter the summary buffer, the articles will - be shown but will already be marked as read. You can then press `x' - to get rid of them entirely. - - By default articles with a negative score will be marked as read. To - change this, push the `Mark' button, and choose `Integer'. You can - then enter a value in the `Mark' field.") - (type . gnus-score-custom-maybe-type)) - ((name . expunge) - (tag . "Expunge") - (doc . "\ - Articles below this score will not be shown in the summary buffer.") - (type . gnus-score-custom-maybe-type)) - ((name . mark-and-expunge) - (tag . "Mark and Expunge") - (doc . "\ - Articles below this score will be marked as read, but not shown. - - Someone should explain me the difference between this and `expunge' - alone or combined with `mark'.") - (type . gnus-score-custom-maybe-type)) - ((name . eval) - (tag . "Eval") - (doc . "\ - Evaluate this lisp expression when the entering summary buffer.") - (type . sexp)) - ((name . read-only) - (tag . "Read Only") - (doc . "Read-only score files will not be updated or saved. - Except from this buffer, of course!") - (type . toggle)) - ((type . doc) - (doc . "\ - Each news header has an associated list of score entries. - You can use the [INS] buttons to add new score entries anywhere in the - list, or the [DEL] buttons to delete specific score entries. - - Each score entry should specify a string that should be matched with - the content actual header in order to determine whether the entry - applies to that header. Enter that string in the `Match' field. - - If the score entry matches, the articles score will be adjusted with - some amount. Enter that amount in the in the `Score' field. You - should specify a positive amount for score entries that matches - articles you find interesting, and a negative amount for score entries - matching articles you would rather avoid. The final score for the - article will be the sum of the score of all score entries that match - the article. - - The score entry can be either permanent or expirable. To make the - entry permanent, push the `Date' button and choose the `Permanent' - entry. To make the entry expirable, choose instead the `Integer' - entry. After choosing the you can enter the date the score entry was - last matched in the `Date' field. The date will be automatically - updated each time the score entry matches an article. When the date - become too old, the score entry will be removed. - - For your convenience, the date is specified as the number of days - elapsed since the (imaginary) Gregorian date Sunday, December 31, 1 - BC. - - Finally, you can choose what kind of match you want to perform by - pushing the `Type' button. For most entries you can choose between - `Exact' which mean the header content must be exactly identical to the - match string, or `Substring' meaning the match string should be - somewhere in the header content, or even `Regexp' to use Emacs regular - expression matching. The last choice is `Fuzzy' which is like `Exact' - except that whitespace derivations, a beginning `Re:' or a terminating - parenthetical remark are all ignored. Each of the four types have a - variant which will ignore case in the comparison. That variant is - indicated with a `(fold)' after its name.")) - ((name . from) - (tag . "From") - (doc . "Scoring based on the authors email address.") - (type . gnus-score-custom-string-type)) - ((name . subject) - (tag . "Subject") - (doc . "Scoring based on the articles subject.") - (type . gnus-score-custom-string-type)) - ((name . followup) - (tag . "Followup") - (doc . "Scoring based on who the article is a followup to. - - If you want to see all followups to your own articles, add an entry - with a positive score matching your email address here. You can also - put an entry with a negative score matching someone who is so annoying - that you don't even want to see him quoted in followups.") - (type . gnus-score-custom-string-type)) - ((name . xref) - (tag . "Xref") - (doc . "Scoring based on article crossposting. - - If you want to score based on which newsgroups an article is posted - to, this is the header to use. The syntax is a little different from - the `Newsgroups' header, but scoring in `Xref' is much faster. As an - example, to match all crossposted articles match on `:.*:' using the - `Regexp' type.") - (type . gnus-score-custom-string-type)) - ((name . references) - (tag . "References") - (doc . "Scoring based on article references. - - The `References' header gives you an alternative way to score on - followups. If you for example want to see follow all discussions - where people from `iesd.auc.dk' school participate, you can add a - substring match on `iesd.auc.dk>' on this header.") - (type . gnus-score-custom-string-type)) - ((name . message-id) - (tag . "Message-ID") - (doc . "Scoring based on the articles message-id. - - This isn't very useful, but Lars like completeness. You can use it to - match all messaged generated by recent Gnus version with a `Substring' - match on `.fsf@'.") - (type . gnus-score-custom-string-type)) - ((type . doc) - (doc . "\ - WARNING: Scoring on the following three pseudo headers is very slow! - Scoring on any of the real headers use a technique that avoids - scanning the entire article, only the actual headers you score on are - scanned, and this scanning has been heavily optimized. Using just a - single entry for one the three pseudo-headers `Head', `Body', and - `All' will require GNUS to retrieve and scan the entire article, which - can be very slow on large groups. However, if you add one entry for - any of these headers, you can just as well add several. Each - subsequent entry cost relatively little extra time.")) - ((name . head) - (tag . "Head") - (doc . "Scoring based on the article header. - - Instead of matching the content of a single header, the entire header - section of the article is matched. You can use this to match on - arbitrary headers, foe example to single out TIN lusers, use a substring - match on `Newsreader: TIN'. That should get 'em!") - (type . gnus-score-custom-string-type)) - ((name . body) - (tag . "Body") - (doc . "Scoring based on the article body. - - If you think any article that mentions `Kibo' is inherently - interesting, do a substring match on His name. You Are Allowed.") - (type . gnus-score-custom-string-type)) - ((name . all) - (tag . "All") - (doc . "Scoring based on the whole article.") - (type . gnus-score-custom-string-type)) - ((name . date) - (tag . "Date") - (doc . "Scoring based on article date. - - You can change the score of articles that have been posted before, - after, or at a specific date. You should add the date in the `Match' - field, and then select `before', `after', or `at' by pushing the - `Type' button. Imagine you want to lower the score of very old - articles, or want to raise the score of articles from the future (such - things happen!). Then you can't use date scoring for that. In fact, - I can't imagine anything you would want to use this for. - - For your convenience, the date is specified in Usenet date format.") - (type . gnus-score-custom-date-type)) - ((type . doc) - (doc . "\ - The Lines and Chars headers use integer based scoring. - - This means that you should write an integer in the `Match' field, and - the push the `Type' field to if the `Chars' or `Lines' header should - be larger, equal, or smaller than the number you wrote in the match - field.")) - ((name . chars) - (tag . "Characters") - (doc . "Scoring based on the number of characters in the article.") - (type . gnus-score-custom-integer-type)) - ((name . lines) - (tag . "Lines") - (doc . "Scoring based on the number of lines in the article.") - (type . gnus-score-custom-integer-type)) - ((name . orphan) - (tag . "Orphan") - (doc . "Score to add to articles with no parents.") - (type . gnus-score-custom-maybe-type)) - ((name . adapt) - (tag . "Adapt") - (doc . "Adapting the score files to your newsreading habits. - - When you have finished reading a group GNUS can automatically create - new score entries based on which articles you read and which you - skipped. This is normally controlled 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 adaptation - rules (overwriting `gnus-default-adaptive-score-alist').") - (type . choice) - (data ((tag . "Default") - (default . nil) - (type . const)) - ((tag . "Enable") - (default . t) - (type . const)) - ((tag . "Disable") - (default . ignore) - (type . const)) - ((tag . "Custom") - (doc . "Customization of adaptive scoring. - - Each time you read an article it will be marked as read. Likewise, if - you delete it, it will be marked as deleted, and if you tick it, it will - be marked as ticked. When you leave a group, GNUS can automatically - create score file entries based on these marks, so next time you enter - the group articles with subjects that you read last time have higher - score and articles with subjects that deleted will have lower score. - - Below is a list of such marks. You can insert new marks to the list - by pushing on one of the `[INS]' buttons in the left margin to create - a new entry and then pushing the `Mark' button to select the mark. - For each mark there is another list, this time of article headers, - which determine how the mark should affect that header. The `[INS]' - buttons of this list are indented to indicate that the belong to the - mark above. Push the `Header' button to choose a header, and then - enter a score value in the `Score' field. - - For each article that are marked with `Mark' when you leave the - group, a temporary score entry for the articles `Header' with the - value of `Score' will be added the adapt file. If the score entry - already exists, `Score' will be added to its value. If you understood - that, you are smart. - - You can select the special value `Other' when pressing the `Mark' or - `Header' buttons. This is because Lars might add more useful values - there. If he does, it is up to you to figure out what they are named.") - (type . list) - (default . ((__uninitialized__))) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (header . nil) - (compact . t) - (data ((type . choice) - (tag . "Mark") - (data ((tag . "Unread") - (default . gnus-unread-mark) - (type . const)) - ((tag . "Ticked") - (default . gnus-ticked-mark) - (type . const)) - ((tag . "Dormant") - (default . gnus-dormant-mark) - (type . const)) - ((tag . "Deleted") - (default . gnus-del-mark) - (type . const)) - ((tag . "Read") - (default . gnus-read-mark) - (type . const)) - ((tag . "Expirable") - (default . gnus-expirable-mark) - (type . const)) - ((tag . "Killed") - (default . gnus-killed-mark) - (type . const)) - ((tag . "Kill-file") - (default . gnus-kill-file-mark) - (type . const)) - ((tag . "Low-score") - (default . gnus-low-score-mark) - (type . const)) - ((tag . "Catchup") - (default . gnus-catchup-mark) - (type . const)) - ((tag . "Ancient") - (default . gnus-ancient-mark) - (type . const)) - ((tag . "Canceled") - (default . gnus-canceled-mark) - (type . const)) - ((prompt . "Other") - (default . ??) - (type . sexp)))) - ((type . repeat) - (prefix . " ") - (data . ((type . list) - (compact . t) - (data ((tag . "Header") - (type . choice) - (data ((tag . "Subject") - (default . subject) - (type . const)) - ((prompt . "From") - (tag . "From ") - (default . from) - (type . const)) - ((prompt . "Other") - (width . 7) - (default . nil) - (type . symbol)))) - ((tag . "Score") - (type . integer)))))))))))))) - ((name . local) - (tag . "Local") - (doc . "\ - List of local variables to set when this score file is loaded. - - Using this entry can provide a convenient way to set variables that - will affect the summary mode for only some specific groups, i. e., those - groups matched by the current score file.") - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Name") - (width . 26) - (type . symbol)) - ((tag . "Value") - (width . 26) - (type . sexp))))))))))) - - (defconst gnus-score-custom-type-properties - '((gnus-score-custom-maybe-type - (type . choice) - (data ((type . integer) - (default . 0)) - ((tag . "Default") - (type . const) - (default . nil)))) - (gnus-score-custom-string-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (width . 59) - (type . string)) - "\n " - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "Exact") - (default . E) - (type . const)) - ((tag . "Substring") - (default . S) - (type . const)) - ((tag . "Regexp") - (default . R) - (type . const)) - ((tag . "Fuzzy") - (default . F) - (type . const)) - ((tag . "Exact (fold)") - (default . e) - (type . const)) - ((tag . "Substring (fold)") - (default . s) - (type . const)) - ((tag . "Regexp (fold)") - (default . r) - (type . const)) - ((tag . "Fuzzy (fold)") - (default . f) - (type . const)))))))))) - (gnus-score-custom-integer-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (type . integer)) - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "<") - (default . <) - (type . const)) - ((tag . ">") - (default . >) - (type . const)) - ((tag . "=") - (default . =) - (type . const)) - ((tag . ">=") - (default . >=) - (type . const)) - ((tag . "<=") - (default . <=) - (type . const)))))))))) - (gnus-score-custom-date-type - (type . list) - (data ((type . repeat) - (header . nil) - (data . ((type . list) - (compact . t) - (data ((tag . "Match") - (width . 59) - (type . string)) - "\n " - ((tag . "Score") - (type . integer)) - ((tag . "Date") - (type . choice) - (data ((type . integer) - (default . 0) - (width . 9)) - ((tag . "Permanent") - (type . const) - (default . nil)))) - ((tag . "Type") - (type . choice) - (data ((tag . "Before") - (default . before) - (type . const)) - ((tag . "After") - (default . after) - (type . const)) - ((tag . "At") - (default . at) - (type . const)))))))))))) - - (defvar gnus-score-custom-file nil - "Name of SCORE file being customized.") - - (defun gnus-score-customize () - "Create a buffer for editing gnus SCORE files." - (interactive) - (let (gnus-score-alist) - (custom-buffer-create "*Score Edit*" gnus-score-custom-data - gnus-score-custom-type-properties - 'gnus-score-custom-set - 'gnus-score-custom-get - 'gnus-score-custom-save)) - (make-local-variable 'gnus-score-custom-file) - (setq gnus-score-custom-file - (expand-file-name "SCORE" gnus-kill-files-directory)) - (make-local-variable 'gnus-score-alist) - (setq gnus-score-alist nil) - (custom-reset-all)) - - (defun gnus-score-custom-get (name) - (if (eq name 'file) - gnus-score-custom-file - (let ((entry (assoc (symbol-name name) gnus-score-alist))) - (if entry - (mapcar 'gnus-score-custom-sanify (cdr entry)) - (setq entry (assoc name gnus-score-alist)) - (if (or (memq name '(files exclude-files local)) - (and (eq name 'adapt) - (not (symbolp (car (cdr entry)))))) - (cdr entry) - (car (cdr entry))))))) - - (defun gnus-score-custom-set (name value) - (cond ((eq name 'file) - (setq gnus-score-custom-file value)) - ((assoc (symbol-name name) gnus-score-alist) - (if value - (setcdr (assoc (symbol-name name) gnus-score-alist) value) - (setq gnus-score-alist (delq (assoc (symbol-name name) - gnus-score-alist) - gnus-score-alist)))) - ((assoc (symbol-name name) gnus-header-index) - (if value - (setq gnus-score-alist - (cons (cons (symbol-name name) value) gnus-score-alist)))) - ((assoc name gnus-score-alist) - (cond ((null value) - (setq gnus-score-alist (delq (assoc name gnus-score-alist) - gnus-score-alist))) - ((and (listp value) (not (eq name 'eval))) - (setcdr (assoc name gnus-score-alist) value)) - (t - (setcdr (assoc name gnus-score-alist) (list value))))) - ((null value)) - ((and (listp value) (not (eq name 'eval))) - (setq gnus-score-alist (cons (cons name value) gnus-score-alist))) - (t - (setq gnus-score-alist - (cons (cons name (list value)) gnus-score-alist))))) - - (defun gnus-score-custom-sanify (entry) - (list (nth 0 entry) - (or (nth 1 entry) gnus-score-interactive-default-score) - (nth 2 entry) - (cond ((null (nth 3 entry)) - 's) - ((memq (nth 3 entry) '(before after at >= <=)) - (nth 3 entry)) - (t - (intern (substring (symbol-name (nth 3 entry)) 0 1)))))) - - (defvar gnus-score-cache nil) - - (defun gnus-score-custom-load () - (interactive) - (let ((file (custom-name-value 'file))) - (if (eq file custom-nil) - (error "You must specify a file name")) - (setq file (expand-file-name file gnus-kill-files-directory)) - (gnus-score-load file) - (setq gnus-score-custom-file file) - (custom-reset-all) - (gnus-message 4 "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)))) - (gnus-message 4 "Saved")) - - (provide 'gnus-edit) - - ;;; gnus-edit.el end here --- 0 ---- *** pub/rgnus/lisp/gnus-group.el Sat Sep 14 22:05:07 1996 --- rgnus/lisp/gnus-group.el Tue Sep 17 02:39:40 1996 *************** *** 211,216 **** --- 211,279 ---- file)))))) "Alist of useful group-server pairs.") + (defvar gnus-group-highlight + (cond + ((not (eq gnus-display-type 'color)) + '((mailp . bold) + ((= unread 0) . italic))) + ((eq gnus-background-mode 'dark) + `(((and (not mailp) (eq level 1)) . + ,(custom-face-lookup "PaleTurquoise" nil nil t)) + ((and (not mailp) (eq level 2)) . + ,(custom-face-lookup "turquoise" nil nil t)) + ((and (not mailp) (eq level 3)) . + ,(custom-face-lookup "MediumTurquoise" nil nil t)) + ((and (not mailp) (>= level 4)) . + ,(custom-face-lookup "DarkTurquoise" nil nil t)) + ((and mailp (eq level 1)) . + ,(custom-face-lookup "aquamarine1" nil nil t)) + ((and mailp (eq level 2)) . + ,(custom-face-lookup "aquamarine2" nil nil t)) + ((and mailp (eq level 3)) . + ,(custom-face-lookup "aquamarine3" nil nil t)) + ((and mailp (>= level 4)) . + ,(custom-face-lookup "aquamarine4" nil nil t)) + )) + (t + `(((and (not mailp) (<= level 3)) . + ,(custom-face-lookup "ForestGreen" nil nil t)) + ((and (not mailp) (eq level 4)) . + ,(custom-face-lookup "DarkGreen" nil nil t)) + ((and (not mailp) (eq level 5)) . + ,(custom-face-lookup "CadetBlue4" nil nil t)) + ((and mailp (eq level 1)) . + ,(custom-face-lookup "DeepPink3" nil nil t)) + ((and mailp (eq level 2)) . + ,(custom-face-lookup "HotPink3" nil nil t)) + ((and mailp (eq level 3)) . + ,(custom-face-lookup "dark magenta" nil nil t)) + ((and mailp (eq level 4)) . + ,(custom-face-lookup "DeepPink4" nil nil t)) + ((and mailp (> level 4)) . + ,(custom-face-lookup "DarkOrchid4" nil nil t)) + ))) + "Controls the highlighting of group buffer lines. + + Below is a list of `Form'/`Face' pairs. When deciding how a a + particular group line should be displayed, each form is + evaluated. The content of the face field after the first true form is + used. You can change how those group lines are displayed by + editing the face field. + + It is also possible to change and add form fields, but currently that + requires an understanding of Lisp expressions. Hopefully this will + change in a future release. For now, you can use the following + variables in the Lisp expression: + + group: The name of the group. + unread: The number of unread articles in the group. + method: The select method used. + mailp: Whether it's a mail group or not. + level: The level of the group. + score: The score of the group. + ticked: The number of ticked articles.") + + ;;; Internal variables (defvar gnus-group-sort-alist-function 'gnus-group-sort-flat *************** *** 565,571 **** ["Send a bug report" gnus-bug t] ["Send a mail" gnus-group-mail t] ["Post an article..." gnus-group-post-news t] - ["Customize score file" gnus-score-customize t] ["Check for new news" gnus-group-get-new-news t] ["Activate all groups" gnus-activate-all-groups t] ["Delete bogus groups" gnus-group-check-bogus-groups t] --- 628,633 ---- *** pub/rgnus/lisp/gnus-load.el Tue Sep 10 21:07:04 1996 --- rgnus/lisp/gnus-load.el Tue Sep 17 02:39:45 1996 *************** *** 425,430 **** --- 425,495 ---- "Function run when a group level is changed. It is called with three parameters -- GROUP, LEVEL and OLDLEVEL.") + ;;; Face thingies. + + ;; The following is just helper functions and data, not meant to be set + ;; by the user. + (defun gnus-make-face (color) + ;; Create entry for face with COLOR. + (custom-face-lookup color nil nil nil nil nil)) + + (defvar gnus-face-light-name-list + '("light blue" "light cyan" "light yellow" "light pink" + "pale green" "beige" "orange" "magenta" "violet" "medium purple" + "turquoise")) + + (defvar gnus-face-dark-name-list + '("MidnightBlue" "firebrick" "dark green" "OrangeRed" + "dark khaki" "dark violet" "SteelBlue4")) + ; CornflowerBlue SeaGreen OrangeRed SteelBlue4 DeepPink3 + ; DarkOlviveGreen4 + + (defvar gnus-visual + '(summary-highlight group-highlight article-highlight + mouse-face + summary-menu group-menu article-menu + tree-highlight menu highlight + browse-menu server-menu + page-marker tree-menu binary-menu pick-menu + grouplens-menu) + "Enable visual features. + If `visual' is disabled, there will be no menus and few faces. Most of + the visual customization options below will be ignored. Gnus will use + less space and be faster as a result.") + + (defvar gnus-mouse-face + (condition-case () + (if (gnus-visual-p 'mouse-face 'highlight) + (if (boundp 'gnus-mouse-face) + gnus-mouse-face + 'highlight) + 'default) + (error nil)) + "Face used for group or summary buffer mouse highlighting. + The line beneath the mouse pointer will be highlighted with this + face.") + + (defvar gnus-article-display-hook + (if (and (string-match "xemacs" emacs-version) + (featurep 'xface)) + '(gnus-article-hide-headers-if-wanted + gnus-article-hide-boring-headers + gnus-article-treat-overstrike + gnus-article-maybe-highlight + gnus-article-display-x-face) + '(gnus-article-hide-headers-if-wanted + gnus-article-hide-boring-headers + gnus-article-treat-overstrike + gnus-article-maybe-highlight)) + "Controls how the article buffer will look. + + If you leave the list empty, the article will appear exactly as it is + stored on the disk. The list entries will hide or highlight various + parts of the article, making it easier to find the information you + want.") + + + ;;; Internal variables *************** *** 628,634 **** (gnus-summary-score-map keymap) gnus-score-save gnus-score-headers gnus-current-score-file-nondirectory gnus-score-adaptive gnus-score-find-trace gnus-score-file-name) - ("gnus-edit" :interactive t gnus-score-customize) ("gnus-topic" :interactive t gnus-topic-mode) ("gnus-topic" gnus-topic-remove-group) ("gnus-salt" :interactive t gnus-pick-mode gnus-binary-mode) --- 693,698 ---- *** pub/rgnus/lisp/gnus-score.el Wed Sep 11 22:34:42 1996 --- rgnus/lisp/gnus-score.el Tue Sep 17 02:33:07 1996 *************** *** 342,349 **** "f" gnus-score-edit-file "F" gnus-score-flush-cache "t" gnus-score-find-trace ! "w" gnus-score-find-favourite-words ! "C" gnus-score-customize) ;; Summary score file commands --- 342,348 ---- "f" gnus-score-edit-file "F" gnus-score-flush-cache "t" gnus-score-find-trace ! "w" gnus-score-find-favourite-words) ;; Summary score file commands *** pub/rgnus/lisp/gnus-sum.el Tue Sep 10 21:20:02 1996 --- rgnus/lisp/gnus-sum.el Tue Sep 17 02:39:42 1996 *************** *** 422,427 **** --- 422,544 ---- (defvar gnus-group-no-more-groups-hook nil "*A hook run when returning to group mode having no more (unread) groups.") + (defvar gnus-summary-selected-face 'underline + "Face used for highlighting the current article in the summary buffer.") + + (defvar gnus-summary-highlight + (cond + ((not (eq gnus-display-type 'color)) + '(((> score default) . bold) + ((< score default) . italic))) + ((eq gnus-background-mode 'dark) + (list + (cons + '(= mark gnus-canceled-mark) + (custom-face-lookup "yellow" "black" nil + nil nil nil)) + (cons '(and (> score default) + (or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark))) + (custom-face-lookup + "pink" nil nil t nil nil)) + (cons '(and (< score default) + (or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark))) + (custom-face-lookup "pink" nil nil + nil t nil)) + (cons '(or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark)) + (custom-face-lookup + "pink" nil nil nil nil nil)) + + (cons + '(and (> score default) (= mark gnus-ancient-mark)) + (custom-face-lookup "medium blue" nil nil t + nil nil)) + (cons + '(and (< score default) (= mark gnus-ancient-mark)) + (custom-face-lookup "SkyBlue" nil nil + nil t nil)) + (cons + '(= mark gnus-ancient-mark) + (custom-face-lookup "SkyBlue" nil nil + nil nil nil)) + (cons '(and (> score default) (= mark gnus-unread-mark)) + (custom-face-lookup "white" nil nil t + nil nil)) + (cons '(and (< score default) (= mark gnus-unread-mark)) + (custom-face-lookup "white" nil nil + nil t nil)) + (cons '(= mark gnus-unread-mark) + (custom-face-lookup + "white" nil nil nil nil nil)) + + (cons '(> score default) 'bold) + (cons '(< score default) 'italic))) + (t + (list + (cons + '(= mark gnus-canceled-mark) + (custom-face-lookup + "yellow" "black" nil nil nil nil)) + (cons '(and (> score default) + (or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark))) + (custom-face-lookup "firebrick" nil nil + t nil nil)) + (cons '(and (< score default) + (or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark))) + (custom-face-lookup "firebrick" nil nil + nil t nil)) + (cons + '(or (= mark gnus-dormant-mark) + (= mark gnus-ticked-mark)) + (custom-face-lookup + "firebrick" nil nil nil nil nil)) + + (cons '(and (> score default) (= mark gnus-ancient-mark)) + (custom-face-lookup "RoyalBlue" nil nil + t nil nil)) + (cons '(and (< score default) (= mark gnus-ancient-mark)) + (custom-face-lookup "RoyalBlue" nil nil + nil t nil)) + (cons + '(= mark gnus-ancient-mark) + (custom-face-lookup + "RoyalBlue" nil nil nil nil nil)) + + (cons '(and (> score default) (/= mark gnus-unread-mark)) + (custom-face-lookup "DarkGreen" nil nil + t nil nil)) + (cons '(and (< score default) (/= mark gnus-unread-mark)) + (custom-face-lookup "DarkGreen" nil nil + nil t nil)) + (cons + '(/= mark gnus-unread-mark) + (custom-face-lookup "DarkGreen" nil nil + nil nil nil)) + + (cons '(> score default) 'bold) + (cons '(< score default) 'italic)))) + "Controls the highlighting of summary buffer lines. + + Below is a list of `Form'/`Face' pairs. When deciding how a a + particular summary line should be displayed, each form is + evaluated. The content of the face field after the first true form is + used. You can change how those summary lines are displayed, by + editing the face field. + + It is also possible to change and add form fields, but currently that + requires an understanding of Lisp expressions. Hopefully this will + change in a future release. For now, you can use the following + variables in the Lisp expression: + + score: The article's score + default: The default article score. + below: The score below which articles are automatically marked as read. + mark: The article's mark.") + ;;; Internal variables (defvar gnus-scores-exclude-files nil) *************** *** 1114,1120 **** ["Clear above" gnus-summary-clear-above t]) ["Current score" gnus-summary-current-score t] ["Set score" gnus-summary-set-score t] - ["Customize score file" gnus-score-customize t] ["Switch current score file..." gnus-score-change-score-file t] ["Set mark below..." gnus-score-set-mark-below t] ["Set expunge below..." gnus-score-set-expunge-below t] --- 1231,1236 ---- *** pub/rgnus/lisp/gnus.el Fri Sep 13 01:09:21 1996 --- rgnus/lisp/gnus.el Tue Sep 17 02:42:40 1996 *************** *** 28,34 **** (eval '(run-hooks 'gnus-load-hook)) ! (defconst gnus-version-number "0.35" "Version number for this version of Gnus.") (defconst gnus-version (format "Red Gnus v%s" gnus-version-number) --- 28,34 ---- (eval '(run-hooks 'gnus-load-hook)) ! (defconst gnus-version-number "0.36" "Version number for this version of Gnus.") (defconst gnus-version (format "Red Gnus v%s" gnus-version-number) *************** *** 40,45 **** --- 40,100 ---- (defvar gnus-play-startup-jingle nil "If non-nil, play the Gnus jingle at startup.") + ;;; Kludges to help the transition from the old `custom.el'. + + ;; XEmacs and Emacs 19.29 facep does different things. + (defalias 'custom-facep + (cond ((fboundp 'find-face) + 'find-face) + ((fboundp 'facep) + 'facep) + (t + 'ignore))) + + ;; The XEmacs people think this is evil, so it must go. + (defun custom-face-lookup (&optional fg bg stipple bold italic underline) + "Lookup or create a face with specified attributes." + (let ((name (intern (format "custom-face-%s-%s-%s-%S-%S-%S" + (or fg "default") + (or bg "default") + (or stipple "default") + bold italic underline)))) + (if (and (custom-facep name) + (fboundp 'make-face)) + () + (copy-face 'default name) + (when (and fg + (not (string-equal fg "default"))) + (condition-case () + (set-face-foreground name fg) + (error nil))) + (when (and bg + (not (string-equal bg "default"))) + (condition-case () + (set-face-background name bg) + (error nil))) + (when (and stipple + (not (string-equal stipple "default")) + (not (eq stipple 'custom:asis)) + (fboundp 'set-face-stipple)) + (set-face-stipple name stipple)) + (when (and bold + (not (eq bold 'custom:asis))) + (condition-case () + (make-face-bold name) + (error nil))) + (when (and italic + (not (eq italic 'custom:asis))) + (condition-case () + (make-face-italic name) + (error nil))) + (when (and underline + (not (eq underline 'custom:asis))) + (condition-case () + (set-face-underline-p name t) + (error nil)))) + name)) + ;;; Internal variables (defvar gnus-group-buffer "*Group*") *************** *** 249,255 **** ;;; Load the compatability functions. - (require 'gnus-cus) (require 'gnus-ems) --- 304,309 ---- *** pub/rgnus/lisp/ChangeLog Sun Sep 15 01:10:31 1996 --- rgnus/lisp/ChangeLog Tue Sep 17 02:39:37 1996 *************** *** 1,3 **** --- 1,15 ---- + Tue Sep 17 02:37:26 1996 Lars Magne Ingebrigtsen + + * gnus-edit.el: Removed. + + * custom.el: Removed. + + * gnus-cus.el: Removed. + + Mon Sep 16 05:59:45 1996 Lars Magne Ingebrigtsen + + * gnus.el: Red Gnus v0.35 is released. + Sun Sep 15 00:47:08 1996 Lars Magne Ingebrigtsen * nnmail.el (nnmail-default-file-modes): New default.