| 1 | ;;; sun-mouse.el --- mouse handling for Sun windows |
| 2 | |
| 3 | ;; Copyright (C) 1987 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Jeff Peck |
| 6 | ;; Maintainer: FSF |
| 7 | ;; Keywords: hardware |
| 8 | |
| 9 | ;; This file is part of GNU Emacs. |
| 10 | |
| 11 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 12 | ;; it under the terms of the GNU General Public License as published by |
| 13 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 14 | ;; any later version. |
| 15 | |
| 16 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 19 | ;; GNU General Public License for more details. |
| 20 | |
| 21 | ;; You should have received a copy of the GNU General Public License |
| 22 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 23 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 24 | ;; Boston, MA 02111-1307, USA. |
| 25 | |
| 26 | ;;; Commentary: |
| 27 | |
| 28 | ;; Jeff Peck, Sun Microsystems, Jan 1987. |
| 29 | ;; Original idea by Stan Jefferson |
| 30 | |
| 31 | ;; Modeled after the GNUEMACS keymap interface. |
| 32 | ;; |
| 33 | ;; User Functions: |
| 34 | ;; make-mousemap, copy-mousemap, |
| 35 | ;; define-mouse, global-set-mouse, local-set-mouse, |
| 36 | ;; use-global-mousemap, use-local-mousemap, |
| 37 | ;; mouse-lookup, describe-mouse-bindings |
| 38 | ;; |
| 39 | ;; Options: |
| 40 | ;; extra-click-wait, scrollbar-width |
| 41 | |
| 42 | ;;; Code: |
| 43 | |
| 44 | (defvar extra-click-wait 150 |
| 45 | "*Number of milliseconds to wait for an extra click. |
| 46 | Set this to zero if you don't want chords or double clicks.") |
| 47 | |
| 48 | (defvar scrollbar-width 5 |
| 49 | "*The character width of the scrollbar. |
| 50 | The cursor is deemed to be in the right edge scrollbar if it is this near the |
| 51 | right edge, and more than two chars past the end of the indicated line. |
| 52 | Setting to nil limits the scrollbar to the edge or vertical dividing bar.") |
| 53 | \f |
| 54 | ;;; |
| 55 | ;;; Mousemaps |
| 56 | ;;; |
| 57 | (defun make-mousemap () |
| 58 | "Returns a new mousemap." |
| 59 | (cons 'mousemap nil)) |
| 60 | |
| 61 | (defun copy-mousemap (mousemap) |
| 62 | "Return a copy of mousemap." |
| 63 | (copy-alist mousemap)) |
| 64 | |
| 65 | (defun define-mouse (mousemap mouse-list def) |
| 66 | "Args MOUSEMAP, MOUSE-LIST, DEF. Define MOUSE-LIST in MOUSEMAP as DEF. |
| 67 | MOUSE-LIST is a list of atoms specifying a mouse hit according to these rules: |
| 68 | * One of these atoms specifies the active region of the definition. |
| 69 | text, scrollbar, modeline, minibuffer |
| 70 | * One or two or these atoms specify the button or button combination. |
| 71 | left, middle, right, double |
| 72 | * Any combination of these atoms specify the active shift keys. |
| 73 | control, shift, meta |
| 74 | * With a single unshifted button, you can add |
| 75 | up |
| 76 | to indicate an up-click. |
| 77 | The atom `double' is used with a button designator to denote a double click. |
| 78 | Two button chords are denoted by listing the two buttons. |
| 79 | See sun-mouse-handler for the treatment of the form DEF." |
| 80 | (mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def)) |
| 81 | |
| 82 | (defun global-set-mouse (mouse-list def) |
| 83 | "Give MOUSE-EVENT-LIST a local definition of DEF. |
| 84 | See define-mouse for a description of MOUSE-EVENT-LIST and DEF. |
| 85 | Note that if MOUSE-EVENT-LIST has a local definition in the current buffer, |
| 86 | that local definition will continue to shadow any global definition." |
| 87 | (interactive "xMouse event: \nxDefinition: ") |
| 88 | (define-mouse current-global-mousemap mouse-list def)) |
| 89 | |
| 90 | (defun local-set-mouse (mouse-list def) |
| 91 | "Give MOUSE-EVENT-LIST a local definition of DEF. |
| 92 | See define-mouse for a description of the arguments. |
| 93 | The definition goes in the current buffer's local mousemap. |
| 94 | Normally buffers in the same major mode share a local mousemap." |
| 95 | (interactive "xMouse event: \nxDefinition: ") |
| 96 | (if (null current-local-mousemap) |
| 97 | (setq current-local-mousemap (make-mousemap))) |
| 98 | (define-mouse current-local-mousemap mouse-list def)) |
| 99 | |
| 100 | (defun use-global-mousemap (mousemap) |
| 101 | "Selects MOUSEMAP as the global mousemap." |
| 102 | (setq current-global-mousemap mousemap)) |
| 103 | |
| 104 | (defun use-local-mousemap (mousemap) |
| 105 | "Selects MOUSEMAP as the local mousemap. |
| 106 | nil for MOUSEMAP means no local mousemap." |
| 107 | (setq current-local-mousemap mousemap)) |
| 108 | |
| 109 | \f |
| 110 | ;;; |
| 111 | ;;; Interface to the Mouse encoding defined in Emacstool.c |
| 112 | ;;; |
| 113 | ;;; Called when mouse-prefix is sent to emacs, additional |
| 114 | ;;; information is read in as a list (button x y time-delta) |
| 115 | ;;; |
| 116 | ;;; First, some generally useful functions: |
| 117 | ;;; |
| 118 | |
| 119 | (defun logtest (x y) |
| 120 | "True if any bits set in X are also set in Y. |
| 121 | Just like the Common Lisp function of the same name." |
| 122 | (not (zerop (logand x y)))) |
| 123 | |
| 124 | |
| 125 | ;;; |
| 126 | ;;; Hit accessors. |
| 127 | ;;; |
| 128 | |
| 129 | (defconst sm::ButtonBits 7) ; Lowest 3 bits. |
| 130 | (defconst sm::ShiftmaskBits 56) ; Second lowest 3 bits (56 = 63 - 7). |
| 131 | (defconst sm::DoubleBits 64) ; Bit 7. |
| 132 | (defconst sm::UpBits 128) ; Bit 8. |
| 133 | |
| 134 | ;;; All the useful code bits |
| 135 | (defmacro sm::hit-code (hit) |
| 136 | `(nth 0 ,hit)) |
| 137 | ;;; The button, or buttons if a chord. |
| 138 | (defmacro sm::hit-button (hit) |
| 139 | `(logand sm::ButtonBits (nth 0 ,hit))) |
| 140 | ;;; The shift, control, and meta flags. |
| 141 | (defmacro sm::hit-shiftmask (hit) |
| 142 | `(logand sm::ShiftmaskBits (nth 0 ,hit))) |
| 143 | ;;; Set if a double click (but not a chord). |
| 144 | (defmacro sm::hit-double (hit) |
| 145 | `(logand sm::DoubleBits (nth 0 ,hit))) |
| 146 | ;;; Set on button release (as opposed to button press). |
| 147 | (defmacro sm::hit-up (hit) |
| 148 | `(logand sm::UpBits (nth 0 ,hit))) |
| 149 | ;;; Screen x position. |
| 150 | (defmacro sm::hit-x (hit) (list 'nth 1 hit)) |
| 151 | ;;; Screen y position. |
| 152 | (defmacro sm::hit-y (hit) (list 'nth 2 hit)) |
| 153 | ;;; Milliseconds since last hit. |
| 154 | (defmacro sm::hit-delta (hit) (list 'nth 3 hit)) |
| 155 | |
| 156 | (defmacro sm::hit-up-p (hit) ; A predicate. |
| 157 | `(not (zerop (sm::hit-up ,hit)))) |
| 158 | |
| 159 | ;;; |
| 160 | ;;; Loc accessors. for sm::window-xy |
| 161 | ;;; |
| 162 | (defmacro sm::loc-w (loc) (list 'nth 0 loc)) |
| 163 | (defmacro sm::loc-x (loc) (list 'nth 1 loc)) |
| 164 | (defmacro sm::loc-y (loc) (list 'nth 2 loc)) |
| 165 | |
| 166 | (defmacro eval-in-buffer (buffer &rest forms) |
| 167 | "Macro to switches to BUFFER, evaluates FORMS, returns to original buffer." |
| 168 | ;; When you don't need the complete window context of eval-in-window |
| 169 | `(let ((StartBuffer (current-buffer))) |
| 170 | (unwind-protect |
| 171 | (progn |
| 172 | (set-buffer ,buffer) |
| 173 | ,@forms) |
| 174 | (set-buffer StartBuffer)))) |
| 175 | |
| 176 | (put 'eval-in-buffer 'lisp-indent-function 1) |
| 177 | |
| 178 | ;;; this is used extensively by sun-fns.el |
| 179 | ;;; |
| 180 | (defmacro eval-in-window (window &rest forms) |
| 181 | "Switch to WINDOW, evaluate FORMS, return to original window." |
| 182 | `(let ((OriginallySelectedWindow (selected-window))) |
| 183 | (unwind-protect |
| 184 | (progn |
| 185 | (select-window ,window) |
| 186 | ,@forms) |
| 187 | (select-window OriginallySelectedWindow)))) |
| 188 | (put 'eval-in-window 'lisp-indent-function 1) |
| 189 | |
| 190 | ;;; |
| 191 | ;;; handy utility, generalizes window_loop |
| 192 | ;;; |
| 193 | |
| 194 | ;;; It's a macro (and does not evaluate its arguments). |
| 195 | (defmacro eval-in-windows (form &optional yesmini) |
| 196 | "Switches to each window and evaluates FORM. Optional argument |
| 197 | YESMINI says to include the minibuffer as a window. |
| 198 | This is a macro, and does not evaluate its arguments." |
| 199 | `(let ((OriginallySelectedWindow (selected-window))) |
| 200 | (unwind-protect |
| 201 | (while (progn |
| 202 | ,form |
| 203 | (not (eq OriginallySelectedWindow |
| 204 | (select-window |
| 205 | (next-window nil ,yesmini)))))) |
| 206 | (select-window OriginallySelectedWindow)))) |
| 207 | (put 'eval-in-window 'lisp-indent-function 0) |
| 208 | |
| 209 | (defun move-to-loc (x y) |
| 210 | "Move cursor to window location X, Y. |
| 211 | Handles wrapped and horizontally scrolled lines correctly." |
| 212 | (move-to-window-line y) |
| 213 | ;; window-line-end expects this to return the window column it moved to. |
| 214 | (let ((cc (current-column)) |
| 215 | (nc (move-to-column |
| 216 | (if (zerop (window-hscroll)) |
| 217 | (+ (current-column) |
| 218 | (min (- (window-width) 2) ; To stay on the line. |
| 219 | x)) |
| 220 | (+ (window-hscroll) -1 |
| 221 | (min (1- (window-width)) ; To stay on the line. |
| 222 | x)))))) |
| 223 | (- nc cc))) |
| 224 | |
| 225 | |
| 226 | (defun minibuffer-window-p (window) |
| 227 | "True iff this WINDOW is minibuffer." |
| 228 | (= (frame-height) |
| 229 | (nth 3 (window-edges window)) ; The bottom edge. |
| 230 | )) |
| 231 | |
| 232 | \f |
| 233 | (defun sun-mouse-handler (&optional hit) |
| 234 | "Evaluates the function or list associated with a mouse hit. |
| 235 | Expecting to read a hit, which is a list: (button x y delta). |
| 236 | A form bound to button by define-mouse is found by mouse-lookup. |
| 237 | The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound. |
| 238 | If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*, |
| 239 | *mouse-x*, and *mouse-y* as arguments; if the form is a list (listp), |
| 240 | the form is eval'ed; if the form is neither of these, it is an error. |
| 241 | Returns nil." |
| 242 | (interactive) |
| 243 | (if (null hit) (setq hit (sm::combined-hits))) |
| 244 | (let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit)))) |
| 245 | (let ((*mouse-window* (sm::loc-w loc)) |
| 246 | (*mouse-x* (sm::loc-x loc)) |
| 247 | (*mouse-y* (sm::loc-y loc)) |
| 248 | (mouse-code (mouse-event-code hit loc))) |
| 249 | (let ((form (eval-in-buffer (window-buffer *mouse-window*) |
| 250 | (mouse-lookup mouse-code)))) |
| 251 | (cond ((null form) |
| 252 | (if (not (sm::hit-up-p hit)) ; undefined up hits are ok. |
| 253 | (error "Undefined mouse event: %s" |
| 254 | (prin1-to-string |
| 255 | (mouse-code-to-mouse-list mouse-code))))) |
| 256 | ((symbolp form) |
| 257 | (setq this-command form) |
| 258 | (funcall form *mouse-window* *mouse-x* *mouse-y*)) |
| 259 | ((listp form) |
| 260 | (setq this-command (car form)) |
| 261 | (eval form)) |
| 262 | (t |
| 263 | (error "Mouse action must be symbol or list, but was: %s" |
| 264 | form)))))) |
| 265 | ;; Don't let 'sun-mouse-handler get on last-command, |
| 266 | ;; since this function should be transparent. |
| 267 | (if (eq this-command 'sun-mouse-handler) |
| 268 | (setq this-command last-command)) |
| 269 | ;; (message (prin1-to-string this-command)) ; to see what your buttons did |
| 270 | nil) |
| 271 | |
| 272 | (defun sm::combined-hits () |
| 273 | "Read and return next mouse-hit, include possible double click" |
| 274 | (let ((hit1 (mouse-hit-read))) |
| 275 | (if (not (sm::hit-up-p hit1)) ; Up hits don't start doubles or chords. |
| 276 | (let ((hit2 (mouse-second-hit extra-click-wait))) |
| 277 | (if hit2 ; we cons'd it, we can smash it. |
| 278 | ; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...)) |
| 279 | (setcar hit1 (logior (sm::hit-code hit1) |
| 280 | (sm::hit-code hit2) |
| 281 | (if (= (sm::hit-button hit1) |
| 282 | (sm::hit-button hit2)) |
| 283 | sm::DoubleBits 0)))))) |
| 284 | hit1)) |
| 285 | |
| 286 | (defun mouse-hit-read () |
| 287 | "Read mouse-hit list from keyboard. Like (read 'read-char), |
| 288 | but that uses minibuffer, and mucks up last-command." |
| 289 | (let ((char-list nil) (char nil)) |
| 290 | (while (not (equal 13 ; Carriage return. |
| 291 | (prog1 (setq char (read-char)) |
| 292 | (setq char-list (cons char char-list)))))) |
| 293 | (read (mapconcat 'char-to-string (nreverse char-list) "")) |
| 294 | )) |
| 295 | |
| 296 | ;;; Second Click Hackery.... |
| 297 | ;;; if prefix is not mouse-prefix, need a way to unread the char... |
| 298 | ;;; or else have mouse flush input queue, or else need a peek at next char. |
| 299 | |
| 300 | ;;; There is no peek, but since one character can be unread, we only |
| 301 | ;;; have to flush the queue when the command after a mouse click |
| 302 | ;;; starts with mouse-prefix1 (see below). |
| 303 | ;;; Something to do later: We could buffer the read commands and |
| 304 | ;;; execute them ourselves after doing the mouse command (using |
| 305 | ;;; lookup-key ??). |
| 306 | |
| 307 | (defvar mouse-prefix1 24 ; C-x |
| 308 | "First char of mouse-prefix. Used to detect double clicks and chords.") |
| 309 | |
| 310 | (defvar mouse-prefix2 0 ; C-@ |
| 311 | "Second char of mouse-prefix. Used to detect double clicks and chords.") |
| 312 | |
| 313 | |
| 314 | (defun mouse-second-hit (hit-wait) |
| 315 | "Returns the next mouse hit occurring within HIT-WAIT milliseconds." |
| 316 | (if (sit-for-millisecs hit-wait) nil ; No input within hit-wait millisecs. |
| 317 | (let ((pc1 (read-char))) |
| 318 | (if (or (not (equal pc1 mouse-prefix1)) |
| 319 | (sit-for-millisecs 3)) ; a mouse prefix will have second char |
| 320 | ;; Can get away with one unread. |
| 321 | (progn (setq unread-command-events (list pc1)) |
| 322 | nil) ; Next input not mouse event. |
| 323 | (let ((pc2 (read-char))) |
| 324 | (if (not (equal pc2 mouse-prefix2)) |
| 325 | (progn (setq unread-command-events (list pc1)) ; put back the ^X |
| 326 | ;;; Too bad can't do two: (setq unread-command-event (list pc1 pc2)) |
| 327 | ;;; Well, now we can, but I don't understand this code well enough to fix it... |
| 328 | (ding) ; user will have to retype that pc2. |
| 329 | nil) ; This input is not a mouse event. |
| 330 | ;; Next input has mouse prefix and is within time limit. |
| 331 | (let ((new-hit (mouse-hit-read))) ; Read the new hit. |
| 332 | (if (sm::hit-up-p new-hit) ; Ignore up events when timing. |
| 333 | (mouse-second-hit (- hit-wait (sm::hit-delta new-hit))) |
| 334 | new-hit ; New down hit within limit, return it. |
| 335 | )))))))) |
| 336 | \f |
| 337 | (defun sm::window-xy (x y) |
| 338 | "Find window containing screen coordinates X and Y. |
| 339 | Returns list (window x y) where x and y are relative to window." |
| 340 | (or |
| 341 | (catch 'found |
| 342 | (eval-in-windows |
| 343 | (let ((we (window-edges (selected-window)))) |
| 344 | (let ((le (nth 0 we)) |
| 345 | (te (nth 1 we)) |
| 346 | (re (nth 2 we)) |
| 347 | (be (nth 3 we))) |
| 348 | (if (= re (frame-width)) |
| 349 | ;; include the continuation column with this window |
| 350 | (setq re (1+ re))) |
| 351 | (if (= be (frame-height)) |
| 352 | ;; include partial line at bottom of frame with this window |
| 353 | ;; id est, if window is not multiple of char size. |
| 354 | (setq be (1+ be))) |
| 355 | |
| 356 | (if (and (>= x le) (< x re) |
| 357 | (>= y te) (< y be)) |
| 358 | (throw 'found |
| 359 | (list (selected-window) (- x le) (- y te)))))) |
| 360 | t)) ; include minibuffer in eval-in-windows |
| 361 | ;;If x,y from a real mouse click, we shouldn't get here. |
| 362 | (list nil x y) |
| 363 | )) |
| 364 | |
| 365 | (defun sm::window-region (loc) |
| 366 | "Parse LOC into a region symbol. |
| 367 | Returns one of (text scrollbar modeline minibuffer)" |
| 368 | (let ((w (sm::loc-w loc)) |
| 369 | (x (sm::loc-x loc)) |
| 370 | (y (sm::loc-y loc))) |
| 371 | (let ((right (1- (window-width w))) |
| 372 | (bottom (1- (window-height w)))) |
| 373 | (cond ((minibuffer-window-p w) 'minibuffer) |
| 374 | ((>= y bottom) 'modeline) |
| 375 | ((>= x right) 'scrollbar) |
| 376 | ;; far right column (window separator) is always a scrollbar |
| 377 | ((and scrollbar-width |
| 378 | ;; mouse within scrollbar-width of edge. |
| 379 | (>= x (- right scrollbar-width)) |
| 380 | ;; mouse a few chars past the end of line. |
| 381 | (>= x (+ 2 (window-line-end w x y)))) |
| 382 | 'scrollbar) |
| 383 | (t 'text))))) |
| 384 | |
| 385 | (defun window-line-end (w x y) |
| 386 | "Return WINDOW column (ignore X) containing end of line Y" |
| 387 | (eval-in-window w (save-excursion (move-to-loc (frame-width) y)))) |
| 388 | \f |
| 389 | ;;; |
| 390 | ;;; The encoding of mouse events into a mousemap. |
| 391 | ;;; These values must agree with coding in emacstool: |
| 392 | ;;; |
| 393 | (defconst sm::keyword-alist |
| 394 | '((left . 1) (middle . 2) (right . 4) |
| 395 | (shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128) |
| 396 | (text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048) |
| 397 | )) |
| 398 | |
| 399 | (defun mouse-event-code (hit loc) |
| 400 | "Maps MOUSE-HIT and LOC into a mouse-code." |
| 401 | ;;;Region is a code for one of text, modeline, scrollbar, or minibuffer. |
| 402 | (logior (sm::hit-code hit) |
| 403 | (mouse-region-to-code (sm::window-region loc)))) |
| 404 | |
| 405 | (defun mouse-region-to-code (region) |
| 406 | "Returns partial mouse-code for specified REGION." |
| 407 | (cdr (assq region sm::keyword-alist))) |
| 408 | |
| 409 | (defun mouse-list-to-mouse-code (mouse-list) |
| 410 | "Map a MOUSE-LIST to a mouse-code." |
| 411 | (apply 'logior |
| 412 | (mapcar (function (lambda (x) |
| 413 | (cdr (assq x sm::keyword-alist)))) |
| 414 | mouse-list))) |
| 415 | |
| 416 | (defun mouse-code-to-mouse-list (mouse-code) |
| 417 | "Map a MOUSE-CODE to a mouse-list." |
| 418 | (apply 'nconc (mapcar |
| 419 | (function (lambda (x) |
| 420 | (if (logtest mouse-code (cdr x)) |
| 421 | (list (car x))))) |
| 422 | sm::keyword-alist))) |
| 423 | |
| 424 | (defun mousemap-set (code mousemap value) |
| 425 | (let* ((alist (cdr mousemap)) |
| 426 | (assq-result (assq code alist))) |
| 427 | (if assq-result |
| 428 | (setcdr assq-result value) |
| 429 | (setcdr mousemap (cons (cons code value) alist))))) |
| 430 | |
| 431 | (defun mousemap-get (code mousemap) |
| 432 | (cdr (assq code (cdr mousemap)))) |
| 433 | |
| 434 | (defun mouse-lookup (mouse-code) |
| 435 | "Look up MOUSE-EVENT and return the definition. nil means undefined." |
| 436 | (or (mousemap-get mouse-code current-local-mousemap) |
| 437 | (mousemap-get mouse-code current-global-mousemap))) |
| 438 | |
| 439 | ;;; |
| 440 | ;;; I (jpeck) don't understand the utility of the next four functions |
| 441 | ;;; ask Steven Greenbaum <froud@kestrel> |
| 442 | ;;; |
| 443 | (defun mouse-mask-lookup (mask list) |
| 444 | "Args MASK (a bit mask) and LIST (a list of (code . form) pairs). |
| 445 | Returns a list of elements of LIST whose code or'ed with MASK is non-zero." |
| 446 | (let ((result nil)) |
| 447 | (while list |
| 448 | (if (logtest mask (car (car list))) |
| 449 | (setq result (cons (car list) result))) |
| 450 | (setq list (cdr list))) |
| 451 | result)) |
| 452 | |
| 453 | (defun mouse-union (l l-unique) |
| 454 | "Return the union of list of mouse (code . form) pairs L and L-UNIQUE, |
| 455 | where L-UNIQUE is considered to be union'ized already." |
| 456 | (let ((result l-unique)) |
| 457 | (while l |
| 458 | (let ((code-form-pair (car l))) |
| 459 | (if (not (assq (car code-form-pair) result)) |
| 460 | (setq result (cons code-form-pair result)))) |
| 461 | (setq l (cdr l))) |
| 462 | result)) |
| 463 | |
| 464 | (defun mouse-union-first-preferred (l1 l2) |
| 465 | "Return the union of lists of mouse (code . form) pairs L1 and L2, |
| 466 | based on the code's, with preference going to elements in L1." |
| 467 | (mouse-union l2 (mouse-union l1 nil))) |
| 468 | |
| 469 | (defun mouse-code-function-pairs-of-region (region) |
| 470 | "Return a list of (code . function) pairs, where each code is |
| 471 | currently set in the REGION." |
| 472 | (let ((mask (mouse-region-to-code region))) |
| 473 | (mouse-union-first-preferred |
| 474 | (mouse-mask-lookup mask (cdr current-local-mousemap)) |
| 475 | (mouse-mask-lookup mask (cdr current-global-mousemap)) |
| 476 | ))) |
| 477 | \f |
| 478 | ;;; |
| 479 | ;;; Functions for DESCRIBE-MOUSE-BINDINGS |
| 480 | ;;; And other mouse documentation functions |
| 481 | ;;; Still need a good procedure to print out a help sheet in readable format. |
| 482 | ;;; |
| 483 | |
| 484 | (defun one-line-doc-string (function) |
| 485 | "Returns first line of documentation string for FUNCTION. |
| 486 | If there is no documentation string, then the string |
| 487 | \"No documentation\" is returned." |
| 488 | (while (consp function) (setq function (car function))) |
| 489 | (let ((doc (documentation function))) |
| 490 | (if (null doc) |
| 491 | "No documentation." |
| 492 | (string-match "^.*$" doc) |
| 493 | (substring doc 0 (match-end 0))))) |
| 494 | |
| 495 | (defun print-mouse-format (binding) |
| 496 | (princ (car binding)) |
| 497 | (princ ": ") |
| 498 | (mapcar (function |
| 499 | (lambda (mouse-list) |
| 500 | (princ mouse-list) |
| 501 | (princ " "))) |
| 502 | (cdr binding)) |
| 503 | (terpri) |
| 504 | (princ " ") |
| 505 | (princ (one-line-doc-string (car binding))) |
| 506 | (terpri) |
| 507 | ) |
| 508 | |
| 509 | (defun print-mouse-bindings (region) |
| 510 | "Prints mouse-event bindings for REGION." |
| 511 | (mapcar 'print-mouse-format (sm::event-bindings region))) |
| 512 | |
| 513 | (defun sm::event-bindings (region) |
| 514 | "Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION, |
| 515 | where each mouse-list is bound to the function in REGION." |
| 516 | (let ((mouse-bindings (mouse-code-function-pairs-of-region region)) |
| 517 | (result nil)) |
| 518 | (while mouse-bindings |
| 519 | (let* ((code-function-pair (car mouse-bindings)) |
| 520 | (current-entry (assoc (cdr code-function-pair) result))) |
| 521 | (if current-entry |
| 522 | (setcdr current-entry |
| 523 | (cons (mouse-code-to-mouse-list (car code-function-pair)) |
| 524 | (cdr current-entry))) |
| 525 | (setq result (cons (cons (cdr code-function-pair) |
| 526 | (list (mouse-code-to-mouse-list |
| 527 | (car code-function-pair)))) |
| 528 | result)))) |
| 529 | (setq mouse-bindings (cdr mouse-bindings)) |
| 530 | ) |
| 531 | result)) |
| 532 | |
| 533 | (defun describe-mouse-bindings () |
| 534 | "Lists all current mouse-event bindings." |
| 535 | (interactive) |
| 536 | (with-output-to-temp-buffer "*Help*" |
| 537 | (princ "Text Region") (terpri) |
| 538 | (princ "---- ------") (terpri) |
| 539 | (print-mouse-bindings 'text) (terpri) |
| 540 | (princ "Modeline Region") (terpri) |
| 541 | (princ "-------- ------") (terpri) |
| 542 | (print-mouse-bindings 'modeline) (terpri) |
| 543 | (princ "Scrollbar Region") (terpri) |
| 544 | (princ "--------- ------") (terpri) |
| 545 | (print-mouse-bindings 'scrollbar))) |
| 546 | |
| 547 | (defun describe-mouse-briefly (mouse-list) |
| 548 | "Print a short description of the function bound to MOUSE-LIST." |
| 549 | (interactive "xDescribe mouse list briefly: ") |
| 550 | (let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list)))) |
| 551 | (if function |
| 552 | (message "%s runs the command %s" mouse-list function) |
| 553 | (message "%s is undefined" mouse-list)))) |
| 554 | |
| 555 | (defun mouse-help-menu (function-and-binding) |
| 556 | (cons (prin1-to-string (car function-and-binding)) |
| 557 | (menu-create ; Two sub-menu items of form ("String" . nil) |
| 558 | (list (list (one-line-doc-string (car function-and-binding))) |
| 559 | (list (prin1-to-string (cdr function-and-binding))))))) |
| 560 | |
| 561 | (defun mouse-help-region (w x y &optional region) |
| 562 | "Displays a menu of mouse functions callable in this region." |
| 563 | (let* ((region (or region (sm::window-region (list w x y)))) |
| 564 | (mlist (mapcar (function mouse-help-menu) |
| 565 | (sm::event-bindings region))) |
| 566 | (menu (menu-create (cons (list (symbol-name region)) mlist))) |
| 567 | (item (sun-menu-evaluate w 0 y menu)) |
| 568 | ))) |
| 569 | \f |
| 570 | ;;; |
| 571 | ;;; Menu interface functions |
| 572 | ;;; |
| 573 | ;;; use defmenu, because this interface is subject to change |
| 574 | ;;; really need a menu-p, but we use vectorp and the context... |
| 575 | ;;; |
| 576 | (defun menu-create (items) |
| 577 | "Functional form for defmenu, given a list of ITEMS returns a menu. |
| 578 | Each ITEM is a (STRING . VALUE) pair." |
| 579 | (apply 'vector items) |
| 580 | ) |
| 581 | |
| 582 | (defmacro defmenu (menu &rest itemlist) |
| 583 | "Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs. |
| 584 | See sun-menu-evaluate for interpretation of ITEMS." |
| 585 | (list 'defconst menu (funcall 'menu-create itemlist)) |
| 586 | ) |
| 587 | |
| 588 | (defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu) |
| 589 | "Display a pop-up menu in WINDOW at X Y and evaluate selected item |
| 590 | of MENU. MENU (or its symbol-value) should be a menu defined by defmenu. |
| 591 | A menu ITEM is a (STRING . FORM) pair; |
| 592 | the FORM associated with the selected STRING is evaluated, |
| 593 | and the resulting value is returned. Generally these FORMs are |
| 594 | evaluated for their side-effects rather than their values. |
| 595 | If the selected form is a menu or a symbol whose value is a menu, |
| 596 | then it is displayed and evaluated as a pullright menu item. |
| 597 | If the FORM of the first ITEM is nil, the STRING of the item |
| 598 | is used as a label for the menu, i.e. it's inverted and not selectable." |
| 599 | |
| 600 | (if (symbolp menu) (setq menu (symbol-value menu))) |
| 601 | (eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu))) |
| 602 | |
| 603 | (defun sun-get-frame-data (code) |
| 604 | "Sends the tty-sub-window escape sequence CODE to terminal, |
| 605 | and returns a cons of the two numbers in returned escape sequence. |
| 606 | That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\". |
| 607 | CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars." |
| 608 | (send-string-to-terminal (concat "\033[" (int-to-string code) "t")) |
| 609 | (let (char str x y) |
| 610 | (while (not (equal 116 (setq char (read-char)))) ; #\t = 116 |
| 611 | (setq str (cons char str))) |
| 612 | (setq str (mapconcat 'char-to-string (nreverse str) "")) |
| 613 | (string-match ";[0-9]*" str) |
| 614 | (setq y (substring str (1+ (match-beginning 0)) (match-end 0))) |
| 615 | (setq str (substring str (match-end 0))) |
| 616 | (string-match ";[0-9]*" str) |
| 617 | (setq x (substring str (1+ (match-beginning 0)) (match-end 0))) |
| 618 | (cons (string-to-int y) (string-to-int x)))) |
| 619 | |
| 620 | (defun sm::font-size () |
| 621 | "Returns font size in pixels: (cons Ysize Xsize)" |
| 622 | (let ((pix (sun-get-frame-data 14)) ; returns size in pixels |
| 623 | (chr (sun-get-frame-data 18))) ; returns size in chars |
| 624 | (cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr))))) |
| 625 | |
| 626 | (defvar sm::menu-kludge-x nil |
| 627 | "Cached frame-to-window X-Offset for sm::menu-kludge") |
| 628 | (defvar sm::menu-kludge-y nil |
| 629 | "Cached frame-to-window Y-Offset for sm::menu-kludge") |
| 630 | |
| 631 | (defun sm::menu-kludge () |
| 632 | "If sunfns.c uses <Menu_Base_Kludge> this function must be here!" |
| 633 | (or sm::menu-kludge-y |
| 634 | (let ((fs (sm::font-size))) |
| 635 | (setq sm::menu-kludge-y (+ 8 (car fs)) ; a title line and borders |
| 636 | sm::menu-kludge-x 4))) ; best values depend on .defaults/Menu |
| 637 | (let ((wl (sun-get-frame-data 13))) ; returns frame location |
| 638 | (cons (+ (car wl) sm::menu-kludge-y) |
| 639 | (+ (cdr wl) sm::menu-kludge-x)))) |
| 640 | \f |
| 641 | ;;; |
| 642 | ;;; Function interface to selection/region |
| 643 | ;;; primitive functions are defined in sunfns.c |
| 644 | ;;; |
| 645 | (defun sun-yank-selection () |
| 646 | "Set mark and yank the contents of the current sunwindows selection. |
| 647 | Insert contents into the current buffer at point." |
| 648 | (interactive "*") |
| 649 | (set-mark-command nil) |
| 650 | (insert (sun-get-selection))) |
| 651 | |
| 652 | (defun sun-select-region (beg end) |
| 653 | "Set the sunwindows selection to the region in the current buffer." |
| 654 | (interactive "r") |
| 655 | (sun-set-selection (buffer-substring beg end))) |
| 656 | |
| 657 | ;;; |
| 658 | ;;; Support for emacstool |
| 659 | ;;; This closes the window instead of stopping emacs. |
| 660 | ;;; |
| 661 | (defun suspend-emacstool (&optional stuffstring) |
| 662 | "Suspend emacstool. |
| 663 | If running under as a detached process emacstool, |
| 664 | you don't want to suspend (there is no way to resume), |
| 665 | just close the window, and wait for reopening." |
| 666 | (interactive) |
| 667 | (run-hooks 'suspend-hook) |
| 668 | (if stuffstring (send-string-to-terminal stuffstring)) |
| 669 | (send-string-to-terminal "\033[2t") ; To close EmacsTool window. |
| 670 | (run-hooks 'suspend-resume-hook)) |
| 671 | ;;; |
| 672 | ;;; initialize mouse maps |
| 673 | ;;; |
| 674 | |
| 675 | (make-variable-buffer-local 'current-local-mousemap) |
| 676 | (setq-default current-local-mousemap nil) |
| 677 | (defvar current-global-mousemap (make-mousemap)) |
| 678 | |
| 679 | (provide 'sun-mouse) |
| 680 | (provide 'term/sun-mouse) ; have to (require 'term/sun-mouse) |
| 681 | |
| 682 | ;;; arch-tag: 6e879372-b899-4509-833f-d7f6250e309a |
| 683 | ;;; sun-mouse.el ends here |