bug#12817: 24.2; The button library does not work on the header line

bug#12817: 24.2; The button library does not work on the header line

[Damien Cassou]

Hi,

the button library does not work if a button is created on the
header-line:

  (require 'button)

  (defun my-button-action (button)
    (message "HERE I AM"))

  (define-button-type 'my-button-type
    'action #'my-button-action
    'follow-link t)

  (setq test-button (copy-sequence "CLICK ME"))

  (make-text-button test-button nil
                    'type 'my-button-type)

  (setq header-line-format test-button)

After evaluating these lines, a button appear with the text "CLICK ME"
in blue and underlined. But clicking this button does nothing. I was
expecting that clicking the button would trigger 'my-button-action and
display the message "HERE I AM".

There is a library that makes 'button work on header-line: 
https://raw.github.com/tarsius/header-button/master/header-button.el

Thank you

In GNU Emacs 24.2.1 (i686-pc-linux-gnu, GTK+ Version 2.24.13)
 of 2012-11-06 on dubnium, modified by Debian
Windowing system distributor `The X.Org Foundation', version 11.0.11300000
Configured using:
 `configure '--build' 'i686-linux-gnu' '--build' 'i686-linux-gnu'
 '--prefix=/usr' '--sharedstatedir=/var/lib' '--libexecdir=/usr/lib'
 '--localstatedir=/var/lib' '--infodir=/usr/share/info'
 '--mandir=/usr/share/man' '--with-pop=yes'
 '--enable-locallisppath=/etc/emacs24:/etc/emacs:/usr/local/share/emacs/24.2/site-lisp:/usr/local/share/emacs/site-lisp:/usr/share/emacs/24.2/site-lisp:/usr/share/emacs/site-lisp'
 '--with-crt-dir=/usr/lib/i386-linux-gnu' '--with-x=yes'
 '--with-x-toolkit=gtk' '--with-toolkit-scroll-bars'
 'build_alias=i686-linux-gnu' 'CFLAGS=-g -O2 -fstack-protector
 --param=ssp-buffer-size=4 -Wformat -Werror=format-security -Wall'
 'LDFLAGS=-Wl,-Bsymbolic-functions -Wl,-z,relro'
 'CPPFLAGS=-D_FORTIFY_SOURCE=2''

Important settings:
  value of $LC_ALL: nil
  value of $LC_COLLATE: nil
  value of $LC_CTYPE: nil
  value of $LC_MESSAGES: nil
  value of $LC_MONETARY: nil
  value of $LC_NUMERIC: nil
  value of $LC_TIME: nil
  value of $LANG: en_US.UTF-8
  value of $XMODIFIERS: nil
  locale-coding-system: utf-8-unix
  default enable-multibyte-characters: t

Major mode: Lisp Interaction

Minor modes in effect:
  tooltip-mode: t
  mouse-wheel-mode: t
  tool-bar-mode: t
  menu-bar-mode: t
  file-name-shadow-mode: t
  global-font-lock-mode: t
  font-lock-mode: t
  blink-cursor-mode: t
  auto-composition-mode: t
  auto-encryption-mode: t
  auto-compression-mode: t
  line-number-mode: t
  transient-mark-mode: t

Recent input:
<help-echo> <down-mouse-1> <mouse-1> <down-mouse-4> 
<mouse-4> <double-down-mouse-4> <double-mouse-4> <triple-down-mouse-4> 
<triple-mouse-4> C-n C-n C-n C-n C-n C-n C-n C-n C-n 
C-n C-n C-n C-n C-n C-n C-n C-n C-n C-n C-M-x C-l C-l 
C-n C-n C-n C-n C-n C-n C-n C-n C-n C-n C-n C-n C-n 
C-n C-n C-n C-n C-n C-n C-n C-n C-n C-n C-n C-M-x C-n 
C-n C-n C-n C-n C-n C-n C-n C-M-x C-n C-l C-l C-n C-n 
C-n C-n C-n C-a C-SPC M-> C-w C-y M-y C-p C-k C-M-x 
C-y C-p C-p C-p C-p C-p C-p C-p C-p C-p C-p C-p C-p 
C-p C-p C-p C-p C-l C-a C-SPC C-n C-n C-f C-f C-x r 
k C-p C-p <tab> C-n <tab> C-n <tab> M-v M-v C-v C-v 
C-l C-p C-p C-p C-e C-n C-a C-k C-n C-SPC C-n C-n C-f 
C-f C-f C-x r k C-p <tab> C-n <tab> C-e C-x C-e q C-p 
C-p C-p C-p C-x C-e C-n C-n C-n C-n C-e C-x C-e <help-echo> 
<down-mouse-1> <mouse-1> <down-mouse-1> <mouse-1> <help-echo> 
<down-mouse-1> <mouse-1> C-n C-n C-n C-n C-a C-SPC 
C-n C-n C-n C-f C-f C-f C-x r k C-e C-x C-e <help-echo> 
<help-echo> <help-echo> <down-mouse-1> <mouse-1> <help-echo> 
<down-mouse-4> <mouse-4> <down-mouse-4> <mouse-4> <down-mouse-4> 
<mouse-4> <down-mouse-4> <mouse-4> <down-mouse-4> <mouse-4> 
<down-mouse-4> <mouse-4> <double-down-mouse-4> <double-mouse-4> 
<triple-down-mouse-4> <triple-mouse-4> <triple-down-mouse-4> 
<triple-mouse-4> <down-mouse-1> <mouse-movement> <drag-mouse-1> 
C-x 1 <down-mouse-1> <mouse-movement> <mouse-1> <help-echo> 
<down-mouse-1> <mouse-1> <help-echo> <down-mouse-1> 
<mouse-1> <help-echo> <down-mouse-1> <mouse-1> <help-echo> 
<down-mouse-1> <mouse-1> <help-echo> <down-mouse-1> 
<mouse-1> <help-echo> <down-mouse-5> <mouse-5> <double-down-mouse-5> 
<double-mouse-5> <triple-down-mouse-5> <triple-mouse-5> 
<down-mouse-1> <mouse-1> <down-mouse-1> <mouse-1> C-p 
C-p C-SPC C-p C-p C-p C-p C-a C-w C-x C-o C-n C-SPC 
M-> <f2> <f2> <f2> C-x 1 C-x 1 C-p C-p C-p <tab> C-n 
<tab> C-n <tab> <down-mouse-1> <mouse-1> C-h k <f2> 
<f2> C-x 1 <down-mouse-1> <mouse-1> C-l <down-mouse-1> 
<mouse-movement> <drag-mouse-1> M-x r e p o r t - e 
m a <tab> <tab> <return>

Recent messages:
This button labeled `No me!' belongs to category `my-header-button'
byte-code: Beginning of buffer
Mark set
This button labeled `Click me!' belongs to category `header-button' [2 times]
This button labeled `No me!' belongs to category `my-header-button'
Mark set [2 times]
Autoscrolling is on.
Type C-x 1 to delete the help window.
Mark set
Making completion list...

Load-path shadows:
/usr/share/emacs/24.2/site-lisp/cmake-data/cmake-mode hides /usr/share/emacs/site-lisp/cmake-mode
/usr/share/emacs/24.2/site-lisp/dictionaries-common/flyspell hides /usr/share/emacs/24.2/lisp/textmodes/flyspell
/usr/share/emacs/24.2/site-lisp/dictionaries-common/ispell hides /usr/share/emacs/24.2/lisp/textmodes/ispell

Features:
(shadow sort gnus-util mail-extr emacsbug message format-spec rfc822 mml
mml-sec mm-decode mm-bodies mm-encode mail-parse rfc2231 mailabbrev
gmm-utils mailheader sendmail regexp-opt rfc2047 rfc2045 ietf-drums
mm-util mail-prsvr mail-utils two-column debug rect help-mode view
help-fns find-func jka-compr info easymenu edmacro kmacro cl time-date
tooltip ediff-hook vc-hooks lisp-float-type mwheel x-win x-dnd tool-bar
dnd fontset image fringe lisp-mode register page menu-bar rfn-eshadow
timer select scroll-bar mouse jit-lock font-lock syntax facemenu
font-core frame cham georgian utf-8-lang misc-lang vietnamese tibetan
thai tai-viet lao korean japanese hebrew greek romanian slovak czech
european ethiopic indian cyrillic chinese case-table epa-hook
jka-cmpr-hook help simple abbrev minibuffer loaddefs button faces
cus-face files text-properties overlay sha1 md5 base64 format env
code-pages mule custom widget hashtable-print-readable backquote
make-network-process dbusbind dynamic-setting system-font-setting
font-render-setting move-toolbar gtk x-toolkit x multi-tty emacs)

bug#12817: 24.2; The button library does not work on the header line

[Stefan Monnier]

> the button library does not work if a button is created on the header-line:

>   (require 'button)
>   (defun my-button-action (button)
>     (message "HERE I AM"))
>   (define-button-type 'my-button-type
>     'action #'my-button-action
>     'follow-link t)
>   (setq test-button (copy-sequence "CLICK ME"))
>   (make-text-button test-button nil
>                     'type 'my-button-type)
>   (setq header-line-format test-button)

> After evaluating these lines, a button appear with the text "CLICK ME"
> in blue and underlined. But clicking this button does nothing. I was
> expecting that clicking the button would trigger 'my-button-action and
> display the message "HERE I AM".

Sounds like a reasonable expectation.

> There is a library that makes 'button work on header-line: 
> https://raw.github.com/tarsius/header-button/master/header-button.el

Would someone be able to turn the above code into a patch to button.el
that makes your sample code work (i.e. make `make-text-button' work in
a header, instead of introducing an ad-hoc `header-button-format')?


        Stefan


PS: BTW, the "follow-link does not work here" comment points at
a misfeature of follow-link, indeed.  I think `follow-link' should be
implemented in function-key-map rather than in mouse-drag-region.

bug#12817: 24.2; The button library does not work on the header line

[Jonas Bernoulli]

[-- Attachment #1: Type: text/plain, Size: 2192 bytes --]

The attached patch allows inserting buttons into the header-line as well
as the mode-line.  I haven't tested it much but it appears to work.

As you suggested it doesn't use a function such as
`header-button-format'.  Instead `make-text-button' was changed to
return a useful value when BEG is a string: the propertized string.

,----
| (setq header-line-format
|       (make-text-button "test" nil
|                         'action (lambda (button)
|                                   (message "Button: %s" button))))
`----

The above is enough now to insert a button in the header-line or
mode-line.  No need for an intermediate variable to hold the string.
Additionally the following changes are needed so that clicking the
button actually does something.

Add an additional kind of "button object" that is used internally and
passed to the button action function: "area buttons" (analogously to
`posn-area').  Normally these have the form (STRING . STRING-POS), where
STRING is the propertized string and STRING-POS is list of the form
returned by `event-start'.  STRING-POS might be useful in actions but
isn't used internally.  Area button objects can also be just a string.

[mode-line mouse-2] and [header-line mouse-2] are bound to push-button
just like [mouse-2].  [follow-link] is not actually used at all.  (I
think it was used instead of [mouse-2] in the past, but I might be
wrong).

I don't know whether binding these events might cause problems for
regular buttons, but it does not appear to be the case.

(Maybe using follow-link instead and extending it to work in the
header-line and mode-line would be better; but I know to little about
that.  The little I do know tells me doing so would probably not be
worth the effort.)

`push-button', `button-get', `button-put', `button-label' are taught to
deal with area buttons.  Using `button-start', `button-end' and
`button-at' with an area button causes an error.  Of the "button
creating functions" only `make-text-button' is useful for area buttons.
`[next|previous|forward|backward]-button' also cannot be used.

The patch is against 24.3.50 from a few days ago but if necessary I can
redo it against a different version.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-area-buttons.patch --]
[-- Type: text/x-diff, Size: 7063 bytes --]

From e6f0ba57a65badba9cb37443efff5dbcb24f8fb8 Mon Sep 17 00:00:00 2001
From: Jonas Bernoulli <jonas@bernoul.li>
Date: Wed, 5 Dec 2012 21:00:30 +0100
Subject: [PATCH] lisp/button.el: allow inserting buttons into mode-line and
 header-line

* lisp/button.el (make-text-button): if BEG is a string return it;
  previously 0 was returned in that case (bugfix)
* lisp/button.el (button-map): bind [mode-line mouse-2] and
  [header-line mouse-2] to push-button
* lisp/button.el (button-activate): mention area (mode-line and
  header-line) buttons, also add general documentation about action
  invocation
* lisp/button.el (push-button): mention button-activate in doc-string
* lisp/button.el (button-get, button-put, button-label): support
  area buttons
* lisp/button.el: add functions button-area-button-p and
  button-area-button-string
---
 button.el | 87 ++++++++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 64 insertions(+), 23 deletions(-)

diff --git a/button.el b/button.el
index 3cf38fa..7c76587 100644
--- a/button.el
+++ b/button.el
@@ -64,6 +64,8 @@
     ;; might get converted to ^M when building loaddefs.el
     (define-key map [(control ?m)] 'push-button)
     (define-key map [mouse-2] 'push-button)
+    (define-key map [mode-line mouse-2] 'push-button)
+    (define-key map [header-line mouse-2] 'push-button)
     map)
   "Keymap used by buttons.")
 
@@ -184,10 +186,12 @@ 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 0 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."
@@ -202,21 +206,32 @@ 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)))
+  (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))))
 
 (defsubst 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 cons (STRING . STRING-POS); where STRING-POS is a
+list of the form returned by the `event-start' and `event-end'
+functions."
   (let ((action (or (and use-mouse-action (button-get button 'mouse-action))
 		    (button-get button 'action))))
     (if (markerp action)
@@ -228,7 +243,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."
@@ -238,6 +256,26 @@ 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 (button)
+  "Return t if BUTTON is an area button.
+An area button is a cons (STRING . STRING-POS) or a string.
+STRING-POS is a list of the form returned by the `event-start'
+and `event-end' functions.  Such area buttons are used for
+buttons in the mode-line and header-line."
+  (or (stringp button)
+      (and (stringp (car-safe button))
+	   (posnp (cdr-safe button)))))
+
+(defun button-area-button-string (button)
+  "Return area button BUTTON's button-string.
+That is either BUTTON itself or it's car if
+it is a cons (STRING . STRING-POS)."
+  (cond ((stringp button) button)
+	((button-area-button-p button) (car button))
+	(t
+	 (signal 'wrong-type-argument
+		 (list 'button-area-button-p button)))))
+
 \f
 ;; Creating overlay buttons
 
@@ -324,7 +362,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.
@@ -405,23 +443,26 @@ 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.
-If there's no button at POS, do nothing and return nil, otherwise
-return t."
+mouse event is used.  If there's no button at POS, do nothing and
+return nil, otherwise return t."
   (interactive
    (list (if (integerp last-command-event) (point) last-command-event)))
   (if (and (not (integerp pos)) (eventp pos))
       ;; 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-area posn)
+	      ;; mode-line or header-line event
+	      (button-activate (cons (car (posn-string posn)) 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))))
 
-- 
1.8.0.1

bug#12817: 24.2; The button library does not work on the header line

[Damien Cassou]

[-- Attachment #1: Type: text/plain, Size: 2428 bytes --]

Thank you very much Jonas

Damien Cassou
http://damiencassou.seasidehosting.st
On Dec 5, 2012 9:39 PM, "Jonas Bernoulli" <jonas@bernoul.li> wrote:

> The attached patch allows inserting buttons into the header-line as well
> as the mode-line.  I haven't tested it much but it appears to work.
>
> As you suggested it doesn't use a function such as
> `header-button-format'.  Instead `make-text-button' was changed to
> return a useful value when BEG is a string: the propertized string.
>
> ,----
> | (setq header-line-format
> |       (make-text-button "test" nil
> |                         'action (lambda (button)
> |                                   (message "Button: %s" button))))
> `----
>
> The above is enough now to insert a button in the header-line or
> mode-line.  No need for an intermediate variable to hold the string.
> Additionally the following changes are needed so that clicking the
> button actually does something.
>
> Add an additional kind of "button object" that is used internally and
> passed to the button action function: "area buttons" (analogously to
> `posn-area').  Normally these have the form (STRING . STRING-POS), where
> STRING is the propertized string and STRING-POS is list of the form
> returned by `event-start'.  STRING-POS might be useful in actions but
> isn't used internally.  Area button objects can also be just a string.
>
> [mode-line mouse-2] and [header-line mouse-2] are bound to push-button
> just like [mouse-2].  [follow-link] is not actually used at all.  (I
> think it was used instead of [mouse-2] in the past, but I might be
> wrong).
>
> I don't know whether binding these events might cause problems for
> regular buttons, but it does not appear to be the case.
>
> (Maybe using follow-link instead and extending it to work in the
> header-line and mode-line would be better; but I know to little about
> that.  The little I do know tells me doing so would probably not be
> worth the effort.)
>
> `push-button', `button-get', `button-put', `button-label' are taught to
> deal with area buttons.  Using `button-start', `button-end' and
> `button-at' with an area button causes an error.  Of the "button
> creating functions" only `make-text-button' is useful for area buttons.
> `[next|previous|forward|backward]-button' also cannot be used.
>
> The patch is against 24.3.50 from a few days ago but if necessary I can
> redo it against a different version.
>
>

[-- Attachment #2: Type: text/html, Size: 2999 bytes --]

bug#12817: 24.2; The button library does not work on the header line

[Stefan Monnier]

> The attached patch allows inserting buttons into the header-line as well
> as the mode-line.  I haven't tested it much but it appears to work.
> As you suggested it doesn't use a function such as
> `header-button-format'.  Instead `make-text-button' was changed to
> return a useful value when BEG is a string: the propertized string.

Thanks, installed, after simplifying it a bit to just use STRING rather
than (STRING . STRING-POS).


        Stefan