X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fwid-edit.el;h=a21f19cbf62c85ba255984fa3098ae1d346e4efa;hb=c5fa2f9d3556ef2be3e0f34b00f6f03a4bd93e8d;hp=a311bc4a6b256f9cb12cd02faf688928920d50aa;hpb=6883ee56ec887c2c48abe5b06b5e66aa74031910;p=chise%2Fxemacs-chise.git diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index a311bc4..a21f19c 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -49,7 +49,7 @@ :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 @@ -302,6 +302,7 @@ new value." (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) @@ -533,7 +534,7 @@ Suitable for use with `map-extents'." 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: @@ -673,7 +674,7 @@ automatically." :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." @@ -722,27 +723,27 @@ It can also be a valid image instantiator, in which case it will be (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]))) @@ -1063,48 +1064,49 @@ Recommended as a parent keymap for modes using widgets.") (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." @@ -1128,7 +1130,7 @@ Recommended as a parent keymap for modes using widgets.") (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.