From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Nick Roberts Newsgroups: gmane.emacs.devel Subject: [PATCH] xt-mouse.el Date: Sun, 9 Jan 2005 19:42:03 +1300 Message-ID: <16864.53819.330845.617109@farnswood.snap.net.nz> NNTP-Posting-Host: deer.gmane.org Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii Content-Transfer-Encoding: 7bit X-Trace: sea.gmane.org 1105254881 11720 80.91.229.6 (9 Jan 2005 07:14:41 GMT) X-Complaints-To: usenet@sea.gmane.org NNTP-Posting-Date: Sun, 9 Jan 2005 07:14:41 +0000 (UTC) Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Sun Jan 09 08:14:33 2005 Return-path: Original-Received: from lists.gnu.org ([199.232.76.165]) by deer.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 1CnXHV-0007zS-00 for ; Sun, 09 Jan 2005 08:14:33 +0100 Original-Received: from localhost ([127.0.0.1] helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1CnXSw-00064k-Lt for ged-emacs-devel@m.gmane.org; Sun, 09 Jan 2005 02:26:22 -0500 Original-Received: from mailman by lists.gnu.org with tmda-scanned (Exim 4.43) id 1CnXNj-00053V-76 for emacs-devel@gnu.org; Sun, 09 Jan 2005 02:21:00 -0500 Original-Received: from exim by lists.gnu.org with spam-scanned (Exim 4.43) id 1CnXNb-0004zV-5J for emacs-devel@gnu.org; Sun, 09 Jan 2005 02:20:51 -0500 Original-Received: from [199.232.76.173] (helo=monty-python.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1CnXNa-0004ov-L3 for emacs-devel@gnu.org; Sun, 09 Jan 2005 02:20:50 -0500 Original-Received: from [202.37.101.8] (helo=viper.snap.net.nz) by monty-python.gnu.org with esmtp (Exim 4.34) id 1CnWtQ-0006mB-Ea for emacs-devel@gnu.org; Sun, 09 Jan 2005 01:49:41 -0500 Original-Received: from farnswood.snap.net.nz (p60-tnt1.snap.net.nz [202.124.110.60]) by viper.snap.net.nz (Postfix) with ESMTP id 86FB91B5389 for ; Sun, 9 Jan 2005 19:49:30 +1300 (NZDT) Original-Received: by farnswood.snap.net.nz (Postfix, from userid 501) id 0D0EC628AD; Sun, 9 Jan 2005 06:42:05 +0000 (GMT) Original-To: emacs-devel@gnu.org X-Mailer: VM 7.19 under Emacs 21.3.50.25 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane.org@gnu.org Xref: main.gmane.org gmane.emacs.devel:32068 X-Report-Spam: http://spam.gmane.org/gmane.emacs.devel:32068 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