Commit 6aaedd12 authored by Per Abrahamsen's avatar Per Abrahamsen

Synched with 1.9914.

parent 99616935
......@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
;; Version: 1.9908
;; Version: 1.9914
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......@@ -246,6 +246,16 @@
:group 'customize
:group 'faces)
(defgroup custom-buffer nil
"Control the customize buffers."
:prefix "custom-"
:group 'customize)
(defgroup custom-menu nil
"Control how the customize menus."
:prefix "custom-"
:group 'customize)
(defgroup abbrev-mode nil
"Word abbreviations mode."
:group 'abbrev)
......@@ -401,7 +411,7 @@ WIDGET is the widget to apply the filter entries of MENU on."
(defcustom custom-unlispify-menu-entries t
"Display menu entries as words instead of symbols if non nil."
:group 'customize
:group 'custom-menu
:type 'boolean)
(defun custom-unlispify-menu-entry (symbol &optional no-suffix)
......@@ -440,7 +450,7 @@ WIDGET is the widget to apply the filter entries of MENU on."
(defcustom custom-unlispify-tag-names t
"Display tag names as words instead of symbols if non nil."
:group 'customize
:group 'custom-buffer
:type 'boolean)
(defun custom-unlispify-tag-name (symbol)
......@@ -518,49 +528,59 @@ if that fails, the doc string with `custom-guess-doc-alist'."
;;; Sorting.
(defcustom custom-buffer-sort-predicate 'custom-buffer-sort-alphabetically
(defcustom custom-buffer-sort-predicate 'ignore
"Function used for sorting group members in buffers.
The value should be useful as a predicate for `sort'.
The list to be sorted is the value of the groups `custom-group' property."
:type '(radio (function-item custom-buffer-sort-alphabetically)
:type '(radio (const :tag "Unsorted" ignore)
(const :tag "Alphabetic" custom-sort-items-alphabetically)
(function :tag "Other"))
:group 'customize)
:group 'custom-buffer)
(defun custom-buffer-sort-alphabetically (a b)
"Return t iff is A should be before B.
A and B should be members of a `custom-group' property.
The members are sorted alphabetically, except that all groups are
sorted after all non-groups."
(cond ((and (eq (nth 1 a) 'custom-group)
(not (eq (nth 1 b) 'custom-group)))
nil)
((and (eq (nth 1 b) 'custom-group)
(not (eq (nth 1 a) 'custom-group)))
t)
(t
(string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b))))))
(defcustom custom-buffer-order-predicate 'custom-sort-groups-last
"Function used for sorting group members in buffers.
The value should be useful as a predicate for `sort'.
The list to be sorted is the value of the groups `custom-group' property."
:type '(radio (const :tag "Groups first" custom-sort-groups-first)
(const :tag "Groups last" custom-sort-groups-last)
(function :tag "Other"))
:group 'custom-buffer)
(defcustom custom-menu-sort-predicate 'custom-menu-sort-alphabetically
(defcustom custom-menu-sort-predicate 'ignore
"Function used for sorting group members in menus.
The value should be useful as a predicate for `sort'.
The list to be sorted is the value of the groups `custom-group' property."
:type '(radio (function-item custom-menu-sort-alphabetically)
:type '(radio (const :tag "Unsorted" ignore)
(const :tag "Alphabetic" custom-sort-items-alphabetically)
(function :tag "Other"))
:group 'customize)
:group 'custom-menu)
(defun custom-menu-sort-alphabetically (a b)
"Return t iff is A should be before B.
A and B should be members of a `custom-group' property.
The members are sorted alphabetically, except that all groups are
sorted before all non-groups."
(cond ((and (eq (nth 1 a) 'custom-group)
(not (eq (nth 1 b) 'custom-group)))
t)
((and (eq (nth 1 b) 'custom-group)
(not (eq (nth 1 a) 'custom-group)))
nil)
(t
(string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b))))))
(defcustom custom-menu-order-predicate 'custom-sort-groups-first
"Function used for sorting group members in menus.
The value should be useful as a predicate for `sort'.
The list to be sorted is the value of the groups `custom-group' property."
:type '(radio (const :tag "Groups first" custom-sort-groups-first)
(const :tag "Groups last" custom-sort-groups-last)
(function :tag "Other"))
:group 'custom-menu)
(defun custom-sort-items-alphabetically (a b)
"Return t iff A is alphabetically before B and the same custom type.
A and B should be members of a `custom-group' property."
(and (eq (nth 1 a) (nth 1 b))
(string-lessp (symbol-name (nth 0 a)) (symbol-name (nth 0 b)))))
(defun custom-sort-groups-first (a b)
"Return t iff A a custom group and B is a not.
A and B should be members of a `custom-group' property."
(and (eq (nth 1 a) 'custom-group)
(not (eq (nth 1 b) 'custom-group))))
(defun custom-sort-groups-last (a b)
"Return t iff B a custom group and A is a not.
A and B should be members of a `custom-group' property."
(and (eq (nth 1 b) 'custom-group)
(not (eq (nth 1 a) 'custom-group))))
;;; Custom Mode Commands.
......@@ -897,7 +917,7 @@ that option."
"If non-nil, only show a single reset button in customize buffers.
This button will have a menu with all three reset operations."
:type 'boolean
:group 'customize)
:group 'custom-buffer)
(defun custom-buffer-create-internal (options)
(message "Creating customization buffer...")
......@@ -1017,38 +1037,49 @@ Reset all visible items in this buffer to their standard settings."
;;; The `custom-magic' Widget.
(defgroup custom-magic-faces nil
"Faces used by the magic button."
:group 'custom-faces
:group 'custom-buffer)
(defface custom-invalid-face '((((class color))
(:foreground "yellow" :background "red"))
(t
(:bold t :italic t :underline t)))
"Face used when the customize item is invalid.")
"Face used when the customize item is invalid."
:group 'custom-magic-faces)
(defface custom-rogue-face '((((class color))
(:foreground "pink" :background "black"))
(t
(:underline t)))
"Face used when the customize item is not defined for customization.")
"Face used when the customize item is not defined for customization."
:group 'custom-magic-faces)
(defface custom-modified-face '((((class color))
(:foreground "white" :background "blue"))
(t
(:italic t :bold)))
"Face used when the customize item has been modified.")
"Face used when the customize item has been modified."
:group 'custom-magic-faces)
(defface custom-set-face '((((class color))
(:foreground "blue" :background "white"))
(t
(:italic t)))
"Face used when the customize item has been set.")
"Face used when the customize item has been set."
:group 'custom-magic-faces)
(defface custom-changed-face '((((class color))
(:foreground "white" :background "blue"))
(t
(:italic t)))
"Face used when the customize item has been changed.")
"Face used when the customize item has been changed."
:group 'custom-magic-faces)
(defface custom-saved-face '((t (:underline t)))
"Face used when the customize item has been saved.")
"Face used when the customize item has been saved."
:group 'custom-magic-faces)
(defconst custom-magic-alist '((nil "#" underline "\
uninitialized, you should not see this.")
......@@ -1123,7 +1154,7 @@ If non-nil and not the symbol `long', only show first word."
:type '(choice (const :tag "no" nil)
(const short)
(const long))
:group 'customize)
:group 'custom-buffer)
(defcustom custom-magic-show-hidden '(option face)
"Control whether the state button is shown for hidden items.
......@@ -1131,12 +1162,12 @@ The value should be a list with the custom categories where the state
button should be visible. Possible categories are `group', `option',
and `face'."
:type '(set (const group) (const option) (const face))
:group 'customize)
:group 'custom-buffer)
(defcustom custom-magic-show-button nil
"Show a magic button indicating the state of each customization option."
:type 'boolean
:group 'customize)
:group 'custom-buffer)
(define-widget 'custom-magic 'default
"Show and manipulate state for a customization option."
......@@ -2176,8 +2207,9 @@ and so forth. The remaining group tags are shown with
(custom-load-widget widget)
(let* ((level (widget-get widget :custom-level))
(symbol (widget-value widget))
(members (sort (get symbol 'custom-group)
custom-buffer-sort-predicate))
(members (sort (sort (copy-sequence (get symbol 'custom-group))
custom-buffer-sort-predicate)
custom-buffer-order-predicate))
(prefixes (widget-get widget :custom-prefixes))
(custom-prefix-list (custom-prefix-add symbol prefixes))
(length (length members))
......@@ -2199,7 +2231,6 @@ and so forth. The remaining group tags are shown with
(unless (eq (preceding-char) ?\n)
(widget-insert "\n"))))
members)))
(put symbol 'custom-group members)
(message "Creating group magic...")
(mapcar 'custom-magic-reset children)
(message "Creating group state...")
......@@ -2465,7 +2496,7 @@ Leave point at the location of the call, or after the last expression."
(defcustom custom-menu-nesting 2
"Maximum nesting in custom menus."
:type 'integer
:group 'customize)
:group 'custom-menu)
(defun custom-face-menu-create (widget symbol)
"Ignoring WIDGET, create a menu entry for customization face SYMBOL."
......@@ -2518,9 +2549,9 @@ The menu is in a format applicable to `easy-menu-define'."
(< (length (get symbol 'custom-group)) widget-menu-max-size))
(let ((custom-prefix-list (custom-prefix-add symbol
custom-prefix-list))
(members (sort (get symbol 'custom-group)
custom-menu-sort-predicate)))
(put symbol 'custom-group members)
(members (sort (sort (copy-sequence (get symbol 'custom-group))
custom-menu-sort-predicate)
custom-menu-order-predicate)))
(custom-load-symbol symbol)
`(,(custom-unlispify-menu-entry symbol t)
,item
......@@ -2579,7 +2610,7 @@ The format is suitable for use with `easy-menu-define'."
(defcustom custom-mode-hook nil
"Hook called when entering custom-mode."
:type 'hook
:group 'customize)
:group 'custom-buffer )
(defun custom-mode ()
"Major mode for editing customization buffers.
......
......@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
;; Version: 1.9905
;; Version: 1.9914
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......@@ -282,7 +282,7 @@ With arg, turn widget mode on if and only if arg is positive."
(interactive "P")
(cond ((null arg)
(setq widget-minor-mode (not widget-minor-mode)))
((<= 0 arg)
((<= arg 0)
(setq widget-minor-mode nil))
(t
(setq widget-minor-mode t)))
......
......@@ -4,7 +4,7 @@
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
;; Version: 1.9908
;; Version: 1.9914
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;; This file is part of GNU Emacs.
......@@ -123,17 +123,21 @@ is the string or buffer containing the text."
"http://www.dina.kvl.dk/~abraham/custom/")
:prefix "widget-"
:group 'extensions
:group 'faces
:group 'hypermedia)
(defgroup widget-faces nil
"Faces used by the widget library."
:group 'widgets
:group 'faces)
(defface widget-button-face '((t (:bold t)))
"Face used for widget buttons."
:group 'widgets)
:group 'widget-faces)
(defcustom widget-mouse-face 'highlight
"Face used for widget buttons when the mouse is above them."
:type 'face
:group 'widgets)
:group 'widget-faces)
(defface widget-field-face '((((class grayscale color)
(background light))
......@@ -144,7 +148,7 @@ is the string or buffer containing the text."
(t
(:italic t)))
"Face used for editable fields."
:group 'widgets)
:group 'widget-faces)
;;; Utility functions.
;;
......@@ -347,14 +351,15 @@ minibuffer."
(t
(:italic t)))
"Face used for inactive widgets."
:group 'widgets)
:group 'widget-faces)
(defun widget-specify-inactive (widget from to)
"Make WIDGET inactive for user modifications."
(unless (widget-get widget :inactive)
(let ((overlay (make-overlay from to nil t nil)))
(overlay-put overlay 'face 'widget-inactive-face)
(overlay-put overlay 'mouse-face 'widget-inactive-face)
;; This is disabled, as it makes the mouse cursor change shape.
;; (overlay-put overlay 'mouse-face 'widget-inactive-face)
(overlay-put overlay 'evaporate t)
(overlay-put overlay 'priority 100)
(overlay-put overlay (if (string-match "XEmacs" emacs-version)
......@@ -474,6 +479,26 @@ This is only meaningful for radio buttons or checkboxes in a list."
(throw 'child child)))
nil)))
(defun widget-map-buttons (function &optional buffer maparg)
"Map FUNCTION over the buttons in BUFFER.
FUNCTION is called with the arguments WIDGET and MAPARG.
If FUNCTION returns non-nil, the walk is cancelled.
The arguments MAPARG, and BUFFER default to nil and (current-buffer),
respectively."
(let ((cur (point-min))
(widget nil)
(parent nil)
(overlays (if buffer
(save-excursion (set-buffer buffer) (overlay-lists))
(overlay-lists))))
(setq overlays (append (car overlays) (cdr overlays)))
(while (setq cur (pop overlays))
(setq widget (overlay-get cur 'button))
(if (and widget (funcall function widget maparg))
(setq overlays nil)))))
;;; Glyphs.
(defcustom widget-glyph-directory (concat data-directory "custom/")
......@@ -720,6 +745,31 @@ The optional ARGS are additional keyword arguments."
(apply 'insert args)
(widget-specify-text from (point))))
(defun widget-convert-text (type from to &optional button-from button-to)
"Return a widget of type TYPE with endpoint FROM TO.
No text will be inserted to the buffer, instead the text between FROM
and TO will be used as the widgets end points. If optional arguments
BUTTON-FROM and BUTTON-TO are given, these will be used as the widgets
button end points."
(let ((widget (widget-convert type))
(from (copy-marker from))
(to (copy-marker to)))
(widget-specify-text from to)
(set-marker-insertion-type from t)
(set-marker-insertion-type to nil)
(widget-put widget :from from)
(widget-put widget :to to)
(when button-from
(widget-specify-button widget button-from button-to))
widget))
(defun widget-convert-button (type from to)
"Return a widget of type TYPE with endpoint FROM TO.
No text will be inserted to the buffer, instead the text between FROM
and TO will be used as the widgets end points, as well as the widgets
button end points."
(widget-convert-text type from to from to))
;;; Keymap and Commands.
(defvar widget-keymap nil
......@@ -783,7 +833,7 @@ Recommended as a parent keymap for modes using widgets.")
(t
(:bold t :underline t)))
"Face used for pressed buttons."
:group 'widgets)
:group 'widget-faces)
(defun widget-button-click (event)
"Invoke button below mouse pointer."
......@@ -1017,7 +1067,8 @@ When not inside a field, move to the previous button or field."
widget-field-list (cons field widget-field-list))
(let ((from (car (widget-get field :field-overlay)))
(to (cdr (widget-get field :field-overlay))))
(widget-specify-field field from to)
(widget-specify-field field
(marker-position from) (marker-position to))
(set-marker from nil)
(set-marker to nil))))
(widget-clear-undo)
......@@ -1037,16 +1088,19 @@ When not inside a field, move to the previous button or field."
(defun widget-field-buffer (widget)
"Return the start of WIDGET's editing field."
(overlay-buffer (widget-get widget :field-overlay)))
(let ((overlay (widget-get widget :field-overlay)))
(and overlay (overlay-buffer overlay))))
(defun widget-field-start (widget)
"Return the start of WIDGET's editing field."
(overlay-start (widget-get widget :field-overlay)))
(let ((overlay (widget-get widget :field-overlay)))
(and overlay (overlay-start overlay))))
(defun widget-field-end (widget)
"Return the end of WIDGET's editing field."
;; Don't subtract one if local-map works at the end of the overlay.
(1- (overlay-end (widget-get widget :field-overlay))))
(let ((overlay (widget-get widget :field-overlay)))
;; Don't subtract one if local-map works at the end of the overlay.
(and overlay (1- (overlay-end overlay)))))
(defun widget-field-find (pos)
"Return the field at POS.
......@@ -1253,32 +1307,34 @@ If that does not exists, call the value of `widget-complete-field'."
(defun widget-default-format-handler (widget escape)
;; We recognize the %h escape by default.
(let* ((buttons (widget-get widget :buttons))
(doc-property (widget-get widget :documentation-property))
(doc-try (cond ((widget-get widget :doc))
((symbolp doc-property)
(documentation-property (widget-get widget :value)
doc-property))
(t
(funcall doc-property (widget-get widget :value)))))
(doc-text (and (stringp doc-try)
(> (length doc-try) 1)
doc-try)))
(let* ((buttons (widget-get widget :buttons)))
(cond ((eq escape ?h)
(when doc-text
(and (eq (preceding-char) ?\n)
(widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
;; The `*' in the beginning is redundant.
(when (eq (aref doc-text 0) ?*)
(setq doc-text (substring doc-text 1)))
;; Get rid of trailing newlines.
(when (string-match "\n+\\'" doc-text)
(setq doc-text (substring doc-text 0 (match-beginning 0))))
(push (widget-create-child-and-convert
widget 'documentation-string
doc-text)
buttons)))
(let* ((doc-property (widget-get widget :documentation-property))
(doc-try (cond ((widget-get widget :doc))
((symbolp doc-property)
(documentation-property
(widget-get widget :value)
doc-property))
(t
(funcall doc-property
(widget-get widget :value)))))
(doc-text (and (stringp doc-try)
(> (length doc-try) 1)
doc-try)))
(when doc-text
(and (eq (preceding-char) ?\n)
(widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
;; The `*' in the beginning is redundant.
(when (eq (aref doc-text 0) ?*)
(setq doc-text (substring doc-text 1)))
;; Get rid of trailing newlines.
(when (string-match "\n+\\'" doc-text)
(setq doc-text (substring doc-text 0 (match-beginning 0))))
(push (widget-create-child-and-convert
widget 'documentation-string
doc-text)
buttons))))
(t
(error "Unknown escape `%c'" escape)))
(widget-put widget :buttons buttons)))
......@@ -2476,7 +2532,7 @@ when he invoked the menu."
(:foreground "dark green"))
(t nil))
"Face used for documentation text."
:group 'widgets)
:group 'widget-faces)
(define-widget 'documentation-string 'item
"A documentation string."
......@@ -2488,11 +2544,11 @@ when he invoked the menu."
(defun widget-documentation-string-value-create (widget)
;; Insert documentation string.
(let ((doc (widget-value widget))
(shown (widget-get (widget-get widget :parent) :documentation-shown)))
(shown (widget-get (widget-get widget :parent) :documentation-shown))
(start (point)))
(if (string-match "\n" doc)
(let ((before (substring doc 0 (match-beginning 0)))
(after (substring doc (match-beginning 0)))
(start (point))
buttons)
(insert before " ")
(widget-specify-doc widget start (point))
......@@ -2507,7 +2563,8 @@ when he invoked the menu."
(insert after)
(widget-specify-doc widget start (point)))
(widget-put widget :buttons buttons))
(insert doc)))
(insert doc)
(widget-specify-doc widget start (point))))
(insert "\n"))
(defun widget-documentation-string-action (widget &rest ignore)
......@@ -2666,6 +2723,41 @@ It will read a directory name from the minibuffer when invoked."
:prompt-history 'widget-variable-prompt-value-history
:tag "Variable")
(when (featurep 'mule)
(defvar widget-coding-system-prompt-value-history nil
"History of input to `widget-coding-system-prompt-value'.")
(define-widget 'coding-system 'symbol
"A MULE coding-system."
:format "%{%t%}: %v"
:tag "Coding system"
:prompt-history 'widget-coding-system-prompt-value-history
:prompt-value 'widget-coding-system-prompt-value
:action 'widget-coding-system-action)
(defun widget-coding-system-prompt-value (widget prompt value unbound)
;; Read coding-system from minibuffer.
(intern
(completing-read (format "%s (default %s) " prompt value)
(mapcar (function
(lambda (sym)
(list (symbol-name sym))
))
(coding-system-list)))))
(defun widget-coding-system-action (widget &optional event)
;; Read a file name from the minibuffer.
(let ((answer
(widget-coding-system-prompt-value
widget
(widget-apply widget :menu-tag-get)
(widget-value widget)
t)))
(widget-value-set widget answer)
(widget-apply widget :notify widget event)
(widget-setup)))
)
(define-widget 'sexp 'editable-field
"An arbitrary lisp expression."
:tag "Lisp expression"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment