[PATCH] xt-mouse.el

[Nick Roberts]

Here's a patch that makes clicking on the mode-line (and header-line) position
dependent when using Emacs in an xterm. Please note that it contains some code
from t-mouse.el (a powerset generator). The two modes have some natural
overlap and I see that there has been some interaction between the two modes
in the past, as Per Abrahamsen, author of xt-mouse.el is credited with some
functions in t-mouse.el.

Note to RMS: I have no way of determining the authorship of t-mouse.el other
than reading the file header, so I am hoping that Alessandro Rubini will
follow that up.

Nick


*** /home/nick/emacs/lisp/xt-mouse.el.~1.21.~   2004-12-09 21:22:18.000000000 
+1300
--- /home/nick/emacs/lisp/xt-mouse.el   2005-01-09 19:38:35.000000000 +1300
***************
*** 43,56 ****
  
  ;; Support multi-click -- somehow.
  
- ;; Clicking on the mode-line does not work, although it should.
- 
  ;;; Code:
  
  (define-key function-key-map "\e[M" 'xterm-mouse-translate)
  
  (defvar xterm-mouse-last)
  
  (defun xterm-mouse-translate (event)
    "Read a click and release event from XTerm."
    (save-excursion
--- 43,93 ----
  
  ;; Support multi-click -- somehow.
  
  ;;; Code:
  
  (define-key function-key-map "\e[M" 'xterm-mouse-translate)
  
  (defvar xterm-mouse-last)
  
+ ;;; begin LIFTED FROM t-mouse.el
+ ;; now get this:  the Emacs C code that generates these fake events
+ ;; depends on certain things done by the very lowest level input
+ ;; handlers; namely the symbols for the events (for instance
+ ;; 'C-S-double-mouse-2) must have an 'event-kind property, set to
+ ;; 'mouse-click.  Since events from unread-command-events do not pass
+ ;; through the low level handlers, they don't get this property unless
+ ;; I set it myself.  I imagine this has caused innumerable attempts by
+ ;; hackers to do things similar to t-mouse to lose.
+ 
+ ;; The next page of code is devoted to fixing this ugly problem.
+ 
+ ;; WOW! a fully general powerset generator
+ ;; (C) Ian Zimmerman Mon Mar 23 12:00:16 PST 1998 :-)
+ (defun t-mouse-powerset (l)
+   (if (null l) '(nil)
+     (let ((l1 (t-mouse-powerset (cdr l)))
+           (first (nth 0 l)))
+       (append
+        (mapcar (function (lambda (l) (cons first l))) l1) l1))))
+ 
+ ;; and a slightly less general cartesian product
+ (defun t-mouse-cartesian (l1 l2)
+   (if (null l1) l2
+     (append (mapcar (function (lambda (x) (append (nth 0 l1) x))) l2)
+             (t-mouse-cartesian (cdr l1) l2))))
+       
+ (let* ((modifier-sets (t-mouse-powerset '(control meta shift)))
+        (typed-sets (t-mouse-cartesian '((down) (drag))
+                                       '((mouse-1) (mouse-2) (mouse-3))))
+        (multipled-sets (t-mouse-cartesian '((double) (triple)) typed-sets))
+        (all-sets (t-mouse-cartesian modifier-sets multipled-sets)))
+   (while all-sets
+     (let ((event-sym (event-convert-list (nth 0 all-sets))))
+       (if (not (get event-sym 'event-kind))
+           (put event-sym 'event-kind 'mouse-click)))
+     (setq all-sets (cdr all-sets))))
+ ;;; end LIFTED FROM t-mouse.el
+ 
  (defun xterm-mouse-translate (event)
    "Read a click and release event from XTerm."
    (save-excursion
***************
*** 78,84 ****
               (click-where (nth 1 click-data)))
          (if (memq down-binding '(nil ignore))
              (if (and (symbolp click-where)
!                      (not (eq 'menu-bar click-where)))
                  (vector (list click-where click-data) click)
                (vector click))
            (setq unread-command-events
--- 115,121 ----
               (click-where (nth 1 click-data)))
          (if (memq down-binding '(nil ignore))
              (if (and (symbolp click-where)
!                      (consp click-where))
                  (vector (list click-where click-data) click)
                (vector click))
            (setq unread-command-events
***************
*** 92,101 ****
                         0
                       (list (intern (format "drag-mouse-%d"
                                             (+ 1 xterm-mouse-last)))
!                            down-data click-data))
!                    )))
            (if (and (symbolp down-where)
!                    (not (eq 'menu-bar down-where)))
                (vector (list down-where down-data) down)
              (vector down))))))))
  
--- 129,137 ----
                         0
                       (list (intern (format "drag-mouse-%d"
                                             (+ 1 xterm-mouse-last)))
!                            down-data click-data)))))
            (if (and (symbolp down-where)
!                    (consp down-where))
                (vector (list down-where down-data) down)
              (vector down))))))))
  
***************
*** 124,153 ****
    (let* ((type (- (xterm-mouse-event-read) #o40))
         (x (- (xterm-mouse-event-read) #o40 1))
         (y (- (xterm-mouse-event-read) #o40 1))
-        (point (cons x y))
-        (window (window-at x y))
-        (where (if window
-                   (coordinates-in-window-p point window)
-                 'menu-bar))
-        (pos (if (consp where)
-                 (progn
-                   (select-window window)
-                   (goto-char (window-start window))
-                   (move-to-window-line (-
-                                         (cdr where)
-                                         (if (or header-line-format
-                                                 default-header-line-format)
-                                             1
-                                           0)))
-                   (move-to-column (- (+ (car where) (current-column)
-                                      (if (string-match "\\` \\*Minibuf"
-                                                        (buffer-name))
-                                          (- (minibuffer-prompt-width))
-                                        0)
-                                      (max 0 (1- (window-hscroll))))
-                                      left-margin-width))
-                   (point))
-               where))
         (mouse (intern
                 ;; For buttons > 3, the release-event looks
                 ;; differently (see xc/programs/xterm/button.c,
--- 160,165 ----
***************
*** 159,170 ****
                        (format "mouse-%d" (+ 1 xterm-mouse-last)))
                       (t
                        (setq xterm-mouse-last type)
!                       (format "down-mouse-%d" (+ 1 type)))))))
      (setq xterm-mouse-x x
          xterm-mouse-y y)
!     (list mouse
!         (list window pos point
!               (/ (nth 2 (current-time)) 1000)))))
  
  ;;;###autoload
  (define-minor-mode xterm-mouse-mode
--- 171,212 ----
                        (format "mouse-%d" (+ 1 xterm-mouse-last)))
                       (t
                        (setq xterm-mouse-last type)
!                       (format "down-mouse-%d" (+ 1 type))))))
!        (w (window-at x y))
!          (left-top-right-bottom (window-edges w))
!          (left (nth 0 left-top-right-bottom))
!          (top (nth 1 left-top-right-bottom))
!          (right (nth 2 left-top-right-bottom))
!          (bottom (nth 3 left-top-right-bottom))
!        (coords-or-part (if w (coordinates-in-window-p (cons x y) w) nil))
!        (timestamp (/ (nth 2 (current-time)) 1000)))
      (setq xterm-mouse-x x
          xterm-mouse-y y)
!     (cond
!      ((consp coords-or-part)
!       (let ((wx (car coords-or-part)) (wy (cdr coords-or-part)))
!       (select-window w)
!       (goto-char (window-start w))
!       (move-to-window-line (- wy (if (or header-line-format
!                                          default-header-line-format) 1 0)))
!       (move-to-column (- (+ wx (current-column)
!                             (if (string-match "\\` \\*Minibuf" (buffer-name))
!                                 (- (minibuffer-prompt-width)) 0)
!                             (max 0 (1- (window-hscroll))))
!                          left-margin-width))
!       (list mouse (list w (point) coords-or-part timestamp))))
!       ((eq coords-or-part 'mode-line)
!        (list mouse (list w 'mode-line (cons (- x left) 0) timestamp 
!                        (cons (format-mode-line mode-line-format)
!                              (- x left)))))
!       ((eq coords-or-part 'header-line)
!        (list mouse (list w 'header-line (cons (- x left) 0) timestamp
!                        (cons (format-mode-line header-line-format)
!                              (- x left)))))
!       ((eq coords-or-part nil)
!        (list mouse (list w 'menu-bar (cons (- x left) 0) timestamp)))
!       ((eq coords-or-part 'vertical-line)
!        (list mouse (list w 'vertical-line (cons 0 (- y top)) timestamp))))))
  
  ;;;###autoload
  (define-minor-mode xterm-mouse-mode