:group 'hypermedia)
(defgroup widget-documentation nil
- "Options controling the display of documentation strings."
+ "Options controlling the display of documentation strings."
:group 'widgets)
(defgroup widget-faces nil
(and (functionp help-echo)
(setq help-echo (funcall help-echo widget)))
(when (stringp help-echo)
+ (setq help-echo-owns-message t)
(display-message 'help-echo help-echo))))
(defsubst widget-handle-help-echo (extent help-echo)
widget-shadow-subrs)
(defun widget-put (widget property value)
"In WIDGET set PROPERTY to VALUE.
-The value can later be retrived with `widget-get'."
+The value can later be retrieved with `widget-get'."
(setcdr widget (plist-put (cdr widget) property value))))
;; Recoded in C, for efficiency:
:group 'widgets
:type 'boolean)
-(defcustom widget-image-conversion
+(defcustom widget-image-file-name-suffixes
'((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
(xbm ".xbm"))
"Conversion alist from image formats to file name suffixes."
(let* ((dirlist (cons (or widget-glyph-directory
(locate-data-directory "custom"))
data-directory-list))
- (formats widget-image-conversion)
- file)
- (while (and formats (not file))
- ;; This dance is necessary, because XEmacs signals an
- ;; error when it encounters an unrecognized image
- ;; format.
- (when (valid-image-instantiator-format-p (caar formats))
- (setq file (locate-file image dirlist
- (mapconcat 'identity (cdar formats)
- ":"))))
- (unless file
- (pop formats)))
+ (all-suffixes
+ (apply #'append
+ (mapcar
+ (lambda (el)
+ (and (valid-image-instantiator-format-p (car el))
+ (cdr el)))
+ widget-image-file-name-suffixes)))
+ (file (locate-file image dirlist all-suffixes)))
(when file
- ;; We create a glyph with the file as the default image
- ;; instantiator, and the TAG fallback
- (let ((glyph (make-glyph `([,(caar formats) :file ,file]
- [string :data ,tag]))))
- ;; Cache the glyph
- (laxputf widget-glyph-cache image glyph)
- ;; ...and return it
- glyph)))))
+ (let* ((extension (concat "." (file-name-extension file)))
+ (format (car (rassoc* extension
+ widget-image-file-name-suffixes
+ :test #'member))))
+ ;; We create a glyph with the file as the default image
+ ;; instantiator, and the TAG fallback
+ (let ((glyph (make-glyph `([,format :file ,file]
+ [string :data ,tag]))))
+ ;; Cache the glyph
+ (laxputf widget-glyph-cache image glyph)
+ ;; ...and return it
+ glyph))))))
((valid-instantiator-p image 'image)
;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
(make-glyph `(,image [string :data ,tag])))
(defun widget-button-click (event)
"Invoke button below mouse pointer."
- (interactive "@e")
- (cond ((event-glyph event)
- (widget-glyph-click event))
- ((widget-event-point event)
- (let* ((pos (widget-event-point event))
- (button (get-char-property pos 'button)))
- (if button
- (let* ((extent (widget-get button :button-extent))
- (face (extent-property extent 'face))
- (mouse-face (extent-property extent 'mouse-face))
- (help-echo (extent-property extent 'help-echo)))
- (unwind-protect
- (progn
- ;; Merge relevant faces, and make the result mouse-face.
- (let ((merge `(widget-button-pressed-face ,mouse-face)))
- (nconc merge (if (listp face)
- face (list face)))
- (setq merge (delete-if-not 'find-face merge))
- (set-extent-property extent 'mouse-face merge))
- (unless (widget-apply button :mouse-down-action event)
- ;; Wait for button release.
- (while (not (button-release-event-p
- (setq event (next-event))))
- (dispatch-event event)))
- ;; Disallow mouse-face and help-echo.
- (set-extent-property extent 'mouse-face nil)
- (set-extent-property extent 'help-echo nil)
- (setq pos (widget-event-point event))
- (unless (eq (current-buffer) (extent-object extent))
- ;; Barf if dispatch-event tripped us by
- ;; changing buffer.
- (error "Buffer changed during mouse motion"))
- ;; Do the associated action.
- (when (and pos (extent-in-region-p extent pos pos))
- (widget-apply-action button event)))
- ;; Unwinding: fully release the button.
- (set-extent-property extent 'mouse-face mouse-face)
- (set-extent-property extent 'help-echo help-echo)))
- ;; This should not happen!
- (error "`widget-button-click' called outside button"))))
- (t
- (message "You clicked somewhere weird"))))
+ (interactive "e")
+ (with-current-buffer (event-buffer event)
+ (cond ((event-glyph event)
+ (widget-glyph-click event))
+ ((widget-event-point event)
+ (let* ((pos (widget-event-point event))
+ (button (get-char-property pos 'button)))
+ (if button
+ (let* ((extent (widget-get button :button-extent))
+ (face (extent-property extent 'face))
+ (mouse-face (extent-property extent 'mouse-face))
+ (help-echo (extent-property extent 'help-echo)))
+ (unwind-protect
+ (progn
+ ;; Merge relevant faces, and make the result mouse-face.
+ (let ((merge `(widget-button-pressed-face ,mouse-face)))
+ (nconc merge (if (listp face)
+ face (list face)))
+ (setq merge (delete-if-not 'find-face merge))
+ (set-extent-property extent 'mouse-face merge))
+ (unless (widget-apply button :mouse-down-action event)
+ ;; Wait for button release.
+ (while (not (button-release-event-p
+ (setq event (next-event))))
+ (dispatch-event event)))
+ ;; Disallow mouse-face and help-echo.
+ (set-extent-property extent 'mouse-face nil)
+ (set-extent-property extent 'help-echo nil)
+ (setq pos (widget-event-point event))
+ (unless (eq (current-buffer) (extent-object extent))
+ ;; Barf if dispatch-event tripped us by
+ ;; changing buffer.
+ (error "Buffer changed during mouse motion"))
+ ;; Do the associated action.
+ (when (and pos (extent-in-region-p extent pos pos))
+ (widget-apply-action button event)))
+ ;; Unwinding: fully release the button.
+ (set-extent-property extent 'mouse-face mouse-face)
+ (set-extent-property extent 'help-echo help-echo)))
+ ;; This should not happen!
+ (error "`widget-button-click' called outside button"))))
+ (t
+ (message "You clicked somewhere weird")))))
(defun widget-button1-click (event)
"Invoke glyph below mouse pointer."
(error "This widget is inactive"))
(let ((current-glyph 'down))
;; We always know what glyph is drawn currently, to avoid
- ;; unnecessary extent changes. Is this any noticable gain?
+ ;; unnecessary extent changes. Is this any noticeable gain?
(unwind-protect
(progn
;; Press the glyph.