*** empty log message ***

[gnus] / lisp / custom.el

;;; custom.el --- User friendly customization support.

;; Copyright (C) 1995, 1996 Free Software Foundation, Inc.

;; Author: Per Abrahamsen <abraham@iesd.auc.dk>
;; 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))

(or (fboundp 'add-to-list)
    ;; Introduced in Emacs 19.29.
    (defun add-to-list (list-var element)
      "Add to the value of LIST-VAR the element ELEMENT if it isn't there yet.
If you want to use `add-to-list' on a variable that is not defined
until a certain package is loaded, you should put the call to `add-to-list'
into a hook function that will be run only after loading the package.
`eval-after-load' provides one way to do this.  In some cases
other hooks, such as major mode hooks, can do the job."
      (or (member element (symbol-value list-var))
          (set list-var (cons element (symbol-value list-var))))))

(or (fboundp 'plist-get)
    ;; Introduced in Emacs 19.29.
    (defun plist-get (plist prop)
      "Extract a value from a property list.
PLIST is a property list, which is a list of the form
\(PROP1 VALUE1 PROP2 VALUE2...).  This function returns the value
corresponding to the given PROP, or nil if PROP is not
one of the properties on the list."
      (let (result)
        (while plist
          (if (eq (car plist) prop)
              (setq result (car (cdr plist))
                    plist nil)
            (set plist (cdr (cdr plist)))))
        result)))

(or (fboundp 'plist-put)
    ;; Introduced in Emacs 19.29.
    (defun plist-put (plist prop val)    
      "Change value in PLIST of PROP to VAL.
PLIST is a property list, which is a list of the form
\(PROP1 VALUE1 PROP2 VALUE2 ...).  PROP is a symbol and VAL is any object.
If PROP is already a property on the list, its value is set to VAL,
otherwise the new PROP VAL pair is added.  The new plist is returned;
use `(setq x (plist-put x prop val))' to be sure to use the new value.
The PLIST is modified by side effects."
      (if (null plist)
          (list prop val)
        (let ((current plist))
          (while current
            (cond ((eq (car current) prop)
                   (setcar (cdr current) val)
                   (setq current nil))
                  ((null (cdr (cdr current)))
                   (setcdr (cdr current) (list prop val))
                   (setq current nil))
                  (t
                   (setq current (cdr (cdr current)))))))
        plist)))

(or (fboundp 'match-string)
    ;; Introduced in Emacs 19.29.
    (defun match-string (num &optional string)
  "Return string of text matched by last search.
NUM specifies which parenthesized expression in the last regexp.
 Value is nil if NUMth pair didn't match, or there were less than NUM pairs.
Zero means the entire text matched by the whole regexp or whole string.
STRING should be given if the last search was by `string-match' on STRING."
  (if (match-beginning num)
      (if string
          (substring string (match-beginning num) (match-end num))
        (buffer-substring (match-beginning num) (match-end num))))))

(or (fboundp 'facep)
    ;; Introduced in Emacs 19.29.
    (defun facep (x)
      "Return t if X is a face name or an internal face vector."
      (and (or (and (fboundp 'internal-facep) (internal-facep x))
               (and 
                (symbolp x) 
                (assq x (and (boundp 'global-face-data) global-face-data))))
           t)))

;; XEmacs and Emacs 19.29 facep does different things.
(if (fboundp 'find-face)
    (fset 'custom-facep 'find-face)
  (fset 'custom-facep 'facep))

(if (custom-facep 'underline)
    ()
  ;; No underline face in XEmacs 19.12.
  (and (fboundp 'make-face)
       (funcall (intern "make-face") 'underline))
  ;; Must avoid calling set-face-underline-p directly, because it
  ;; is a defsubst in emacs19, and will make the .elc files non
  ;; portable!
  (or (and (fboundp 'face-differs-from-default-p)
           (face-differs-from-default-p 'underline))
      (and (fboundp 'set-face-underline-p)
           (funcall 'set-face-underline-p 'underline t))))

(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)
    ;; 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)