Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 377:d883f39b8495 r21-2b4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2b4
author cvs
date Mon, 13 Aug 2007 11:05:42 +0200
parents cc15677e0335
children 8626e4521993
comparison
equal deleted inserted replaced
376:e2295b4d9f2e 377:d883f39b8495
1061 (and (mouse-event-p event) 1061 (and (mouse-event-p event)
1062 (event-point event))) 1062 (event-point event)))
1063 1063
1064 (defun widget-button-click (event) 1064 (defun widget-button-click (event)
1065 "Invoke button below mouse pointer." 1065 "Invoke button below mouse pointer."
1066 (interactive "@e") 1066 (interactive "e")
1067 (cond ((event-glyph event) 1067 (with-current-buffer (event-buffer event)
1068 (widget-glyph-click event)) 1068 (cond ((event-glyph event)
1069 ((widget-event-point event) 1069 (widget-glyph-click event))
1070 (let* ((pos (widget-event-point event)) 1070 ((widget-event-point event)
1071 (button (get-char-property pos 'button))) 1071 (let* ((pos (widget-event-point event))
1072 (if button 1072 (button (get-char-property pos 'button)))
1073 (let* ((extent (widget-get button :button-extent)) 1073 (if button
1074 (face (extent-property extent 'face)) 1074 (let* ((extent (widget-get button :button-extent))
1075 (mouse-face (extent-property extent 'mouse-face)) 1075 (face (extent-property extent 'face))
1076 (help-echo (extent-property extent 'help-echo))) 1076 (mouse-face (extent-property extent 'mouse-face))
1077 (unwind-protect 1077 (help-echo (extent-property extent 'help-echo)))
1078 (progn 1078 (unwind-protect
1079 ;; Merge relevant faces, and make the result mouse-face. 1079 (progn
1080 (let ((merge `(widget-button-pressed-face ,mouse-face))) 1080 ;; Merge relevant faces, and make the result mouse-face.
1081 (nconc merge (if (listp face) 1081 (let ((merge `(widget-button-pressed-face ,mouse-face)))
1082 face (list face))) 1082 (nconc merge (if (listp face)
1083 (setq merge (delete-if-not 'find-face merge)) 1083 face (list face)))
1084 (set-extent-property extent 'mouse-face merge)) 1084 (setq merge (delete-if-not 'find-face merge))
1085 (unless (widget-apply button :mouse-down-action event) 1085 (set-extent-property extent 'mouse-face merge))
1086 ;; Wait for button release. 1086 (unless (widget-apply button :mouse-down-action event)
1087 (while (not (button-release-event-p 1087 ;; Wait for button release.
1088 (setq event (next-event)))) 1088 (while (not (button-release-event-p
1089 (dispatch-event event))) 1089 (setq event (next-event))))
1090 ;; Disallow mouse-face and help-echo. 1090 (dispatch-event event)))
1091 (set-extent-property extent 'mouse-face nil) 1091 ;; Disallow mouse-face and help-echo.
1092 (set-extent-property extent 'help-echo nil) 1092 (set-extent-property extent 'mouse-face nil)
1093 (setq pos (widget-event-point event)) 1093 (set-extent-property extent 'help-echo nil)
1094 (unless (eq (current-buffer) (extent-object extent)) 1094 (setq pos (widget-event-point event))
1095 ;; Barf if dispatch-event tripped us by 1095 (unless (eq (current-buffer) (extent-object extent))
1096 ;; changing buffer. 1096 ;; Barf if dispatch-event tripped us by
1097 (error "Buffer changed during mouse motion")) 1097 ;; changing buffer.
1098 ;; Do the associated action. 1098 (error "Buffer changed during mouse motion"))
1099 (when (and pos (extent-in-region-p extent pos pos)) 1099 ;; Do the associated action.
1100 (widget-apply-action button event))) 1100 (when (and pos (extent-in-region-p extent pos pos))
1101 ;; Unwinding: fully release the button. 1101 (widget-apply-action button event)))
1102 (set-extent-property extent 'mouse-face mouse-face) 1102 ;; Unwinding: fully release the button.
1103 (set-extent-property extent 'help-echo help-echo))) 1103 (set-extent-property extent 'mouse-face mouse-face)
1104 ;; This should not happen! 1104 (set-extent-property extent 'help-echo help-echo)))
1105 (error "`widget-button-click' called outside button")))) 1105 ;; This should not happen!
1106 (t 1106 (error "`widget-button-click' called outside button"))))
1107 (message "You clicked somewhere weird")))) 1107 (t
1108 (message "You clicked somewhere weird")))))
1108 1109
1109 (defun widget-button1-click (event) 1110 (defun widget-button1-click (event)
1110 "Invoke glyph below mouse pointer." 1111 "Invoke glyph below mouse pointer."
1111 (interactive "@e") 1112 (interactive "@e")
1112 (if (event-glyph event) 1113 (if (event-glyph event)