X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/4a47c2757309e338321da1e7a2f6d399a306ce7d..b84e3dda5b63822f233732174f63e4854ca3f878:/lisp/button.el diff --git a/lisp/button.el b/lisp/button.el index c771474da3..433c3990d5 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -1,7 +1,6 @@ ;;; button.el --- clickable buttons ;; -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, -;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2001-2013 Free Software Foundation, Inc. ;; ;; Author: Miles Bader ;; Keywords: extensions @@ -38,10 +37,12 @@ ;; the button is represented by a marker or buffer-position pointing ;; somewhere in the button. In the latter case, no markers into the ;; buffer are retained, which is important for speed if there are are -;; extremely large numbers of buttons. +;; extremely large numbers of buttons. Note however that if there is +;; an existing face text-property at the site of the button, the +;; button face may not be visible. Using overlays avoids this. ;; ;; Using `define-button-type' to define default properties for buttons -;; is not necessary, but it is is encouraged, since doing so makes the +;; is not necessary, but it is encouraged, since doing so makes the ;; resulting code clearer and more efficient. ;; @@ -53,10 +54,7 @@ ;; Use color for the MS-DOS port because it doesn't support underline. ;; FIXME if MS-DOS correctly answers the (supports) question, it need ;; no longer be a special case. -(defface button '((((type pc) (class color)) - (:foreground "lightblue")) - (((supports :underline t)) :underline t) - (t (:foreground "lightblue"))) +(defface button '((t :inherit link)) "Default face used for buttons." :group 'basic-faces) @@ -66,6 +64,11 @@ ;; might get converted to ^M when building loaddefs.el (define-key map [(control ?m)] 'push-button) (define-key map [mouse-2] 'push-button) + ;; FIXME: You'd think that for keymaps coming from text-properties on the + ;; mode-line or header-line, the `mode-line' or `header-line' prefix + ;; shouldn't be necessary! + (define-key map [mode-line mouse-2] 'push-button) + (define-key map [header-line mouse-2] 'push-button) map) "Keymap used by buttons.") @@ -186,10 +189,13 @@ changes to a supertype are not reflected in its subtypes)." (defun button-get (button prop) "Get the property of button BUTTON named PROP." - (if (overlayp button) - (overlay-get button prop) - ;; Must be a text-property button. - (get-text-property button prop))) + (cond ((overlayp button) + (overlay-get button prop)) + ((button--area-button-p button) + (get-text-property (cdr button) + prop (button--area-button-string button))) + (t ; Must be a text-property button. + (get-text-property button prop)))) (defun button-put (button prop val) "Set BUTTON's PROP property to VAL." @@ -204,21 +210,30 @@ changes to a supertype are not reflected in its subtypes)." ;; Disallow updating the `category' property directly. (error "Button `category' property may not be set directly"))) ;; Add the property. - (if (overlayp button) - (overlay-put button prop val) - ;; Must be a text-property button. - (put-text-property - (or (previous-single-property-change (1+ button) 'button) - (point-min)) - (or (next-single-property-change button 'button) - (point-max)) - prop val))) - -(defsubst button-activate (button &optional use-mouse-action) + (cond ((overlayp button) + (overlay-put button prop val)) + ((button--area-button-p button) + (setq button (button--area-button-string button)) + (put-text-property 0 (length button) prop val button)) + (t ; Must be a text-property button. + (put-text-property + (or (previous-single-property-change (1+ button) 'button) + (point-min)) + (or (next-single-property-change button 'button) + (point-max)) + prop val)))) + +(defun button-activate (button &optional use-mouse-action) "Call BUTTON's action property. If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action instead of its normal action; if the button has no mouse-action, -the normal action is used instead." +the normal action is used instead. + +The action can either be a marker or a function. If it's a +marker then goto it. Otherwise it it is a function then it is +called with BUTTON as only argument. BUTTON is either an +overlay, a buffer position, or (for buttons in the mode-line or +header-line) a string." (let ((action (or (and use-mouse-action (button-get button 'mouse-action)) (button-get button 'action)))) (if (markerp action) @@ -230,7 +245,10 @@ the normal action is used instead." (defun button-label (button) "Return BUTTON's text label." - (buffer-substring-no-properties (button-start button) (button-end button))) + (if (button--area-button-p button) + (substring-no-properties (button--area-button-string button)) + (buffer-substring-no-properties (button-start button) + (button-end button)))) (defsubst button-type (button) "Return BUTTON's button-type." @@ -240,6 +258,13 @@ the normal action is used instead." "Return t if BUTTON has button-type TYPE, or one of TYPE's subtypes." (button-type-subtype-p (button-get button 'type) type)) +(defun button--area-button-p (b) + "Return non-nil if BUTTON is an area button. +Such area buttons are used for buttons in the mode-line and header-line." + (stringp (car-safe b))) + +(defalias 'button--area-button-string #'car + "Return area button BUTTON's button-string.") ;; Creating overlay buttons @@ -290,9 +315,12 @@ button-type from which to inherit other properties; see `define-button-type'. This function is like `make-button', except that the button is actually -part of the text instead of being a property of the buffer. Creating -large numbers of buttons can also be somewhat faster using -`make-text-button'. +part of the text instead of being a property of the buffer. That is, +this function uses text properties, the other uses overlays. +Creating large numbers of buttons can also be somewhat faster +using `make-text-button'. Note, however, that if there is an existing +face property at the site of the button, the button face may not be visible. +You may want to use `make-button' in that case. BEG can also be a string, in which case it is made into a button. @@ -323,7 +351,7 @@ Also see `insert-text-button'." (cons 'button (cons (list t) properties)) object) ;; Return something that can be used to get at the button. - beg)) + (or object beg))) (defun insert-text-button (label &rest properties) "Insert a button with the label LABEL. @@ -348,7 +376,9 @@ Also see `make-text-button'." ;; Finding buttons in a buffer (defun button-at (pos) - "Return the button at position POS in the current buffer, or nil." + "Return the button at position POS in the current buffer, or nil. +If the button at POS is a text property button, the return value +is a marker pointing to POS." (let ((button (get-char-property pos 'button))) (if (or (overlayp button) (null button)) button @@ -402,7 +432,9 @@ POS may be either a buffer position or a mouse-event. If USE-MOUSE-ACTION is non-nil, invoke the button's mouse-action instead of its normal action; if the button has no mouse-action, the normal action is used instead. The action may be either a -function to call or a marker to display. +function to call or a marker to display and is invoked using +`button-activate' (which see). + POS defaults to point, except when `push-button' is invoked interactively as the result of a mouse-event, in which case, the mouse event is used. @@ -414,11 +446,13 @@ return t." ;; POS is a mouse event; switch to the proper window/buffer (let ((posn (event-start pos))) (with-current-buffer (window-buffer (posn-window posn)) - (push-button (posn-point posn) t))) + (if (posn-string posn) + ;; mode-line, header-line, or display string event. + (button-activate (posn-string posn) t) + (push-button (posn-point posn)) t))) ;; POS is just normal position (let ((button (button-at (or pos (point))))) - (if (not button) - nil + (when button (button-activate button use-mouse-action) t)))) @@ -477,5 +511,4 @@ Returns the button found." (provide 'button) -;; arch-tag: 5f2c7627-413b-4097-b282-630f89d9c5e9 ;;; button.el ends here