Mercurial > hg > xemacs-beta

comparison lisp/wid-edit.el @ 371:cc15677e0335 r21-2b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2b1
author cvs
date Mon, 13 Aug 2007 11:03:08 +0200
parents a4f53d9b3154
children d883f39b8495
comparison
equal deleted inserted replaced
370:bd866891f083 371:cc15677e0335
47 :prefix "widget-" 47 :prefix "widget-"
48 :group 'extensions 48 :group 'extensions
49 :group 'hypermedia) 49 :group 'hypermedia)
50 50
51 (defgroup widget-documentation nil 51 (defgroup widget-documentation nil
52 "Options controlling the display of documentation strings." 52 "Options controling the display of documentation strings."
53 :group 'widgets) 53 :group 'widgets)
54 54
55 (defgroup widget-faces nil 55 (defgroup widget-faces nil
56 "Faces used by the widget library." 56 "Faces used by the widget library."
57 :group 'widgets 57 :group 'widgets
300 (extent-property extent 'glyph-widget))) 300 (extent-property extent 'glyph-widget)))
301 (help-echo (and widget (widget-get widget :help-echo)))) 301 (help-echo (and widget (widget-get widget :help-echo))))
302 (and (functionp help-echo) 302 (and (functionp help-echo)
303 (setq help-echo (funcall help-echo widget))) 303 (setq help-echo (funcall help-echo widget)))
304 (when (stringp help-echo) 304 (when (stringp help-echo)
305 (setq help-echo-owns-message t)
306 (display-message 'help-echo help-echo)))) 305 (display-message 'help-echo help-echo))))
307 306
308 (defsubst widget-handle-help-echo (extent help-echo) 307 (defsubst widget-handle-help-echo (extent help-echo)
309 (set-extent-property extent 'balloon-help help-echo) 308 (set-extent-property extent 'balloon-help help-echo)
310 (set-extent-property extent 'help-echo help-echo) 309 (set-extent-property extent 'help-echo help-echo)
437 "Face used for inactive widgets." 436 "Face used for inactive widgets."
438 :group 'widget-faces) 437 :group 'widget-faces)
439 438
440 ;; For inactiveness to work on complex structures, it is not 439 ;; For inactiveness to work on complex structures, it is not
441 ;; sufficient to keep track of whether a button/field/glyph is 440 ;; sufficient to keep track of whether a button/field/glyph is
442 ;; inactive or not -- we must know how many times it was deactivated 441 ;; inactive or not -- we must know how many time it was deactivated
443 ;; (inactiveness level). Successive deactivations of the same button 442 ;; (inactiveness level). Successive deactivations of the same button
444 ;; increment its inactive-count, and activations decrement it. When 443 ;; increment its inactive-count, and activations decrement it. When
445 ;; inactive-count reaches 0, the button/field/glyph is reactivated. 444 ;; inactive-count reaches 0, the button/field/glyph is reactivated.
446 445
447 (defun widget-activation-widget-mapper (extent action) 446 (defun widget-activation-widget-mapper (extent action)
510 (map-extents 'widget-activation-glyph-mapper 509 (map-extents 'widget-activation-glyph-mapper
511 nil from to :deactivate nil 'glyph-widget))) 510 nil from to :deactivate nil 'glyph-widget)))
512 511
513 (defun widget-specify-active (widget) 512 (defun widget-specify-active (widget)
514 "Make WIDGET active for user modifications." 513 "Make WIDGET active for user modifications."
515 (let ((inactive (widget-get widget :inactive)) 514 (let ((inactive (widget-get widget :inactive)))
516 (from (widget-get widget :from))
517 (to (widget-get widget :to)))
518 (when (and inactive (not (extent-detached-p inactive))) 515 (when (and inactive (not (extent-detached-p inactive)))
519 ;; Reactivate the buttons and fields covered by the extent. 516 ;; Reactivate the buttons and fields covered by the extent.
520 (map-extents 'widget-activation-widget-mapper 517 (map-extents 'widget-activation-widget-mapper
521 nil from to :activate nil 'button-or-field) 518 inactive nil nil :activate nil 'button-or-field)
522 ;; Reactivate the glyphs. 519 ;; Reactivate the glyphs.
523 (map-extents 'widget-activation-glyph-mapper 520 (map-extents 'widget-activation-glyph-mapper
524 nil from to :activate nil 'end-glyph) 521 inactive nil nil :activate nil 'end-glyph)
525 (delete-extent inactive) 522 (delete-extent inactive)
526 (widget-put widget :inactive nil)))) 523 (widget-put widget :inactive nil))))
527 524
528 525
529 ;;; Widget Properties. 526 ;;; Widget Properties.
675 "If non nil, use glyphs in images when available." 672 "If non nil, use glyphs in images when available."
676 :group 'widgets 673 :group 'widgets
677 :type 'boolean) 674 :type 'boolean)
678 675
679 (defcustom widget-image-conversion 676 (defcustom widget-image-conversion
680 '((png ".png") (xpm ".xpm") (gif ".gif") (jpeg ".jpg" ".jpeg") 677 '((xpm ".xpm") (gif ".gif") (png ".png") (jpeg ".jpg" ".jpeg")
681 (xbm ".xbm")) 678 (xbm ".xbm"))
682 "Conversion alist from image formats to file name suffixes." 679 "Conversion alist from image formats to file name suffixes."
683 :group 'widgets 680 :group 'widgets
684 :type '(repeat (cons :format "%v" 681 :type '(repeat (cons :format "%v"
685 (symbol :tag "Image Format" unknown) 682 (symbol :tag "Image Format" unknown)
1064 (and (mouse-event-p event) 1061 (and (mouse-event-p event)
1065 (event-point event))) 1062 (event-point event)))
1066 1063
1067 (defun widget-button-click (event) 1064 (defun widget-button-click (event)
1068 "Invoke button below mouse pointer." 1065 "Invoke button below mouse pointer."
1069 (interactive "e") 1066 (interactive "@e")
1070 (with-current-buffer (event-buffer event) 1067 (cond ((event-glyph event)
1071 (cond ((event-glyph event) 1068 (widget-glyph-click event))
1072 (widget-glyph-click event)) 1069 ((widget-event-point event)
1073 ((widget-event-point event) 1070 (let* ((pos (widget-event-point event))
1074 (let* ((pos (widget-event-point event)) 1071 (button (get-char-property pos 'button)))
1075 (button (get-char-property pos 'button))) 1072 (if button
1076 (if button 1073 (let* ((extent (widget-get button :button-extent))
1077 (let* ((extent (widget-get button :button-extent)) 1074 (face (extent-property extent 'face))
1078 (face (extent-property extent 'face)) 1075 (mouse-face (extent-property extent 'mouse-face))
1079 (mouse-face (extent-property extent 'mouse-face)) 1076 (help-echo (extent-property extent 'help-echo)))
1080 (help-echo (extent-property extent 'help-echo))) 1077 (unwind-protect
1081 (unwind-protect 1078 (progn
1082 (progn 1079 ;; Merge relevant faces, and make the result mouse-face.
1083 ;; Merge relevant faces, and make the result mouse-face. 1080 (let ((merge `(widget-button-pressed-face ,mouse-face)))
1084 (let ((merge `(widget-button-pressed-face ,mouse-face))) 1081 (nconc merge (if (listp face)
1085 (nconc merge (if (listp face) 1082 face (list face)))
1086 face (list face))) 1083 (setq merge (delete-if-not 'find-face merge))
1087 (setq merge (delete-if-not 'find-face merge)) 1084 (set-extent-property extent 'mouse-face merge))
1088 (set-extent-property extent 'mouse-face merge)) 1085 (unless (widget-apply button :mouse-down-action event)
1089 (unless (widget-apply button :mouse-down-action event) 1086 ;; Wait for button release.
1090 ;; Wait for button release. 1087 (while (not (button-release-event-p
1091 (while (not (button-release-event-p 1088 (setq event (next-event))))
1092 (setq event (next-event)))) 1089 (dispatch-event event)))
1093 (dispatch-event event))) 1090 ;; Disallow mouse-face and help-echo.
1094 ;; Disallow mouse-face and help-echo. 1091 (set-extent-property extent 'mouse-face nil)
1095 (set-extent-property extent 'mouse-face nil) 1092 (set-extent-property extent 'help-echo nil)
1096 (set-extent-property extent 'help-echo nil) 1093 (setq pos (widget-event-point event))
1097 (setq pos (widget-event-point event)) 1094 (unless (eq (current-buffer) (extent-object extent))
1098 (unless (eq (current-buffer) (extent-object extent)) 1095 ;; Barf if dispatch-event tripped us by
1099 ;; Barf if dispatch-event tripped us by 1096 ;; changing buffer.
1100 ;; changing buffer. 1097 (error "Buffer changed during mouse motion"))
1101 (error "Buffer changed during mouse motion")) 1098 ;; Do the associated action.
1102 ;; Do the associated action. 1099 (when (and pos (extent-in-region-p extent pos pos))
1103 (when (and pos (extent-in-region-p extent pos pos)) 1100 (widget-apply-action button event)))
1104 (widget-apply-action button event))) 1101 ;; Unwinding: fully release the button.
1105 ;; Unwinding: fully release the button. 1102 (set-extent-property extent 'mouse-face mouse-face)
1106 (set-extent-property extent 'mouse-face mouse-face) 1103 (set-extent-property extent 'help-echo help-echo)))
1107 (set-extent-property extent 'help-echo help-echo))) 1104 ;; This should not happen!
1108 ;; This should not happen! 1105 (error "`widget-button-click' called outside button"))))
1109 (error "`widget-button-click' called outside button")))) 1106 (t
1110 (t 1107 (message "You clicked somewhere weird"))))
1111 (message "You clicked somewhere weird")))))
1112 1108
1113 (defun widget-button1-click (event) 1109 (defun widget-button1-click (event)
1114 "Invoke glyph below mouse pointer." 1110 "Invoke glyph below mouse pointer."
1115 (interactive "@e") 1111 (interactive "@e")
1116 (if (event-glyph event) 1112 (if (event-glyph event)