+Sun Mar 9 01:51:16 1997 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
+
+ * gnus.el: Gnus v5.4.24 is released.
+
+Sun Mar 9 00:52:47 1997 Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+
+ * gnus-sum.el (gnus-summary-set-local-parameters): Ignore errors.
+
+Sat Mar 8 08:55:52 1997 Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
+
+ * gnus-art.el (gnus-article-prev-page): Return a proper value.
+
+ * gnus-sum.el (gnus-summary-prev-page-or-article): New command.
+ * gnus-xmas.el (gnus-summary-toolbar): Use it.
+
Sat Mar 8 08:34:22 1997 Lars Magne Ingebrigtsen <larsi@menja.ifi.uio.no>
* gnus.el: Gnus v5.4.23 is released.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 1.55
+;; Version: 1.59
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
(define-widget-keywords :custom-prefixes :custom-menu :custom-show
:custom-magic :custom-state :custom-level :custom-form
- :custom-set :custom-save :custom-reset-current :custom-reset-saved
+ :custom-set :custom-save :custom-reset-current :custom-reset-saved
:custom-reset-factory)
;;; Customization Groups.
(defgroup customize '((widgets custom-group))
"Customization of the Customization support."
:link '(custom-manual "(custom)Top")
- :link '(url-link :tag "Development Page"
+ :link '(url-link :tag "Development Page"
"http://www.dina.kvl.dk/~abraham/custom/")
:prefix "custom-"
:group 'help
(defun custom-split-regexp-maybe (regexp)
"If REGEXP is a string, split it to a list at `\\|'.
-You can get the original back with from the result with:
+You can get the original back with from the result with:
(mapconcat 'identity result \"\\|\")
IF REGEXP is not a string, return it unchanged."
(while prefixes
(setq prefix (car prefixes))
(if (search-forward prefix (+ (point) (length prefix)) t)
- (progn
+ (progn
(setq prefixes nil)
(delete-region (point-min) (point)))
(setq prefixes (cdr prefixes)))))
(subst-char-in-region (point-min) (point-max) ?- ?\ t)
(capitalize-region (point-min) (point-max))
- (unless no-suffix
+ (unless no-suffix
(goto-char (point-max))
(insert "..."))
(buffer-string)))))
(defvar custom-mode-map nil
"Keymap for `custom-mode'.")
-
+
(unless custom-mode-map
(setq custom-mode-map (make-sparse-keymap))
(set-keymap-parent custom-mode-map widget-keymap)
(define-key custom-mode-map "q" 'bury-buffer))
-(easy-menu-define custom-mode-menu
+(easy-menu-define custom-mode-menu
custom-mode-map
"Menu used in customization buffers."
'("Custom"
\\[widget-button-press] Activate button under point.
\\[custom-set] Set all modifications.
\\[custom-save] Make all modifications default.
-\\[custom-reset-current] Reset all modified options.
+\\[custom-reset-current] Reset all modified options.
\\[custom-reset-saved] Reset all modified or set options.
\\[custom-reset-factory] Reset all options.
children))
(custom-save-all))
-(defvar custom-reset-menu
+(defvar custom-reset-menu
'(("Current" . custom-reset-current)
("Saved" . custom-reset-saved)
("Factory Settings" . custom-reset-factory))
(defun customize (symbol)
"Customize SYMBOL, which must be a customization group."
(interactive (list (completing-read "Customize group: (default emacs) "
- obarray
+ obarray
(lambda (symbol)
(get symbol 'custom-group))
t)))
(let ((v (variable-at-point))
(enable-recursive-minibuffers t)
val)
- (setq val (completing-read
+ (setq val (completing-read
(if v
(format "Customize variable (default %s): " v)
"Customize variable: ")
(defun customize-face (&optional symbol)
"Customize SYMBOL, which should be a face name or nil.
If SYMBOL is nil, customize all faces."
- (interactive (list (completing-read "Customize face: (default all) "
+ (interactive (list (completing-read "Customize face: (default all) "
obarray 'custom-facep)))
(if (or (null symbol) (and (stringp symbol) (zerop (length symbol))))
(let ((found nil))
(boundp symbol)
(setq found
(cons (list symbol 'custom-variable) found)))))
- (if found
+ (if found
(custom-buffer-create found)
(error "No customized user options"))))
(user-variable-p symbol))))
(setq found
(cons (list symbol 'custom-variable) found))))))
- (if found
+ (if found
(custom-buffer-create found)
(error "No matches"))))
(custom-mode)
(widget-insert "This is a customization buffer.
Push RET or click mouse-2 on the word ")
- (widget-create 'info-link
+ (widget-create 'info-link
:tag "help"
- :help-echo "Push me for help."
+ :help-echo "Read the online help."
"(custom)The Customization Buffer")
(widget-insert " for more information.\n\n")
- (setq custom-options
+ (setq custom-options
(mapcar (lambda (entry)
- (prog1
+ (prog1
(if (> (length options) 1)
(widget-create (nth 1 entry)
:tag (custom-unlispify-tag-name
(mapcar 'custom-magic-reset custom-options)
(widget-create 'push-button
:tag "Set"
- :help-echo "Push me to set all modifications."
+ :help-echo "Set all modifications for this session."
:action (lambda (widget &optional event)
(custom-set)))
(widget-insert " ")
(widget-create 'push-button
:tag "Save"
- :help-echo "Push me to make the modifications default."
+ :help-echo "\
+Make the modifications default for future sessions."
:action (lambda (widget &optional event)
(custom-save)))
(widget-insert " ")
(widget-create 'push-button
:tag "Reset"
- :help-echo "Push me to undo all modifications."
+ :help-echo "Undo all modifications."
:action (lambda (widget &optional event)
(custom-reset event)))
(widget-insert " ")
(widget-create 'push-button
:tag "Done"
- :help-echo "Push me to bury the buffer."
+ :help-echo "Bury the buffer."
:action (lambda (widget &optional event)
(bury-buffer)
;; Steal button release event.
(when (memq 'down (event-modifiers event))
(read-event)))))
(widget-insert "\n")
- (widget-setup))
+ (widget-setup)
+ (goto-char (point-min)))
;;; Modification of Basic Widgets.
;;
(define-widget 'custom-manual 'info-link
"Link to the manual entry for this customization option."
- :help-echo "Push me to read the manual."
+ :help-echo "Read the manual entry for this option."
:tag "Manual")
;;; The `custom-magic' Widget.
(:underline t)))
"Face used when the customize item is not defined for customization.")
-(defface custom-modified-face '((((class color))
+(defface custom-modified-face '((((class color))
(:foreground "white" :background "blue"))
(t
(:italic t :bold)))
"Face used when the customize item has been modified.")
-(defface custom-set-face '((((class color))
+(defface custom-set-face '((((class color))
(:foreground "blue" :background "white"))
(t
(:italic t)))
"Face used when the customize item has been set.")
-(defface custom-changed-face '((((class color))
+(defface custom-changed-face '((((class color))
(:foreground "white" :background "blue"))
(t
(:italic t)))
(factory " " nil "\
this item is unchanged from its factory setting."))
"Alist of customize option states.
-Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where
+Each entry is of the form (STATE MAGIC FACE DESCRIPTION), where
STATE is one of the following symbols:
`unknown'
For internal use, should never occur.
`hidden'
- This item is not being displayed.
+ This item is not being displayed.
`invalid'
This item is modified, but has an invalid form.
`modified'
:type '(list (checklist :inline t
(group (const nil)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const unknown)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const hidden)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const invalid)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const modified)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const set)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const changed)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const saved)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const rogue)
(string :tag "Magic")
- face
+ face
(string :tag "Description"))
(group (const factory)
(string :tag "Magic")
- face
+ face
(string :tag "Description")))
(editable-list :inline t
(group symbol
(lisp (eq (widget-get parent :custom-form) 'lisp))
children)
(when custom-magic-show
- (push (widget-create-child-and-convert widget 'choice-item
+ (push (widget-create-child-and-convert widget 'choice-item
:help-echo "\
-Push me to change the state of this item."
+Change the state of this item."
:format "%[%t%]"
:tag "State")
children)
(if (eq custom-magic-show 'long)
(insert text)
(insert (symbol-name state)))
- (when lisp
+ (when lisp
(insert " (lisp)"))
(insert "\n"))
(when custom-magic-show-button
(let ((indent (widget-get parent :indent)))
(when indent
(insert-char ? indent))))
- (push (widget-create-child-and-convert widget 'choice-item
+ (push (widget-create-child-and-convert widget 'choice-item
:button-face face
- :help-echo "\
-Push me to change the state."
+ :help-echo "Change the state."
:format "%[%t%]"
- :tag (if lisp
+ :tag (if lisp
(concat "(" magic ")")
(concat "[" magic "]")))
children)
(define-widget 'custom-level 'item
"The custom level buttons."
:format "%[%t%]"
- :help-echo "Push me to expand or collapse this item."
+ :help-echo "Expand or collapse this item."
:action 'custom-level-action)
(defun custom-level-action (widget &optional event)
(defun custom-convert-widget (widget)
;; Initialize :value and :tag from :args in WIDGET.
(let ((args (widget-get widget :args)))
- (when args
+ (when args
(widget-put widget :value (widget-apply widget
:value-to-internal (car args)))
(widget-put widget :tag (custom-unlispify-tag-name (car args)))
(state (widget-get widget :custom-state))
(level (widget-get widget :custom-level)))
(cond ((eq escape ?l)
- (when level
+ (when level
(push (widget-create-child-and-convert
widget 'custom-level (make-string level ?*))
buttons)
(if many
(insert ", and ")
(insert " and ")))
- (t
+ (t
(insert ", "))))
(widget-put widget :buttons buttons))))
- (t
+ (t
(widget-default-format-handler widget escape)))))
(defun custom-notify (widget &rest args)
"Keep track of changes."
- (widget-put widget :custom-state 'modified)
+ (unless (memq (widget-get widget :custom-state) '(nil unknown hidden))
+ (widget-put widget :custom-state 'modified))
(let ((buffer-undo-list t))
(custom-magic-reset widget))
(apply 'widget-default-notify widget args))
(defun custom-redraw-magic (widget)
"Redraw WIDGET state with current settings."
- (while widget
+ (while widget
(let ((magic (widget-get widget :custom-magic)))
- (unless magic
+ (unless magic
(debug))
(widget-value-set magic (widget-value magic))
(when (setq widget (widget-get widget :group))
(define-widget 'custom-variable 'custom
"Customize variable."
:format "%l%v%m%h%a"
- :help-echo "Push me to set or reset this variable."
+ :help-echo "Set or reset this variable."
:documentation-property 'variable-documentation
:custom-state nil
:custom-menu 'custom-variable-menu-create
;; Now we can create the child widget.
(cond ((eq state 'hidden)
;; Indicate hidden value.
- (push (widget-create-child-and-convert
+ (push (widget-create-child-and-convert
widget 'item
:format "%{%t%}: ..."
:sample-face 'custom-variable-sample-face
(custom-quote (default-value symbol)))
(t
(custom-quote (widget-get conv :value))))))
- (push (widget-create-child-and-convert
- widget 'sexp
+ (push (widget-create-child-and-convert
+ widget 'sexp
:button-face 'custom-variable-button-face
:tag (symbol-name symbol)
:parent widget
(t
;; Edit mode.
(push (widget-create-child-and-convert
- widget type
+ widget type
:tag tag
:button-face 'custom-variable-button-face
:sample-face 'custom-variable-sample-face
(if (eq state 'hidden)
(widget-put widget :custom-state state)
(custom-variable-state-set widget))
- (widget-put widget :custom-form form)
+ (widget-put widget :custom-form form)
(widget-put widget :buttons buttons)
(widget-put widget :children children)))
(t 'rogue))))
(widget-put widget :custom-state state)))
-(defvar custom-variable-menu
+(defvar custom-variable-menu
'(("Edit" . custom-variable-edit)
("Edit Lisp" . custom-variable-edit-lisp)
("Set" . custom-variable-set)
"Show the menu for `custom-variable' WIDGET.
Optional EVENT is the location for the menu."
(if (eq (widget-get widget :custom-state) 'hidden)
- (progn
+ (progn
(widget-put widget :custom-state 'unknown)
(custom-redraw widget))
(let* ((completion-ignore-case t)
;;; The `custom-face-edit' Widget.
-(defvar custom-face-edit-args
- (mapcar (lambda (att)
- (list 'group
- :inline t
- (list 'const :format "" :value (nth 0 att))
- (nth 1 att)))
- custom-face-attributes))
-
(define-widget 'custom-face-edit 'checklist
"Edit face attributes."
:format "%t: %v"
:tag "Attributes"
:extra-offset 12
+ :button-args '(:help-echo "Control whether this attribute have any effect.")
:args (mapcar (lambda (att)
- (list 'group
+ (list 'group
:inline t
- (list 'const :format "" :value (nth 0 att))
+ :sibling-args (widget-get (nth 1 att) :sibling-args)
+ (list 'const :format "" :value (nth 0 att))
(nth 1 att)))
custom-face-attributes))
"Select a display type."
:tag "Display"
:value t
+ :help-echo "Specify frames where the face attributes should be used."
:args '((const :tag "all" t)
- (checklist :offset 0
- :extra-offset 9
- :args ((group (const :format "Type: " type)
- (checklist :inline t
- :offset 0
- (const :format "X "
- x)
- (const :format "PM "
- pm)
- (const :format "Win32 "
- win32)
- (const :format "DOS "
- pc)
- (const :format "TTY%n"
- tty)))
- (group (const :format "Class: " class)
- (checklist :inline t
- :offset 0
- (const :format "Color "
- color)
- (const :format
- "Grayscale "
- grayscale)
- (const :format "Monochrome%n"
- mono)))
- (group (const :format "Background: " background)
- (checklist :inline t
- :offset 0
- (const :format "Light "
- light)
- (const :format "Dark\n"
- dark)))))))
+ (checklist
+ :offset 0
+ :extra-offset 9
+ :args ((group :sibling-args (:help-echo "\
+Only match the specified window systems.")
+ (const :format "Type: "
+ type)
+ (checklist :inline t
+ :offset 0
+ (const :format "X "
+ :sibling-args (:help-echo "\
+The X11 Window System.")
+ x)
+ (const :format "PM "
+ :sibling-args (:help-echo "\
+OS/2 Presentation Manager.")
+ pm)
+ (const :format "Win32 "
+ :sibling-args (:help-echo "\
+Windows NT/95/97.")
+ win32)
+ (const :format "DOS "
+ :sibling-args (:help-echo "\
+Plain MS-DOS.")
+ pc)
+ (const :format "TTY%n"
+ :sibling-args (:help-echo "\
+Plain text terminals.")
+ tty)))
+ (group :sibling-args (:help-echo "\
+Only match the frames with the specified color support.")
+ (const :format "Class: "
+ class)
+ (checklist :inline t
+ :offset 0
+ (const :format "Color "
+ :sibling-args (:help-echo "\
+Match color frames.")
+ color)
+ (const :format "Grayscale "
+ :sibling-args (:help-echo "\
+Match grayscale frames.")
+ grayscale)
+ (const :format "Monochrome%n"
+ :sibling-args (:help-echo "\
+Match frames with no color support.")
+ mono)))
+ (group :sibling-args (:help-echo "\
+Only match frames with the specified intensity.")
+ (const :format "\
+Background brightness: "
+ background)
+ (checklist :inline t
+ :offset 0
+ (const :format "Light "
+ :sibling-args (:help-echo "\
+Match frames with light backgrounds.")
+ light)
+ (const :format "Dark\n"
+ :sibling-args (:help-echo "\
+Match frames with dark backgrounds.")
+ dark)))))))
;;; The `custom-face' Widget.
:format "%l%{%t%}: %s%m%h%a%v"
:format-handler 'custom-face-format-handler
:sample-face 'custom-face-tag-face
- :help-echo "Push me to set or reset this face."
+ :help-echo "Set or reset this face."
:documentation-property '(lambda (face)
(face-doc-string face))
:value-create 'custom-face-value-create
;; XEmacs cannot display initialized faces.
(not (custom-facep symbol))
(copy-face 'custom-face-empty symbol))
- (setq child (widget-create-child-and-convert
+ (setq child (widget-create-child-and-convert
widget 'item
:format "(%{%t%})\n"
:sample-face symbol
:tag "sample")))
- (t
+ (t
(custom-format-handler widget escape)))
(when child
(widget-put widget
:entry-format "%i %d %v"
:value (or (get symbol 'saved-face)
(get symbol 'factory-face))
+ :insert-button-args '(:help-echo "\
+Insert new display specification here.")
+ :append-button-args '(:help-echo "\
+Append new display specification here.")
+ :delete-button-args '(:help-echo "\
+Delete this display specification.")
'(group :format "%v"
custom-display custom-face-edit))))
(custom-face-state-set widget)
(widget-put widget :children (list edit)))))
-(defvar custom-face-menu
+(defvar custom-face-menu
'(("Set" . custom-face-set)
("Save" . custom-face-save)
("Reset to Saved" . custom-face-reset-saved)
'saved)
((get symbol 'factory-face)
'factory)
- (t
+ (t
'rogue)))))
(defun custom-face-action (widget &optional event)
"Show the menu for `custom-face' WIDGET.
Optional EVENT is the location for the menu."
(if (eq (widget-get widget :custom-state) 'hidden)
- (progn
+ (progn
(widget-put widget :custom-state 'unknown)
(custom-redraw widget))
(let* ((completion-ignore-case t)
(mapcar (lambda (face)
(list (symbol-name face)))
(face-list))
- nil nil nil
+ nil nil nil
'face-history)))
(unless (zerop (length answer))
(widget-value-set widget (intern answer))
(defun custom-hook-convert-widget (widget)
;; Handle `:custom-options'.
(let* ((options (widget-get widget :options))
- (other `(editable-list :inline t
+ (other `(editable-list :inline t
:entry-format "%i %d%v"
(function :format " %v")))
(args (if options
:format "%l%{%t%}:%L\n%m%h%a%v"
:sample-face-get 'custom-group-sample-face-get
:documentation-property 'group-documentation
- :help-echo "Push me to set or reset all members of this group."
+ :help-echo "Set or reset all members of this group."
:value-create 'custom-group-value-create
:action 'custom-group-action
:custom-set 'custom-group-set
(widget-put widget :children children)
(custom-group-state-update widget)))))
-(defvar custom-group-menu
+(defvar custom-group-menu
'(("Set" . custom-group-set)
("Save" . custom-group-save)
("Reset to Current" . custom-group-reset-current)
"Show the menu for `custom-group' WIDGET.
Optional EVENT is the location for the menu."
(if (eq (widget-get widget :custom-state) 'hidden)
- (progn
+ (progn
(widget-put widget :custom-state 'unknown)
(custom-redraw widget))
(let* ((completion-ignore-case t)
(defun custom-menu-create (symbol &optional name)
"Create menu for customization group SYMBOL.
-If optional NAME is given, use that as the name of the menu.
+If optional NAME is given, use that as the name of the menu.
Otherwise make up a name from SYMBOL.
The menu is in a format applicable to `easy-menu-define'."
(unless name
,(widget-apply '(custom-group) :custom-menu 'emacs)
,@(cdr (cdr custom-help-menu)))))
(if (fboundp 'add-submenu)
- (add-submenu '("Help") menu)
+ (add-submenu '("Options") menu)
(define-key global-map [menu-bar help-menu customize-menu]
(cons (car menu) (easy-menu-create-keymaps (car menu) (cdr menu)))))))
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 1.55
+;; Version: 1.59
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
(require 'custom)
+(eval-and-compile (require 'cl))
+
;;; Compatibility.
-(unless (fboundp 'frame-property)
- ;; XEmacs function missing in Emacs 19.34.
- (defun frame-property (frame property &optional default)
- "Return FRAME's value for property PROPERTY."
- (or (cdr (assq property (frame-parameters frame)))
- default)))
-
-(unless (fboundp 'face-doc-string)
- ;; XEmacs function missing in Emacs.
- (defun face-doc-string (face)
- "Get the documentation string for FACE."
- (get face 'face-doc-string)))
-
-(unless (fboundp 'set-face-doc-string)
- ;; XEmacs function missing in Emacs.
- (defun set-face-doc-string (face string)
- "Set the documentation string for FACE to STRING."
- (put face 'face-doc-string string)))
+(eval-and-compile
+ (unless (fboundp 'frame-property)
+ ;; XEmacs function missing in Emacs 19.34.
+ (defun frame-property (frame property &optional default)
+ "Return FRAME's value for property PROPERTY."
+ (or (cdr (assq property (frame-parameters frame)))
+ default)))
+
+ (unless (fboundp 'face-doc-string)
+ ;; XEmacs function missing in Emacs.
+ (defun face-doc-string (face)
+ "Get the documentation string for FACE."
+ (get face 'face-doc-string)))
+
+ (unless (fboundp 'set-face-doc-string)
+ ;; XEmacs function missing in Emacs.
+ (defun set-face-doc-string (face string)
+ "Set the documentation string for FACE to STRING."
+ (put face 'face-doc-string string))))
(unless (fboundp 'x-color-values)
;; Emacs function missing in XEmacs 19.14.
If FRAME is omitted or nil, use the selected frame."
(color-instance-rgb-components (make-color-instance color))))
-;; XEmacs and Emacs have different definitions of `facep'.
-;; The Emacs definition is the useful one, so emulate that.
+;; XEmacs and Emacs have different definitions of `facep'.
+;; The Emacs definition is the useful one, so emulate that.
(cond ((not (fboundp 'facep))
- (defun custom-facep (face)
+ (defun custom-facep (face)
"No faces"
nil))
((string-match "XEmacs" emacs-version)
Does nothing when the variable initialize-face-resources is nil."
(when initialize-face-resources
(make-face-x-resource-internal face frame t))))
- (t
+ (t
;; Too hard to do right on XEmacs.
(defalias 'initialize-face-resources 'ignore)))
-(unless (fboundp 'reverse-face)
- ;; This should be moved to `faces.el'.
- (if (string-match "XEmacs" emacs-version)
- ;; Xemacs.
- (defun reverse-face (face &optional frame)
- "Swap the foreground and background colors of face FACE.
-If the colors are not specified in the face, use the default colors."
- (interactive (list (read-face-name "Reverse face: ")))
- (let ((fg (color-name (face-foreground face frame) frame))
- (bg (color-name (face-background face frame) frame)))
- (set-face-foreground face bg frame)
- (set-face-background face fg frame)))
- ;; Emacs.
- (defun reverse-face (face &optional frame)
+(if (string-match "XEmacs" emacs-version)
+ ;; Xemacs.
+ (defun custom-invert-face (face &optional frame)
"Swap the foreground and background colors of face FACE.
If the colors are not specified in the face, use the default colors."
(interactive (list (read-face-name "Reverse face: ")))
- (let ((fg (or (face-foreground face frame)
- (face-foreground 'default frame)
- (frame-property (or frame (selected-frame))
- 'foreground-color)
- "black"))
- (bg (or (face-background face frame)
- (face-background 'default frame)
- (frame-property (or frame (selected-frame))
- 'background-color)
- "white")))
+ (let ((fg (color-name (face-foreground face frame) frame))
+ (bg (color-name (face-background face frame) frame)))
(set-face-foreground face bg frame)
- (set-face-background face fg frame)))))
+ (set-face-background face fg frame)))
+ ;; Emacs.
+ (defun custom-invert-face (face &optional frame)
+ "Swap the foreground and background colors of face FACE.
+If the colors are not specified in the face, use the default colors."
+ (interactive (list (read-face-name "Reverse face: ")))
+ (let ((fg (or (face-foreground face frame)
+ (face-foreground 'default frame)
+ (frame-property (or frame (selected-frame))
+ 'foreground-color)
+ "black"))
+ (bg (or (face-background face frame)
+ (face-background 'default frame)
+ (frame-property (or frame (selected-frame))
+ 'background-color)
+ "white")))
+ (set-face-foreground face bg frame)
+ (set-face-background face fg frame))))
(defcustom custom-background-mode nil
"The brightness of the background.
your background is light, or nil (default) if you want Emacs to
examine the brightness for you."
:group 'customize
- :type '(choice (choice-item dark)
+ :type '(choice (choice-item dark)
(choice-item light)
(choice-item :tag "default" nil)))
+(defun custom-background-mode (frame)
+ "Kludge to detect background mode for FRAME."
+ (let* ((bg-resource
+ (condition-case ()
+ (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
+ (error nil)))
+ color
+ (mode (cond (bg-resource
+ (intern (downcase bg-resource)))
+ ((and (setq color (condition-case ()
+ (or (frame-property
+ frame
+ 'background-color)
+ (color-instance-name
+ (specifier-instance
+ (face-background 'default))))
+ (error nil)))
+ (or (string-match "XEmacs" emacs-version)
+ window-system)
+ (< (apply '+ (x-color-values color))
+ (/ (apply '+ (x-color-values "white"))
+ 3)))
+ 'dark)
+ (t 'light))))
+ (modify-frame-parameters frame (list (cons 'background-mode mode)))
+ mode))
+
(eval-and-compile
(if (string-match "XEmacs" emacs-version)
;; XEmacs.
'class (frame-property frame 'display-type)
'background (or custom-background-mode
(frame-property frame 'background-mode)
- (custom-background-mode frame))))))
-
-(defconst custom-face-attributes
- '((:bold (toggle :format "Bold: %[%v%]\n") custom-set-face-bold)
- (:italic (toggle :format "Italic: %[%v%]\n") custom-set-face-italic)
- (:underline
- (toggle :format "Underline: %[%v%]\n") set-face-underline-p)
- (:foreground (color :tag "Foreground") set-face-foreground)
- (:background (color :tag "Background") set-face-background)
- (:reverse (const :format "Reverse Video\n" t)
- (lambda (face value &optional frame)
- ;; We don't use VALUE.
- (reverse-face face frame)))
- (:stipple (editable-field :format "Stipple: %v") set-face-stipple))
- "Alist of face attributes.
-
-The elements are of the form (KEY TYPE SET) where KEY is a symbol
-identifying the attribute, TYPE is a widget type for editing the
-attibute, SET is a function for setting the attribute value.
-
-The SET function should take three arguments, the face to modify, the
-value of the attribute, and optionally the frame where the face should
-be changed.")
+ (custom-background-mode frame))))))
;;; Declaring a face.
;;; Font Attributes.
-(defun custom-face-attribites-set (face frame &rest atts)
+(defconst custom-face-attributes
+ '((:bold (toggle :format "Bold: %[%v%]\n"
+ :help-echo "Control whether a bold font should be used.")
+ custom-set-face-bold)
+ (:italic (toggle :format "Italic: %[%v%]\n"
+ :help-echo "\
+Control whether an italic font should be used.")
+ custom-set-face-italic)
+ (:underline (toggle :format "Underline: %[%v%]\n"
+ :help-echo "\
+Control whether the text should be underlined.")
+ set-face-underline-p)
+ (:foreground (color :tag "Foreground"
+ :help-echo "Set foreground color.")
+ set-face-foreground)
+ (:background (color :tag "Background"
+ :help-echo "Set background color.")
+ set-face-background)
+ (:invert (const :format "Invert Face\n"
+ :sibling-args (:help-echo "\
+Reverse the foreground and background color.
+If you haven't specified them for the face, the default colors will be used.")
+ t)
+ (lambda (face value &optional frame)
+ ;; We don't use VALUE.
+ (custom-invert-face face frame)))
+ (:stipple (editable-field :format "Stipple: %v"
+ :help-echo "Name of background bitmap file.")
+ set-face-stipple))
+ "Alist of face attributes.
+
+The elements are of the form (KEY TYPE SET) where KEY is a symbol
+identifying the attribute, TYPE is a widget type for editing the
+attibute, SET is a function for setting the attribute value.
+
+The SET function should take three arguments, the face to modify, the
+value of the attribute, and optionally the frame where the face should
+be changed.")
+
+(defun custom-face-attributes-set (face frame &rest atts)
"For FACE on FRAME set the attributes [KEYWORD VALUE]....
Each keyword should be listed in `custom-face-attributes'.
If FRAME is nil, set the default face."
- (while atts
+ (while atts
(let* ((name (nth 0 atts))
(value (nth 1 atts))
(fun (nth 2 (assq name custom-face-attributes))))
(apply 'set-face-font face fontobj args)))
(nconc custom-face-attributes
- '((:family (editable-field :format "Family: %v")
+ '((:family (editable-field :format "Font Family: %v"
+ :help-echo "\
+Name of font family to use (e.g. times).")
custom-set-face-font-family)
- (:size (editable-field :format "Size: %v")
+ (:size (editable-field :format "Size: %v"
+ :help-echo "\
+Text size (e.g. 9pt or 2mm).")
custom-set-face-font-size))))
;;; Frames.
Iff optional FRAME is non-nil, set it for that frame only.
See `defface' for information about SPEC."
(when (fboundp 'make-face)
- (while spec
+ (while spec
(let* ((entry (car spec))
(display (nth 0 entry))
(atts (nth 1 entry)))
(when (custom-display-match-frame display frame)
;; Avoid creating frame local duplicates of the global face.
(unless (and frame (eq display (get face 'custom-face-display)))
- (apply 'custom-face-attribites-set face frame atts))
+ (apply 'custom-face-attributes-set face frame atts))
(unless frame
(put face 'custom-face-display display))
(setq spec nil))))))
-(defun custom-background-mode (frame)
- "Kludge to detect background mode for FRAME."
- (let* ((bg-resource
- (condition-case ()
- (x-get-resource ".backgroundMode" "BackgroundMode" 'string)
- (error nil)))
- color
- (mode (cond (bg-resource
- (intern (downcase bg-resource)))
- ((and (setq color (condition-case ()
- (or (frame-property
- frame
- 'background-color)
- (color-instance-name
- (specifier-instance
- (face-background 'default))))
- (error nil)))
- (or (string-match "XEmacs" emacs-version)
- window-system)
- (< (apply '+ (x-color-values color))
- (/ (apply '+ (x-color-values "white"))
- 3)))
- 'dark)
- (t 'light))))
- (modify-frame-parameters frame (list (cons 'background-mode mode)))
- mode))
-
(defvar custom-default-frame-properties nil
"The frame properties used for the global faces.
Frames who doesn't match these propertiess should have frame local faces.
-The value should be nil, if uninitialized, or a plist otherwise.
+The value should be nil, if uninitialized, or a plist otherwise.
See `defface' for a list of valid keys and values for the plist.")
(defun custom-get-frame-properties (&optional frame)
;; Oh well, get it then.
(setq cache (custom-extract-frame-properties frame))
;; and cache it...
- (modify-frame-parameters frame
+ (modify-frame-parameters frame
(list (cons 'custom-properties cache))))
cache))
(custom-default-frame-properties)
((eq req 'background)
(memq background options))
(t
- (error "Unknown req `%S' with options `%S'"
+ (error "Unknown req `%S' with options `%S'"
req options)))))
match)))
(mapcar (lambda (symbol)
(let ((spec (or (get symbol 'saved-face)
(get symbol 'factory-face))))
- (when spec
+ (when spec
(custom-face-display-set symbol spec frame)
(initialize-face-resources symbol frame))))
(face-list)))
If FRAME is missing or nil, the first member (frame-list) is used."
(unless frame
(setq frame (car (frame-list))))
- (unless (equal (custom-get-frame-properties)
+ (unless (equal (custom-get-frame-properties)
(custom-get-frame-properties frame))
(custom-initialize-faces frame)))
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, faces
-;; Version: 1.55
+;; Version: 1.59
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
;;
;; This file only contain the code needed to declare and initialize
;; user options. The code to customize options is autoloaded from
-;; `cus-edit.el'.
+;; `cus-edit.el'.
;; The code implementing face declarations is in `cus-face.el'
(put symbol 'factory-value (list value))
(when doc
(put symbol 'variable-documentation doc))
- (while args
+ (while args
(let ((arg (car args)))
(setq args (cdr args))
(unless (symbolp arg)
If SYMBOL is not already bound, initialize it to VALUE.
The remaining arguments should have the form
- [KEYWORD VALUE]...
+ [KEYWORD VALUE]...
The following KEYWORD's are defined:
:type VALUE should be a widget type.
:options VALUE should be a list of valid members of the widget type.
-:group VALUE should be a customization group.
+:group VALUE should be a customization group.
Add SYMBOL to that group.
Read the section about customization in the emacs lisp manual for more
(put symbol 'custom-group (nconc members (get symbol 'custom-group)))
(when doc
(put symbol 'group-documentation doc))
- (while args
+ (while args
(let ((arg (car args)))
(setq args (cdr args))
(unless (symbolp arg)
The remaining arguments should have the form
- [KEYWORD VALUE]...
+ [KEYWORD VALUE]...
The following KEYWORD's are defined:
(defun custom-handle-all-keywords (symbol args type)
"For customization option SYMBOL, handle keyword arguments ARGS.
Third argument TYPE is the custom option type."
- (while args
+ (while args
(let ((arg (car args)))
(setq args (cdr args))
(unless (symbolp arg)
(unless args
(error "Keyword %s is missing an argument" keyword))
(setq args (cdr args))
- (custom-handle-keyword symbol keyword value type)))))
+ (custom-handle-keyword symbol keyword value type)))))
(defun custom-handle-keyword (symbol keyword value type)
"For customization option SYMBOL, handle KEYWORD with VALUE.
((eq keyword :tag)
(put symbol 'custom-tag value))
(t
- (error "Unknown keyword %s" symbol))))
+ (error "Unknown keyword %s" symbol))))
(defun custom-add-option (symbol option)
"To the variable SYMBOL add OPTION.
;;; Initializing.
(defun custom-set-variables (&rest args)
- "Initialize variables according to user preferences.
+ "Initialize variables according to user preferences.
The arguments should be a list where each entry has the form:
The unevaluated VALUE is stored as the saved value for SYMBOL.
If NOW is present and non-nil, VALUE is also evaluated and bound as
the default value for the SYMBOL."
- (while args
+ (while args
(let ((entry (car args)))
(if (listp entry)
(let ((symbol (nth 0 entry))
(value (nth 1 entry))
(now (nth 2 entry)))
(put symbol 'saved-value (list value))
- (when now
+ (when now
(put symbol 'force-value t)
(set-default symbol (eval value)))
(setq args (cdr args)))
(remove-hook 'custom-define-hook 'custom-menu-reset)
(if (string-match "XEmacs" emacs-version)
(when (fboundp 'add-submenu)
- (add-submenu '("Help") custom-help-menu))
+ (add-submenu '("Options") custom-help-menu))
(define-key global-map [menu-bar help-menu customize-menu]
(cons (car custom-help-menu)
(easy-menu-create-keymaps (car custom-help-menu)
(cdr custom-help-menu))))))
+(unless (string-match "XEmacs" emacs-version)
+ (custom-menu-reset))
+
;;; The End.
(provide 'custom)
(fset 'read-color 'ignore)))
(setq byte-compile-warnings
- '(free-vars unresolved callargs redefine))
+ '(free-vars unresolved callargs redefine obsolete))
(defun dgnushack-compile ()
;;(setq byte-compile-dynamic t)
(recenter -1))
(let ((scroll-in-place nil))
(prog1
- (ignore-errors
- (scroll-down lines))
+ (condition-case ()
+ (scroll-down lines)
+ (beginning-of-buffer
+ (goto-char (point-min))))
(move-to-window-line 0)))))
(defun gnus-article-refer-article ()
(defcustom gnus-nocem-liberal-fetch nil
"*If t try to fetch all messages which have @@NCM in the subject.
-Otherwise don't fetch messages which have references or whose messsage-id
+Otherwise don't fetch messages which have references or whose message-id
matches an previously scanned and verified nocem message."
:group 'gnus-nocem
:type 'boolean)
(symbolp (car elem)) ; Has to be a symbol in there.
(not (memq (car elem)
'(quit-config to-address to-list to-group)))
- (progn ; So we set it.
+ (ignore-errors ; So we set it.
(make-local-variable (car elem))
(set (car elem) (eval (nth 1 elem))))))))
(gnus-set-global-variables)
(let ((article (gnus-summary-article-number))
(article-window (get-buffer-window gnus-article-buffer t))
- (endp nil))
+ endp)
(gnus-configure-windows 'article)
(if (eq (cdr (assq article gnus-newsgroup-reads)) gnus-canceled-mark)
(if (and (eq gnus-summary-goto-unread 'never)
(gnus-summary-recenter)
(gnus-summary-position-point)))
-(defun gnus-summary-prev-page (&optional lines)
+(defun gnus-summary-prev-page (&optional lines move)
"Show previous page of selected article.
-Argument LINES specifies lines to be scrolled down."
+Argument LINES specifies lines to be scrolled down.
+If MOVE, move to the previous unread article if point is at
+the beginning of the buffer."
(interactive "P")
(gnus-set-global-variables)
(let ((article (gnus-summary-article-number))
- (article-window (get-buffer-window gnus-article-buffer t)))
+ (article-window (get-buffer-window gnus-article-buffer t))
+ endp)
(gnus-configure-windows 'article)
(if (or (null gnus-current-article)
(null gnus-article-current)
(gnus-summary-recenter)
(when article-window
(gnus-eval-in-buffer-window gnus-article-buffer
- (gnus-article-prev-page lines)))))
+ (setq endp (gnus-article-prev-page lines)))
+ (when (and move endp)
+ (cond (lines
+ (gnus-message 3 "Beginning of message"))
+ ((null lines)
+ (if (and (eq gnus-summary-goto-unread 'never)
+ (not (gnus-summary-first-article-p article)))
+ (gnus-summary-prev-article)
+ (gnus-summary-prev-unread-article))))))))
(gnus-summary-position-point))
+(defun gnus-summary-prev-page-or-article (&optional lines)
+ "Show previous page of selected article.
+Argument LINES specifies lines to be scrolled down.
+If at the beginning of the article, go to the next article."
+ (interactive "P")
+ (gnus-summary-prev-page lines t))
+
(defun gnus-summary-scroll-up (lines)
"Scroll up (or down) one line current article.
Argument LINES specifies lines to be scrolled up (or down if negative)."
(defvar gnus-summary-toolbar
'([gnus-summary-prev-unread
- gnus-summary-prev-unread-article t "Prev unread article"]
+ gnus-summary-prev-page-or-article t "Page up"]
[gnus-summary-next-unread
- gnus-summary-next-unread-article t "Next unread article"]
+ gnus-summary-next-page t "Page down"]
[gnus-summary-post-news
gnus-summary-post-news t "Post an article"]
[gnus-summary-followup-with-original
:link '(custom-manual "(gnus)Exiting Gnus")
:group 'gnus)
-(defconst gnus-version-number "5.4.23"
+(defconst gnus-version-number "5.4.24"
"Version number for this version of Gnus.")
(defconst gnus-version (format "Gnus v%s" gnus-version-number)
(save-excursion (run-hooks 'nnmail-prepare-incoming-hook))
;; Handle both babyl, MMDF and unix mail formats, since movemail will
;; use the former when fetching from a mailbox, the latter when
- ;; fetches from a file.
+ ;; fetching from a file.
(cond ((or (looking-at "\^L")
(looking-at "BABYL OPTIONS:"))
(nnmail-process-babyl-mail-format func artnum-func))
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 1.55
+;; Version: 1.59
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
(defvar widget-browse-mode-map nil
"Keymap for `widget-browse-mode'.")
-
+
(unless widget-browse-mode-map
(setq widget-browse-mode-map (make-sparse-keymap))
(set-keymap-parent widget-browse-mode-map widget-keymap))
-(easy-menu-define widget-browse-mode-menu
+(easy-menu-define widget-browse-mode-menu
widget-browse-mode-map
"Menu used in widget browser buffers."
'("Widget"
(defun widget-browse (widget)
"Create a widget browser for WIDGET."
- (interactive (list (completing-read "Widget: "
+ (interactive (list (completing-read "Widget: "
obarray
(lambda (symbol)
(get symbol 'widget-type))
(kill-buffer (get-buffer-create "*Browse Widget*"))
(switch-to-buffer (get-buffer-create "*Browse Widget*")))
(widget-browse-mode)
-
+
;; Quick way to get out.
(widget-create 'push-button
:action (lambda (widget &optional event)
:action 'widget-browse-action)
(defun widget-browse-action (widget &optional event)
- ;; Create widget browser for WIDGET's :value.
+ ;; Create widget browser for WIDGET's :value.
(widget-browse (widget-get widget :value)))
(defun widget-browse-value-create (widget)
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: extensions
-;; Version: 1.55
+;; Version: 1.59
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
;;; Code:
(require 'widget)
-(require 'cl)
-(autoload 'pp-to-string "pp")
-(autoload 'Info-goto-node "info")
-
-(if (string-match "XEmacs" emacs-version)
- ;; XEmacs spell `intangible' as `atomic'.
- (defun widget-make-intangible (from to side)
- "Make text between FROM and TO atomic with regard to movement.
+
+(eval-and-compile
+ (require 'cl))
+
+;;; Compatibility.
+
+(eval-and-compile
+ (autoload 'pp-to-string "pp")
+ (autoload 'Info-goto-node "info")
+
+ (if (string-match "XEmacs" emacs-version)
+ ;; XEmacs spell `intangible' as `atomic'.
+ (defun widget-make-intangible (from to side)
+ "Make text between FROM and TO atomic with regard to movement.
Third argument should be `start-open' if it should be sticky to the rear,
and `end-open' if it should sticky to the front."
- (require 'atomic-extents)
- (let ((ext (make-extent from to)))
- ;; XEmacs doesn't understant different kinds of read-only, so
- ;; we have to use extents instead.
- (put-text-property from to 'read-only nil)
- (set-extent-property ext 'read-only t)
- (set-extent-property ext 'start-open nil)
- (set-extent-property ext 'end-open nil)
- (set-extent-property ext side t)
- (set-extent-property ext 'atomic t)))
- (defun widget-make-intangible (from to size)
- "Make text between FROM and TO intangible."
- (put-text-property from to 'intangible 'front)))
-
+ (require 'atomic-extents)
+ (let ((ext (make-extent from to)))
+ ;; XEmacs doesn't understant different kinds of read-only, so
+ ;; we have to use extents instead.
+ (put-text-property from to 'read-only nil)
+ (set-extent-property ext 'read-only t)
+ (set-extent-property ext 'start-open nil)
+ (set-extent-property ext 'end-open nil)
+ (set-extent-property ext side t)
+ (set-extent-property ext 'atomic t)))
+ (defun widget-make-intangible (from to size)
+ "Make text between FROM and TO intangible."
+ (put-text-property from to 'intangible 'front)))
+
;; The following should go away when bundled with Emacs.
-(eval-and-compile
(condition-case ()
(require 'custom)
(error nil))
(unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
;; We have the old custom-library, hack around it!
(defmacro defgroup (&rest args) nil)
- (defmacro defcustom (var value doc &rest args)
+ (defmacro defcustom (var value doc &rest args)
`(defvar ,var ,value ,doc))
(defmacro defface (&rest args) nil)
(define-widget-keywords :prefix :tag :load :link :options :type :group)
(when (fboundp 'copy-face)
(copy-face 'default 'widget-documentation-face)
(copy-face 'bold 'widget-button-face)
- (copy-face 'italic 'widget-field-face))))
+ (copy-face 'italic 'widget-field-face)))
-;;; Compatibility.
-
-(unless (fboundp 'event-point)
- ;; XEmacs function missing in Emacs.
- (defun event-point (event)
- "Return the character position of the given mouse-motion, button-press,
+ (unless (fboundp 'event-point)
+ ;; XEmacs function missing in Emacs.
+ (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))))
+ (posn-point (event-start event))))
-(unless (fboundp 'error-message-string)
- ;; Emacs function missing in XEmacs.
- (defun error-message-string (obj)
- "Convert an error value to an error message."
- (let ((buf (get-buffer-create " *error-message*")))
- (erase-buffer buf)
- (display-error obj buf)
- (buffer-string buf))))
+ (unless (fboundp 'error-message-string)
+ ;; Emacs function missing in XEmacs.
+ (defun error-message-string (obj)
+ "Convert an error value to an error message."
+ (let ((buf (get-buffer-create " *error-message*")))
+ (erase-buffer buf)
+ (display-error obj buf)
+ (buffer-string buf)))))
;;; Customization.
(defgroup widgets nil
"Customization support for the Widget Library."
:link '(custom-manual "(widget)Top")
- :link '(url-link :tag "Development Page"
+ :link '(url-link :tag "Development Page"
"http://www.dina.kvl.dk/~abraham/custom/")
:prefix "widget-"
:group 'extensions
(((class grayscale color)
(background dark))
(:background "dark gray"))
- (t
+ (t
(:italic t)))
"Face used for editable fields."
:group 'widgets)
nil)))
;;; Widget text specifications.
-;;
-;; These functions are for specifying text properties.
+;;
+;; These functions are for specifying text properties.
(defun widget-specify-none (from to)
;; Clear all text properties between FROM and TO.
;; Make it possible to edit the front end of the field.
(add-text-properties (1- from) from (list 'rear-nonsticky t
- 'end-open t
- 'invisible t))
+ 'end-open t
+ 'invisible t))
(when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
(widget-get widget :hide-front-space))
;; WARNING: This is going to lose horrible if the character just
;; choice widget). We try to compensate by checking the format
;; string, and hope the user hasn't changed the :create method.
(widget-make-intangible (- from 2) from 'end-open))
-
+
;; Make it possible to edit back end of the field.
(add-text-properties to (1+ to) (list 'front-sticky nil
'read-only t
;; I tried putting an invisible intangible read-only space
;; before the newline, which gave really weird effects.
;; So for now, we just have trust the user not to delete the
- ;; newline.
+ ;; newline.
(put-text-property to (1+ to) 'read-only nil))))
(defun widget-specify-field-update (widget from to)
(secret-to to)
(size (widget-get widget :size))
(face (or (widget-get widget :value-face)
- 'widget-field-face)))
-
- (when secret
+ 'widget-field-face))
+ (help-echo (widget-get widget :help-echo))
+ (help-property (if (featurep 'balloon-help)
+ 'balloon-help
+ 'help-echo)))
+ (unless (or (stringp help-echo) (null help-echo))
+ (setq help-echo 'widget-mouse-help))
+
+ (when secret
(while (and size
(not (zerop size))
(> secret-to from)
'read-only nil
'keymap map
'local-map map
+ help-property help-echo
'face face))
-
- (when secret
+
+ (when secret
(save-excursion
(goto-char from)
(while (< (point) secret-to)
(unless (widget-get widget :size)
(add-text-properties to (1+ to) (list 'field widget
+ help-property help-echo
'face face)))
(add-text-properties to (1+ to) (list 'local-map map
'keymap map))))
(defun widget-specify-button (widget from to)
;; Specify button for WIDGET between FROM and TO.
- (let ((face (widget-apply widget :button-face-get)))
+ (let ((face (widget-apply widget :button-face-get))
+ (help-echo (widget-get widget :help-echo))
+ (help-property (if (featurep 'balloon-help)
+ 'balloon-help
+ 'help-echo)))
+ (unless (or (null help-echo) (stringp help-echo))
+ (setq help-echo 'widget-mouse-help))
(add-text-properties from to (list 'button widget
'mouse-face widget-mouse-face
'start-open t
'end-open t
+ help-property help-echo
'face face))))
+(defun widget-mouse-help (extent)
+ "Find mouse help string for button in extent."
+ (let* ((widget (widget-at (extent-start-position extent)))
+ (help-echo (and widget (widget-get widget :help-echo))))
+ (cond ((stringp help-echo)
+ help-echo)
+ ((and (symbolp help-echo) (fboundp help-echo)
+ (stringp (setq help-echo (funcall help-echo widget))))
+ help-echo)
+ (t
+ (format "(widget %S :help-echo %S)" widget help-echo)))))
+
(defun widget-specify-sample (widget from to)
;; Specify sample for WIDGET between FROM and TO.
(let ((face (widget-apply widget :sample-face-get)))
missing nil))
((setq tmp (car widget))
(setq widget (get tmp 'widget-type)))
- (t
+ (t
(setq missing nil))))
value))
(defun widget-apply (widget property &rest args)
"Apply the value of WIDGET's PROPERTY to the widget itself.
-ARGS are passed as extra argments to the function."
+ARGS are passed as extra arguments to the function."
(apply (widget-get widget property) widget args))
(defun widget-value (widget)
(widget-glyph-insert-glyph widget tag image))
(t
;; A string. Look it up in.
- (let ((file (concat widget-glyph-directory
+ (let ((file (concat widget-glyph-directory
(if (string-match "/\\'" widget-glyph-directory)
""
"/")
(set-glyph-image glyph (cons 'tty tag))
(set-glyph-property glyph 'widget widget)
(insert "*")
- (add-text-properties (1- (point)) (point)
+ (add-text-properties (1- (point)) (point)
(list 'invisible t
- 'end-glyph glyph)))
+ 'end-glyph glyph))
+ (let ((help-echo (widget-get widget :help-echo)))
+ (when help-echo
+ (let ((extent (extent-at (1- (point)) nil 'end-glyph))
+ (help-property (if (featurep 'balloon-help)
+ 'balloon-help
+ 'help-echo)))
+ (set-extent-property extent help-property (if (stringp help-echo)
+ help-echo
+ 'widget-mouse-help))))))
;;; Creating Widgets.
;;;###autoload
(defun widget-create (type &rest args)
- "Create widget of TYPE.
+ "Create widget of TYPE.
The optional ARGS are additional keyword arguments."
(let ((widget (apply 'widget-convert type args)))
(widget-apply widget :create)
(widget-apply widget :delete))
(defun widget-convert (type &rest args)
- "Convert TYPE to a widget without inserting it in the buffer.
+ "Convert TYPE to a widget without inserting it in the buffer.
The optional ARGS are additional keyword arguments."
;; Don't touch the type.
- (let* ((widget (if (symbolp type)
+ (let* ((widget (if (symbolp type)
(list type)
(copy-list type)))
(current widget)
(setq widget (funcall convert-widget widget))))
(setq type (get (car type) 'widget-type)))
;; Finally set the keyword args.
- (while keys
+ (while keys
(let ((next (nth 0 keys)))
(if (and (symbolp next) (eq (aref (symbol-name next) 0) ?:))
- (progn
+ (progn
(widget-put widget next (nth 1 keys))
(setq keys (nthcdr 2 keys)))
(setq keys nil))))
(apply 'insert args)
(widget-specify-text from (point))))
-;;; Keymap and Comands.
+;;; Keymap and Commands.
(defvar widget-keymap nil
"Keymap containing useful binding for buffers containing widgets.
Recommended as a parent keymap for modes using widgets.")
-(unless widget-keymap
+(unless widget-keymap
(setq widget-keymap (make-sparse-keymap))
(define-key widget-keymap "\C-k" 'widget-kill-line)
(define-key widget-keymap "\t" 'widget-forward)
(define-key widget-keymap [(shift tab)] 'widget-backward)
(define-key widget-keymap [backtab] 'widget-backward)
(if (string-match "XEmacs" (emacs-version))
- (progn
+ (progn
(define-key widget-keymap [button2] 'widget-button-click)
(define-key widget-keymap [button1] 'widget-button1-click))
(define-key widget-keymap [mouse-2] 'ignore)
(defvar widget-field-keymap nil
"Keymap used inside an editable field.")
-(unless widget-field-keymap
+(unless widget-field-keymap
(setq widget-field-keymap (copy-keymap widget-keymap))
(unless (string-match "XEmacs" (emacs-version))
(define-key widget-field-keymap [menu-bar] 'nil))
(defvar widget-text-keymap nil
"Keymap used inside a text field.")
-(unless widget-text-keymap
+(unless widget-text-keymap
(setq widget-text-keymap (copy-keymap widget-keymap))
(unless (string-match "XEmacs" (emacs-version))
(define-key widget-text-keymap [menu-bar] 'nil))
(let ((button (get-text-property (event-point event) 'button)))
(if button
(widget-apply button :action event)
- (call-interactively
+ (call-interactively
(or (lookup-key widget-global-map [ button2 ])
(lookup-key widget-global-map [ down-mouse-2 ])
(lookup-key widget-global-map [ mouse-2]))))))
(defun widget-field-find (pos)
;; Find widget whose editing field is located at POS.
;; Return nil if POS is not inside and editing field.
- ;;
+ ;;
;; This is only used in `widget-field-modified', since ordinarily
;; you would just test the field property.
(let ((fields widget-field-list)
(message "Error: `widget-after-change' called on two fields"))
(t
(let ((size (widget-get field :size)))
- (if size
+ (if size
(let ((begin (1+ (widget-get field :value-from)))
(end (1- (widget-get field :value-to))))
(widget-specify-field-update field begin end)
(save-excursion
(goto-char end)
(insert-char ?\ (- (+ begin size) end))
- (widget-specify-field-update field
+ (widget-specify-field-update field
begin
(+ begin size))))
((> (- end begin) size)
;;; Widget Functions
;;
-;; These functions are used in the definition of multiple widgets.
+;; These functions are used in the definition of multiple widgets.
(defun widget-children-value-delete (widget)
"Delete all :children and :buttons in WIDGET."
:indent nil
:offset 0
:format-handler 'widget-default-format-handler
- :button-face-get 'widget-default-button-face-get
- :sample-face-get 'widget-default-sample-face-get
+ :button-face-get 'widget-default-button-face-get
+ :sample-face-get 'widget-default-sample-face-get
:delete 'widget-default-delete
:value-set 'widget-default-value-set
:value-inline 'widget-default-value-inline
(insert "\n")
(insert-char ? (widget-get widget :indent))))
((eq escape ?t)
- (cond (glyph
+ (cond (glyph
(widget-glyph-insert widget (or tag "image") glyph))
(tag
(insert tag))
(if (and button-begin (not button-end))
(widget-apply widget :value-create)
(setq value-pos (point))))
- (t
+ (t
(widget-apply widget :format-handler escape)))))
;; Specify button, sample, and doc, and insert value.
(and button-begin button-end
(push (if (string-match "\n." doc-text)
;; Allow multiline doc to be hiden.
(widget-create-child-and-convert
- widget 'widget-help
+ widget 'widget-help
:doc (progn
(string-match "\\`.*" doc-text)
(match-string 0 doc-text))
(widget-create-child-and-convert
widget 'item :format "%d" :doc doc-text nil))
buttons)))
- (t
+ (t
(error "Unknown escape `%c'" escape)))
(widget-put widget :buttons buttons)))
(defun widget-item-convert-widget (widget)
;; Initialize :value from :args in WIDGET.
(let ((args (widget-get widget :args)))
- (when args
+ (when args
(widget-put widget :value (widget-apply widget
:value-to-internal (car args)))
(widget-put widget :args nil)))
(fboundp 'device-on-window-system-p)
(device-on-window-system-p)
(string-match "XEmacs" emacs-version))
- (progn
+ (progn
(unless gui
(setq gui (make-gui-button tag 'widget-gui-action widget))
(push (cons tag gui) widget-push-button-cache))
(define-widget 'link 'item
"An embedded link."
- :help-echo "Push me to follow the link."
+ :help-echo "Follow the link."
:format "%[_%t_%]")
;;; The `info-link' Widget.
(invalid (widget-apply widget :validate)))
(when invalid
(error (widget-get invalid :error)))
- (widget-value-set widget
- (widget-apply widget
+ (widget-value-set widget
+ (widget-apply widget
:value-to-external
- (read-string (concat tag ": ")
- (widget-apply
+ (read-string (concat tag ": ")
+ (widget-apply
widget
:value-to-internal
(widget-value widget))
(secret (widget-get widget :secret))
(old (current-buffer)))
(if (and from to)
- (progn
+ (progn
(set-buffer (marker-buffer from))
(setq from (1+ from)
to (1- to))
choices)))
(widget-choose tag (reverse choices) event))))
(when current
- (widget-value-set widget
+ (widget-value-set widget
(widget-apply current :value-to-external
(widget-get current :value)))
(widget-apply widget :notify widget event)
(defun widget-toggle-value-create (widget)
;; Insert text representing the `on' and `off' states.
(if (widget-value widget)
- (widget-glyph-insert widget
- (widget-get widget :on)
+ (widget-glyph-insert widget
+ (widget-get widget :on)
(widget-get widget :on-glyph))
(widget-glyph-insert widget
(widget-get widget :off)
;; Toggle value.
(widget-value-set widget (not (widget-value widget)))
(widget-apply widget :notify widget event))
-
+
;;; The `checkbox' Widget.
(define-widget 'checkbox 'toggle
;; Insert all values
(let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
(args (widget-get widget :args)))
- (while args
+ (while args
(widget-checklist-add-item widget (car args) (assq (car args) alist))
(setq args (cdr args)))
(widget-put widget :children (nreverse (widget-get widget :children)))))
(and (eq (preceding-char) ?\n)
(widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
- (widget-specify-insert
+ (widget-specify-insert
(let* ((children (widget-get widget :children))
(buttons (widget-get widget :buttons))
+ (button-args (or (widget-get type :sibling-args)
+ (widget-get widget :button-args)))
(from (point))
child button)
(insert (widget-get widget :entry-format))
(cond ((eq escape ?%)
(insert "%"))
((eq escape ?b)
- (setq button (widget-create-child-and-convert
- widget 'checkbox :value (not (null chosen)))))
+ (setq button (apply 'widget-create-child-and-convert
+ widget 'checkbox
+ :value (not (null chosen))
+ button-args)))
((eq escape ?v)
(setq child
(cond ((not chosen)
(t
(widget-create-child-value
widget type (car (cdr chosen)))))))
- (t
+ (t
(error "Unknown escape `%c'" escape)))))
;; Update properties.
(and button child (widget-put child :button button))
found rest)
(while values
(let ((answer (widget-checklist-match-up args values)))
- (cond (answer
+ (cond (answer
(let ((vals (widget-match-inline answer values)))
(setq found (append found (car vals))
values (cdr vals)
(greedy
(setq rest (append rest (list (car values)))
values (cdr values)))
- (t
+ (t
(setq rest (append rest values)
values nil)))))
(cons found rest)))
found)
(while vals
(let ((answer (widget-checklist-match-up args vals)))
- (cond (answer
+ (cond (answer
(let ((match (widget-match-inline answer vals)))
(setq found (cons (cons answer (car match)) found)
vals (cdr match)
args (delq answer args))))
(greedy
(setq vals (cdr vals)))
- (t
+ (t
(setq vals nil)))))
found))
;; The values of all selected items.
(let ((children (widget-get widget :children))
child result)
- (while children
+ (while children
(setq child (car children)
children (cdr children))
(if (widget-value (widget-get child :button))
;; Insert all values
(let ((args (widget-get widget :args))
arg)
- (while args
+ (while args
(setq arg (car args)
args (cdr args))
(widget-radio-add-item widget arg))))
(and (eq (preceding-char) ?\n)
(widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
- (widget-specify-insert
+ (widget-specify-insert
(let* ((value (widget-get widget :value))
(children (widget-get widget :children))
(buttons (widget-get widget :buttons))
+ (button-args (or (widget-get type :sibling-args)
+ (widget-get widget :button-args)))
(from (point))
(chosen (and (null (widget-get widget :choice))
(widget-apply type :match value)))
(cond ((eq escape ?%)
(insert "%"))
((eq escape ?b)
- (setq button (widget-create-child-and-convert
- widget 'radio-button
- :value (not (null chosen)))))
+ (setq button (apply 'widget-create-child-and-convert
+ widget 'radio-button
+ :value (not (null chosen))
+ button-args)))
((eq escape ?v)
(setq child (if chosen
(widget-create-child-value
widget type value)
(widget-create-child widget type))))
- (t
+ (t
(error "Unknown escape `%c'" escape)))))
;; Update properties.
(when chosen
(widget-put widget :choice type))
- (when button
+ (when button
(widget-put child :button button)
(widget-put widget :buttons (nconc buttons (list button))))
(when child
(match (and (not found)
(widget-apply current :match value))))
(widget-value-set button match)
- (if match
+ (if match
(widget-value-set current value))
(setq found (or found match))))))
(define-widget 'insert-button 'push-button
"An insert button for the `editable-list' widget."
:tag "INS"
+ :help-echo "Insert a new item into the list at this position."
:action 'widget-insert-button-action)
(defun widget-insert-button-action (widget &optional event)
;; Ask the parent to insert a new item.
- (widget-apply (widget-get widget :parent)
+ (widget-apply (widget-get widget :parent)
:insert-before (widget-get widget :widget)))
;;; The `delete-button' Widget.
(define-widget 'delete-button 'push-button
"A delete button for the `editable-list' widget."
:tag "DEL"
+ :help-echo "Delete this item from the list."
:action 'widget-delete-button-action)
(defun widget-delete-button-action (widget &optional event)
;; Ask the parent to insert a new item.
- (widget-apply (widget-get widget :parent)
+ (widget-apply (widget-get widget :parent)
:delete-at (widget-get widget :widget)))
;;; The `editable-list' Widget.
(cond ((eq escape ?i)
(and (widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
- (widget-create-child-and-convert widget 'insert-button))
- (t
+ (apply 'widget-create-child-and-convert
+ widget 'insert-button
+ (widget-get widget :append-button-args)))
+ (t
(widget-default-format-handler widget escape)))))
(defun widget-editable-list-value-create (widget)
found)
(while (and value ok)
(let ((answer (widget-match-inline type value)))
- (if answer
+ (if answer
(setq found (append found (car answer))
value (cdr answer))
(setq ok nil))))
(let ((children (widget-get widget :children))
(inhibit-read-only t)
after-change-functions)
- (cond (before
+ (cond (before
(goto-char (widget-get before :entry-from)))
(t
(goto-char (widget-get widget :value-pos))))
- (let ((child (widget-editable-list-entry-create
+ (let ((child (widget-editable-list-entry-create
widget nil nil)))
(when (< (widget-get child :entry-from) (widget-get widget :from))
(set-marker (widget-get widget :from)
(let ((type (nth 0 (widget-get widget :args)))
(widget-push-button-gui widget-editable-list-gui)
child delete insert)
- (widget-specify-insert
+ (widget-specify-insert
(save-excursion
(and (widget-get widget :indent)
(insert-char ? (widget-get widget :indent)))
(cond ((eq escape ?%)
(insert "%"))
((eq escape ?i)
- (setq insert (widget-create-child-and-convert
- widget 'insert-button)))
+ (setq insert (apply 'widget-create-child-and-convert
+ widget 'insert-button
+ (widget-get widget :insert-button-args))))
((eq escape ?d)
- (setq delete (widget-create-child-and-convert
- widget 'delete-button)))
+ (setq delete (apply 'widget-create-child-and-convert
+ widget 'delete-button
+ (widget-get widget :delete-button-args))))
((eq escape ?v)
(if conv
- (setq child (widget-create-child-value
+ (setq child (widget-create-child-value
widget type value))
(setq child (widget-create-child widget type))))
- (t
+ (t
(error "Unknown escape `%c'" escape)))))
- (widget-put widget
- :buttons (cons delete
+ (widget-put widget
+ :buttons (cons delete
(cons insert
(widget-get widget :buttons))))
(let ((entry-from (copy-marker (point-min)))
(setq argument (car args)
args (cdr args)
answer (widget-match-inline argument vals))
- (if answer
+ (if answer
(setq vals (cdr answer)
found (append found (car answer)))
(setq vals nil
(define-widget 'widget-help 'push-button
"The widget documentation button."
:format "%[[%t]%] %d"
- :help-echo "Push me to toggle the documentation."
+ :help-echo "Toggle display of documentation."
:action 'widget-help-action)
(defun widget-help-action (widget &optional event)
:tag "Regexp")
(define-widget 'file 'string
- "A file widget.
+ "A file widget.
It will read a file name from the minibuffer when activated."
:format "%[%t%]: %v"
:tag "File"
(widget-setup)))
(define-widget 'directory 'file
- "A directory widget.
+ "A directory widget.
It will read a directory name from the minibuffer when activated."
:tag "Directory")
:value 0
:type-error "This field should contain an integer"
:value-to-internal (lambda (widget value)
- (if (integerp value)
+ (if (integerp value)
(prin1-to-string value)
value))
:match (lambda (widget value) (integerp value)))
"An character."
:tag "Character"
:value 0
- :size 1
+ :size 1
:format "%{%t%}: %v\n"
:type-error "This field should contain a character"
:value-to-internal (lambda (widget value)
- (if (integerp value)
+ (if (integerp value)
(char-to-string value)
value))
:value-to-external (lambda (widget value)
:value-to-internal (lambda (widget value) (append value nil))
:value-to-external (lambda (widget value) (apply 'vector value)))
-(defun widget-vector-match (widget value)
+(defun widget-vector-match (widget value)
(and (vectorp value)
(widget-group-match widget
(widget-apply :value-to-internal widget value))))
:value-to-external (lambda (widget value)
(cons (nth 0 value) (nth 1 value))))
-(defun widget-cons-match (widget value)
+(defun widget-cons-match (widget value)
(and (consp value)
(widget-group-match widget
(widget-apply widget :value-to-internal value))))
(define-widget 'color-item 'choice-item
"A color name (with sample)."
- :format "%v (%[sample%])\n"
+ :format "%v (%{sample%})\n"
:button-face-get 'widget-color-item-button-face-get)
(defun widget-color-item-button-face-get (widget)
(defun widget-color-choice-list ()
(unless widget-color-choice-list
- (setq widget-color-choice-list
+ (setq widget-color-choice-list
(mapcar '(lambda (color) (list color))
(x-defined-colors))))
widget-color-choice-list)
(read-color prompt))
((fboundp 'x-defined-colors)
(completing-read (concat tag ": ")
- (widget-color-choice-list)
+ (widget-color-choice-list)
nil nil nil 'widget-color-history))
(t
(read-string prompt (widget-value widget))))))
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Keywords: help, extensions, faces, hypermedia
-;; Version: 1.55
+;; Version: 1.59
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
;;; Commentary:
(set (car keywords) (car keywords)))
(setq keywords (cdr keywords)))))))
-(define-widget-keywords :tag-glyph :off-glyph :on-glyph :valid-regexp
- :secret :sample-face :sample-face-get :case-fold :widget-doc
+(define-widget-keywords :sibling-args :delete-button-args
+ :insert-button-args :append-button-args :button-args
+ :tag-glyph :off-glyph :on-glyph :valid-regexp
+ :secret :sample-face :sample-face-get :case-fold :widget-doc
:create :convert-widget :format :value-create :offset :extra-offset
:tag :doc :from :to :args :value :value-from :value-to :action
:value-set :value-delete :match :parent :delete :menu-tag-get
:must-match :type-error :value-inline :inline :match-inline :greedy
:button-face-get :button-face :value-face :keymap :entry-from
:entry-to :help-echo :documentation-property :hide-front-space
- :hide-rear-space)
+ :hide-rear-space)
;; These autoloads should be deleted when the file is added to Emacs.
(unless (fboundp 'load-gc)
@comment node-name, next, previous, up
@top The Customization Library
-Version: 1.55
+Version: 1.59
@menu
* Introduction::
The last part of the customization buffer looks like this:
@example
-[Set] [Save] [Reset]
+[Set] [Save] [Reset] [Done]
@end example
Activating the @samp{[Set]}, @samp{[Save]}, or @samp{[Reset]}
button will affect all modified customization items that are visible in
-the buffer.
+the buffer. @samp{[Done]} will bury the buffer.
@node Declarations, Utilities, The Customization Buffer, Top
@comment node-name, next, previous, up
@item
Integrate with @file{w3} so you can customization buffers with much
better formatting. I'm thinking about adding a <custom>name</custom>
-tag.
+tag. The latest w3 have some support for this, so come up with a
+convincing example.
@item
Add an `examples' section, with explained examples of custom type
be a letter. @sc{gnus} will call the function
@code{gnus-user-format-function-}@samp{X}, where @samp{X} is the letter
following @samp{%u}. The function will be passed a single dummy
-paratere as argument. The function should return a string, which will
+parameter as argument. The function should return a string, which will
be inserted into the buffer just like information from any other
specifier.
@end table
Here's an example group parameter list:
@example
-((to-address . "ding@ifi.uio.no")
+((to-address . "ding@@ifi.uio.no")
(auto-expiry . t))
@end example
\input texinfo.tex
-@c $Id: widget.texi,v 1.83 1997/03/05 16:43:09 abraham Exp $
+@c $Id: widget.texi,v 1.87 1997/03/08 16:21:38 abraham Exp $
@c %**start of header
@setfilename widget
@comment node-name, next, previous, up
@top The Emacs Widget Library
-Version: 1.55
+Version: 1.59
@menu
* Introduction::
@item :parent
The parent of a nested widget (e.g. a @code{menu-choice} item or an element of a
@code{editable-list} widget).
+
+@item :sibling-args
+This keyword is only used for members of a @code{radio-button-choice} or
+@code{checklist}. The value should be a list of extra keyword
+arguments, which will be used when creating the @code{radio-button} or
+@code{checkbox} associated with this item.
+
@end table
@deffn {User Option} widget-glyph-directory
Insert a literal @samp{%}.
@end table
+@item button-args
+A list of keywords to pass to the radio buttons. Useful for setting
+e.g. the @samp{:help-echo} for each button.
+
@item :buttons
The widgets representing the radio buttons.
Insert a literal @samp{%}.
@end table
+@item button-args
+A list of keywords to pass to the checkboxes. Useful for setting
+e.g. the @samp{:help-echo} for each checkbox.
+
@item :buttons
The widgets representing the checkboxes.
Insert a literal @samp{%}.
@end table
+@item :insert-button-args
+A list of keyword arguments to pass to the insert buttons.
+
+@item :delete-button-args
+A list of keyword arguments to pass to the delete buttons.
+
+@item :append-button-args
+A list of keyword arguments to pass to the trailing insert button.
+
+
@item :buttons
The widgets representing the insert and delete buttons.
projects / gnus / commitdiff