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