![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to sun-mouse.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to sun-mouse.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 ! root 1: ;; Mouse handling for Sun windows ! 2: ;; Copyright (C) 1987, 1991 Free Software Foundation, Inc. ! 3: ! 4: ;; This file is part of GNU Emacs. ! 5: ! 6: ;; GNU Emacs is free software; you can redistribute it and/or modify ! 7: ;; it under the terms of the GNU General Public License as published by ! 8: ;; the Free Software Foundation; either version 1, or (at your option) ! 9: ;; any later version. ! 10: ! 11: ;; GNU Emacs is distributed in the hope that it will be useful, ! 12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ! 13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! 14: ;; GNU General Public License for more details. ! 15: ! 16: ;; You should have received a copy of the GNU General Public License ! 17: ;; along with GNU Emacs; see the file COPYING. If not, write to ! 18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ! 19: ! 20: ;;; Jeff Peck, Sun Microsystems, Jan 1987. ! 21: ;;; Original idea by Stan Jefferson ! 22: ;; ! 23: ;; Mar 90 get/set selections ! 24: ;; Mar 91 add mouse-help, print bindings dynamically ! 25: ! 26: (provide 'sun-mouse) ! 27: ! 28: ;;; ! 29: ;;; Modelled after the GNUEMACS keymap interface. ! 30: ;;; ! 31: ;;; User Functions: ! 32: ;;; make-mousemap, copy-mousemap, ! 33: ;;; define-mouse, global-set-mouse, local-set-mouse, ! 34: ;;; use-global-mousemap, use-local-mousemap, ! 35: ;;; mouse-lookup, describe-mouse-bindings ! 36: ;;; ! 37: ;;; Options: ! 38: ;;; extra-click-wait, scrollbar-width ! 39: ;;; ! 40: ! 41: (defvar extra-click-wait 150 ! 42: "*Number of milliseconds to wait for an extra click. ! 43: Set this to zero if you don't want chords or double clicks.") ! 44: ! 45: (defvar scrollbar-width 5 ! 46: "*The character width of the scrollbar. ! 47: The cursor is deemed to be in the right edge scrollbar if it is this near the ! 48: right edge, and more than two chars past the end of the indicated line. ! 49: Setting to nil limits the scrollbar to the edge or vertical dividing bar.") ! 50: ! 51: ;;; ! 52: ;;; Mousemaps ! 53: ;;; ! 54: (defun make-mousemap () ! 55: "Returns a new mousemap." ! 56: (cons 'mousemap nil)) ! 57: ! 58: (defun copy-mousemap (mousemap) ! 59: "Return a copy of mousemap." ! 60: (copy-alist mousemap)) ! 61: ! 62: (defun define-mouse (mousemap mouse-list def) ! 63: "Args MOUSEMAP, MOUSE-LIST, DEF. Define MOUSE-LIST in MOUSEMAP as DEF. ! 64: MOUSE-LIST is a list of atoms specifing a mouse hit according to these rules: ! 65: * One of these atoms specifies the active region of the definition. ! 66: text, scrollbar, modeline, minibuffer ! 67: * One or two or these atoms specify the button or button combination. ! 68: left, middle, right, double ! 69: * Any combination of these atoms specify the active shift keys. ! 70: control, shift, meta ! 71: * With a single unshifted button, you can add ! 72: up ! 73: to indicate an up-click. ! 74: The atom `double' is used with a button designator to denote a double click. ! 75: Two button chords are denoted by listing the two buttons. ! 76: See sun-mouse-handler for the treatment of the form DEF." ! 77: (mousemap-set (mouse-list-to-mouse-code mouse-list) mousemap def)) ! 78: ! 79: (defun global-set-mouse (mouse-list def) ! 80: "Give MOUSE-EVENT-LIST a local definition of DEF. ! 81: See define-mouse for a description of MOUSE-EVENT-LIST and DEF. ! 82: Note that if MOUSE-EVENT-LIST has a local definition in the current buffer, ! 83: that local definition will continue to shadow any global definition." ! 84: (interactive "xMouse event: \nxDefinition: ") ! 85: (define-mouse current-global-mousemap mouse-list def)) ! 86: ! 87: (defun local-set-mouse (mouse-list def) ! 88: "Give MOUSE-EVENT-LIST a local definition of DEF. ! 89: See define-mouse for a description of the arguments. ! 90: The definition goes in the current buffer's local mousemap. ! 91: Normally buffers in the same major mode share a local mousemap." ! 92: (interactive "xMouse event: \nxDefinition: ") ! 93: (if (null current-local-mousemap) ! 94: (setq current-local-mousemap (make-mousemap))) ! 95: (define-mouse current-local-mousemap mouse-list def)) ! 96: ! 97: (defun use-global-mousemap (mousemap) ! 98: "Selects MOUSEMAP as the global mousemap." ! 99: (setq current-global-mousemap mousemap)) ! 100: ! 101: (defun use-local-mousemap (mousemap) ! 102: "Selects MOUSEMAP as the local mousemap. ! 103: nil for MOUSEMAP means no local mousemap." ! 104: (setq current-local-mousemap mousemap)) ! 105: ! 106: ! 107: ;;; ! 108: ;;; Interface to the Mouse encoding defined in Emacstool.c ! 109: ;;; ! 110: ;;; Called when mouse-prefix is sent to emacs, additional ! 111: ;;; information is read in as a list (button x y time-delta) ! 112: ;;; ! 113: ;;; First, some generally useful functions: ! 114: ;;; ! 115: ! 116: (defun logtest (x y) ! 117: "True if any bits set in X are also set in Y. ! 118: Just like the Common Lisp function of the same name." ! 119: (not (zerop (logand x y)))) ! 120: ! 121: ! 122: ;;; ! 123: ;;; Hit accessors. ! 124: ;;; ! 125: ! 126: (defconst sm::ButtonBits 7) ; Lowest 3 bits. ! 127: (defconst sm::ShiftmaskBits 56) ; Second lowest 3 bits (56 = 63 - 7). ! 128: (defconst sm::DoubleBits 64) ; Bit 7. ! 129: (defconst sm::UpBits 128) ; Bit 8. ! 130: ! 131: ;;; All the useful code bits ! 132: (defmacro sm::hit-code (hit) ! 133: (` (nth 0 (, hit)))) ! 134: ;;; The button, or buttons if a chord. ! 135: (defmacro sm::hit-button (hit) ! 136: (` (logand sm::ButtonBits (nth 0 (, hit))))) ! 137: ;;; The shift, control, and meta flags. ! 138: (defmacro sm::hit-shiftmask (hit) ! 139: (` (logand sm::ShiftmaskBits (nth 0 (, hit))))) ! 140: ;;; Set if a double click (but not a chord). ! 141: (defmacro sm::hit-double (hit) ! 142: (` (logand sm::DoubleBits (nth 0 (, hit))))) ! 143: ;;; Set on button release (as opposed to button press). ! 144: (defmacro sm::hit-up (hit) ! 145: (` (logand sm::UpBits (nth 0 (, hit))))) ! 146: ;;; Screen x position. ! 147: (defmacro sm::hit-x (hit) (list 'nth 1 hit)) ! 148: ;;; Screen y position. ! 149: (defmacro sm::hit-y (hit) (list 'nth 2 hit)) ! 150: ;;; Millisconds since last hit. ! 151: (defmacro sm::hit-delta (hit) (list 'nth 3 hit)) ! 152: ! 153: (defmacro sm::hit-up-p (hit) ; A predicate. ! 154: (` (not (zerop (sm::hit-up (, hit)))))) ! 155: ! 156: ;;; ! 157: ;;; Loc accessors. for sm::window-xy ! 158: ;;; ! 159: (defmacro sm::loc-w (loc) (list 'nth 0 loc)) ! 160: (defmacro sm::loc-x (loc) (list 'nth 1 loc)) ! 161: (defmacro sm::loc-y (loc) (list 'nth 2 loc)) ! 162: ! 163: (defmacro eval-in-buffer (buffer &rest forms) ! 164: "Macro to switches to BUFFER, evaluates FORMS, returns to original buffer." ! 165: ;; When you don't need the complete window context of eval-in-window ! 166: (` (let ((StartBuffer (current-buffer))) ! 167: (unwind-protect ! 168: (progn ! 169: (set-buffer (, buffer)) ! 170: (,@ forms)) ! 171: (set-buffer StartBuffer))))) ! 172: ! 173: (put 'eval-in-buffer 'lisp-indent-hook 1) ! 174: ! 175: ;;; this is used extensively by sun-fns.el ! 176: ;;; ! 177: (defmacro eval-in-window (window &rest forms) ! 178: "Switch to WINDOW, evaluate FORMS, return to original window." ! 179: (` (let ((OriginallySelectedWindow (selected-window))) ! 180: (unwind-protect ! 181: (progn ! 182: (select-window (, window)) ! 183: (,@ forms)) ! 184: ;; don't go back to window if it has been destroyed... ! 185: ;; window-point seems to work as an indication of existence ! 186: (if (window-point OriginallySelectedWindow) ! 187: (select-window OriginallySelectedWindow)))))) ! 188: (put 'eval-in-window 'lisp-indent-hook 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-hook 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: (= (screen-height) ! 229: (nth 3 (window-edges window)) ; The bottom edge. ! 230: )) ! 231: ! 232: ! 233: (setq *mouse-help* nil) ; flag to display, rather than execute ! 234: (defun sun-mouse-handler (&optional hit) ! 235: "Evaluates the function or list associated with a mouse hit. ! 236: Expecting to read a hit, which is a list: (button x y delta). ! 237: A form bound to button by define-mouse is found by mouse-lookup. ! 238: The variables: *mouse-window*, *mouse-x*, *mouse-y* are bound. ! 239: If the form is a symbol (symbolp), it is funcall'ed with *mouse-window*, ! 240: *mouse-x*, and *mouse-y* as arguments; if the form is a list (listp), ! 241: the form is eval'ed; if the form is neither of these, it is an error. ! 242: Returns nil." ! 243: (interactive) ! 244: (if (null hit) (setq hit (sm::combined-hits))) ! 245: (let ((loc (sm::window-xy (sm::hit-x hit) (sm::hit-y hit)))) ! 246: (let ((*mouse-window* (sm::loc-w loc)) ! 247: (*mouse-x* (sm::loc-x loc)) ! 248: (*mouse-y* (sm::loc-y loc)) ! 249: (mouse-code (mouse-event-code hit loc))) ! 250: (let ((form (eval-in-buffer (window-buffer *mouse-window*) ! 251: (mouse-lookup mouse-code)))) ! 252: (cond ((null form) ! 253: (if (not (sm::hit-up-p hit)) ; undefined up hits are ok. ! 254: (error "Undefined mouse event: %s" ! 255: (prin1-to-string ! 256: (mouse-code-to-mouse-list mouse-code))))) ! 257: ((symbolp form) ! 258: (setq this-command form) ! 259: (if *mouse-help* ! 260: (progn (prin1 (list form *mouse-window* *mouse-x* *mouse-y*)) ! 261: (exit-recursive-edit)) ! 262: (funcall form *mouse-window* *mouse-x* *mouse-y*))) ! 263: ((listp form) ! 264: (setq this-command (car form)) ! 265: (if *mouse-help* ! 266: (progn (prin1 form) (exit-recursive-edit)) ! 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 mouse-help () ! 279: (interactive) ! 280: (let ((*mouse-help* t)) ! 281: (recursive-edit))) ! 282: ! 283: (defun sm::combined-hits () ! 284: "Read and return next mouse-hit, include possible double click" ! 285: (let ((hit1 (mouse-hit-read))) ! 286: (if (not (sm::hit-up-p hit1)) ; Up hits dont start doubles or chords. ! 287: (let ((hit2 (mouse-second-hit extra-click-wait))) ! 288: (if hit2 ; we cons'd it, we can smash it. ! 289: ; (setf (sm::hit-code hit1) (logior (sm::hit-code hit1) ...)) ! 290: (setcar hit1 (logior (sm::hit-code hit1) ! 291: (sm::hit-code hit2) ! 292: (if (= (sm::hit-button hit1) ! 293: (sm::hit-button hit2)) ! 294: sm::DoubleBits 0)))))) ! 295: hit1)) ! 296: ! 297: (defun mouse-hit-read () ! 298: "Read mouse-hit list from keyboard. Like (read 'read-char), ! 299: but that uses minibuffer, and mucks up last-command." ! 300: (let ((char-list nil) (char nil)) ! 301: (while (not (equal 13 ; Carriage return. ! 302: (prog1 (setq char (read-char)) ! 303: (setq char-list (cons char char-list)))))) ! 304: (read (mapconcat 'char-to-string (nreverse char-list) "")) ! 305: )) ! 306: ! 307: ;;; Second Click Hackery.... ! 308: ;;; if prefix is not mouse-prefix, need a way to unread the char... ! 309: ;;; or else have mouse flush input queue, or else need a peek at next char. ! 310: ! 311: ;;; There is no peek, but since one character can be unread, we only ! 312: ;;; have to flush the queue when the command after a mouse click ! 313: ;;; starts with mouse-prefix1 (see below). ! 314: ;;; Something to do later: We could buffer the read commands and ! 315: ;;; execute them ourselves after doing the mouse command (using ! 316: ;;; lookup-key ??). ! 317: ! 318: (defvar mouse-prefix1 24 ; C-x ! 319: "First char of mouse-prefix. Used to detect double clicks and chords.") ! 320: ! 321: (defvar mouse-prefix2 0 ; C-@ ! 322: "Second char of mouse-prefix. Used to detect double clicks and chords.") ! 323: ! 324: ! 325: (defun mouse-second-hit (hit-wait) ! 326: "Returns the next mouse hit occurring within HIT-WAIT milliseconds." ! 327: (if (sit-for-millisecs hit-wait) nil ; No input within hit-wait millisecs. ! 328: (let ((pc1 (read-char))) ! 329: (if (or (not (equal pc1 mouse-prefix1)) ! 330: (sit-for-millisecs 3)) ; a mouse prefix will have second char ! 331: (progn (setq unread-command-char pc1) ; Can get away with one unread. ! 332: nil) ; Next input not mouse event. ! 333: (let ((pc2 (read-char))) ! 334: (if (not (equal pc2 mouse-prefix2)) ! 335: (progn (setq unread-command-char pc1) ; put back the ^X ! 336: ;;; Too bad can't do two: (setq unread-command-char (list pc1 pc2)) ! 337: (ding) ; user will have to retype that pc2. ! 338: nil) ; This input is not a mouse event. ! 339: ;; Next input has mouse prefix and is within time limit. ! 340: (let ((new-hit (mouse-hit-read))) ; Read the new hit. ! 341: (if (sm::hit-up-p new-hit) ; Ignore up events when timing. ! 342: (mouse-second-hit (- hit-wait (sm::hit-delta new-hit))) ! 343: new-hit ; New down hit within limit, return it. ! 344: )))))))) ! 345: ! 346: (defun sm::window-xy (x y) ! 347: "Find window containing screen coordinates X and Y. ! 348: Returns list (window x y) where x and y are relative to window." ! 349: (or ! 350: (catch 'found ! 351: (eval-in-windows ! 352: (let ((we (window-edges (selected-window)))) ! 353: (let ((le (nth 0 we)) ! 354: (te (nth 1 we)) ! 355: (re (nth 2 we)) ! 356: (be (nth 3 we))) ! 357: (if (= re (screen-width)) ! 358: ;; include the continuation column with this window ! 359: (setq re (1+ re))) ! 360: (if (= be (screen-height)) ! 361: ;; include partial line at bottom of screen with this window ! 362: ;; id est, if window is not multple of char size. ! 363: (setq be (1+ be))) ! 364: ! 365: (if (and (>= x le) (< x re) ! 366: (>= y te) (< y be)) ! 367: (throw 'found ! 368: (list (selected-window) (- x le) (- y te)))))) ! 369: t)) ; include minibuffer in eval-in-windows ! 370: ;;If x,y from a real mouse click, we shouldn't get here. ! 371: (list nil x y) ! 372: )) ! 373: ! 374: (defun sm::window-region (loc) ! 375: "Parse LOC into a region symbol. ! 376: Returns one of (text scrollbar modeline minibuffer)" ! 377: (let ((w (sm::loc-w loc)) ! 378: (x (sm::loc-x loc)) ! 379: (y (sm::loc-y loc))) ! 380: (let ((right (1- (window-width w))) ! 381: (bottom (1- (window-height w)))) ! 382: (cond ((minibuffer-window-p w) 'minibuffer) ! 383: ((>= y bottom) 'modeline) ! 384: ((>= x right) 'scrollbar) ! 385: ;; far right column (window seperator) is always a scrollbar ! 386: ((and scrollbar-width ! 387: ;; mouse within scrollbar-width of edge. ! 388: (>= x (- right scrollbar-width)) ! 389: ;; mouse a few chars past the end of line. ! 390: (>= x (+ 2 (window-line-end w x y)))) ! 391: 'scrollbar) ! 392: (t 'text))))) ! 393: ! 394: (defun window-line-end (w x y) ! 395: "Return WINDOW column (ignore X) containing end of line Y" ! 396: (eval-in-window w (save-excursion (move-to-loc (screen-width) y)))) ! 397: ! 398: ;;; ! 399: ;;; The encoding of mouse events into a mousemap. ! 400: ;;; These values must agree with coding in emacstool: ! 401: ;;; ! 402: (defconst sm::keyword-alist ! 403: '((left . 1) (middle . 2) (right . 4) ! 404: (shift . 8) (control . 16) (meta . 32) (double . 64) (up . 128) ! 405: (text . 256) (scrollbar . 512) (modeline . 1024) (minibuffer . 2048) ! 406: )) ! 407: ! 408: (defun mouse-event-code (hit loc) ! 409: "Maps MOUSE-HIT and LOC into a mouse-code." ! 410: ;;;Region is a code for one of text, modeline, scrollbar, or minibuffer. ! 411: (logior (sm::hit-code hit) ! 412: (mouse-region-to-code (sm::window-region loc)))) ! 413: ! 414: (defun mouse-region-to-code (region) ! 415: "Returns partial mouse-code for specified REGION." ! 416: (cdr (assq region sm::keyword-alist))) ! 417: ! 418: (defun mouse-list-to-mouse-code (mouse-list) ! 419: "Map a MOUSE-LIST to a mouse-code." ! 420: (apply 'logior ! 421: (mapcar (function (lambda (x) ! 422: (cdr (assq x sm::keyword-alist)))) ! 423: mouse-list))) ! 424: ! 425: (defun mouse-code-to-mouse-list (mouse-code) ! 426: "Map a MOUSE-CODE to a mouse-list." ! 427: (apply 'nconc (mapcar ! 428: (function (lambda (x) ! 429: (if (logtest mouse-code (cdr x)) ! 430: (list (car x))))) ! 431: sm::keyword-alist))) ! 432: ! 433: (defun mousemap-set (code mousemap value) ! 434: (let* ((alist (cdr mousemap)) ! 435: (assq-result (assq code alist))) ! 436: (if assq-result ! 437: (setcdr assq-result value) ! 438: (setcdr mousemap (cons (cons code value) alist))))) ! 439: ! 440: (defun mousemap-get (code mousemap) ! 441: (cdr (assq code (cdr mousemap)))) ! 442: ! 443: (defun mouse-lookup (mouse-code) ! 444: "Look up MOUSE-EVENT and return the definition. nil means undefined." ! 445: (or (mousemap-get mouse-code current-local-mousemap) ! 446: (mousemap-get mouse-code current-global-mousemap))) ! 447: ! 448: ;;; ! 449: ;;; I (jpeck) don't understand the utility of the next four functions ! 450: ;;; ask Steven Greenbaum <froud@kestrel> ! 451: ;;; ! 452: (defun mouse-mask-lookup (mask list) ! 453: "Args MASK (a bit mask) and LIST (a list of (code . form) pairs). ! 454: Returns a list of elements of LIST whose code or'ed with MASK is non-zero." ! 455: (let ((result nil)) ! 456: (while list ! 457: (if (logtest mask (car (car list))) ! 458: (setq result (cons (car list) result))) ! 459: (setq list (cdr list))) ! 460: result)) ! 461: ! 462: (defun mouse-union (l l-unique) ! 463: "Return the union of list of mouse (code . form) pairs L and L-UNIQUE, ! 464: where L-UNIQUE is considered to be union'ized already." ! 465: (let ((result l-unique)) ! 466: (while l ! 467: (let ((code-form-pair (car l))) ! 468: (if (not (assq (car code-form-pair) result)) ! 469: (setq result (cons code-form-pair result)))) ! 470: (setq l (cdr l))) ! 471: result)) ! 472: ! 473: (defun mouse-union-first-prefered (l1 l2) ! 474: "Return the union of lists of mouse (code . form) pairs L1 and L2, ! 475: based on the code's, with preference going to elements in L1." ! 476: (mouse-union l2 (mouse-union l1 nil))) ! 477: ! 478: (defun mouse-code-function-pairs-of-region (region) ! 479: "Return a list of (code . function) pairs, where each code is ! 480: currently set in the REGION." ! 481: (let ((mask (mouse-region-to-code region))) ! 482: (mouse-union-first-prefered ! 483: (mouse-mask-lookup mask (cdr current-local-mousemap)) ! 484: (mouse-mask-lookup mask (cdr current-global-mousemap)) ! 485: ))) ! 486: ! 487: ;;; ! 488: ;;; Functions for DESCRIBE-MOUSE-BINDINGS ! 489: ;;; And other mouse documentation functions ! 490: ;;; Still need a good procedure to print out a help sheet in readable format. ! 491: ;;; ! 492: ! 493: (defun one-line-doc-string (function) ! 494: "Returns first line of documentation string for FUNCTION. ! 495: If there is no documentation string, then the string ! 496: \"No documentation\" is returned." ! 497: (while (consp function) (setq function (car function))) ! 498: (let ((doc (documentation function))) ! 499: (if (null doc) ! 500: "No documentation." ! 501: (string-match "^.*$" doc) ! 502: (substring doc 0 (match-end 0))))) ! 503: ! 504: (defun print-mouse-format (binding) ! 505: (princ (car binding)) ! 506: (princ ": ") ! 507: (mapcar (function ! 508: (lambda (mouse-list) ! 509: (princ mouse-list) ! 510: (princ " "))) ! 511: (cdr binding)) ! 512: (terpri) ! 513: (princ " ") ! 514: (princ (one-line-doc-string (car binding))) ! 515: (terpri) ! 516: ) ! 517: ! 518: (defun print-mouse-bindings (region) ! 519: "Prints mouse-event bindings for REGION." ! 520: (mapcar 'print-mouse-format (sm::event-bindings region))) ! 521: ! 522: (defun sm::event-bindings (region) ! 523: "Returns an alist of (function . (mouse-list1 ... mouse-listN)) for REGION, ! 524: where each mouse-list is bound to the function in REGION." ! 525: (let ((mouse-bindings (mouse-code-function-pairs-of-region region)) ! 526: (result nil)) ! 527: (while mouse-bindings ! 528: (let* ((code-function-pair (car mouse-bindings)) ! 529: (current-entry (assoc (cdr code-function-pair) result))) ! 530: (if current-entry ! 531: (setcdr current-entry ! 532: (cons (mouse-code-to-mouse-list (car code-function-pair)) ! 533: (cdr current-entry))) ! 534: (setq result (cons (cons (cdr code-function-pair) ! 535: (list (mouse-code-to-mouse-list ! 536: (car code-function-pair)))) ! 537: result)))) ! 538: (setq mouse-bindings (cdr mouse-bindings)) ! 539: ) ! 540: result)) ! 541: ! 542: (defun describe-mouse-bindings () ! 543: "Lists all current mouse-event bindings." ! 544: (interactive) ! 545: (with-output-to-temp-buffer "*Help*" ! 546: (princ "Text Region") (terpri) ! 547: (princ "---- ------") (terpri) ! 548: (print-mouse-bindings 'text) (terpri) ! 549: (princ "Modeline Region") (terpri) ! 550: (princ "-------- ------") (terpri) ! 551: (print-mouse-bindings 'modeline) (terpri) ! 552: (princ "Scrollbar Region") (terpri) ! 553: (princ "--------- ------") (terpri) ! 554: (print-mouse-bindings 'scrollbar))) ! 555: ! 556: (defun describe-mouse-briefly (mouse-list) ! 557: "Print a short description of the function bound to MOUSE-LIST." ! 558: (interactive "xDescibe mouse list briefly: ") ! 559: (let ((function (mouse-lookup (mouse-list-to-mouse-code mouse-list)))) ! 560: (if function ! 561: (message "%s runs the command %s" mouse-list function) ! 562: (message "%s is undefined" mouse-list)))) ! 563: ! 564: (defun mouse-help-menu (function-and-binding) ! 565: (cons (prin1-to-string (car function-and-binding)) ! 566: (menu-create ; Two sub-menu items of form ("String" . nil) ! 567: (list (list (one-line-doc-string (car function-and-binding))) ! 568: (list (prin1-to-string (cdr function-and-binding))))))) ! 569: ! 570: (defun mouse-help-region (w x y &optional region) ! 571: "Displays a menu of mouse functions callable in this region." ! 572: (let* ((region (or region (sm::window-region (list w x y)))) ! 573: (mlist (mapcar (function mouse-help-menu) ! 574: (sm::event-bindings region))) ! 575: (menu (menu-create (cons (list (symbol-name region)) mlist))) ! 576: (item (sun-menu-evaluate w 0 y menu)) ! 577: ))) ! 578: ! 579: ;;; ! 580: ;;; Menu interface functions ! 581: ;;; ! 582: ;;; use defmenu, because this interface is subject to change ! 583: ;;; really need a menu-p, but we use vectorp and the context... ! 584: ;;; ! 585: (defun menu-create (items) ! 586: "Functional form for defmenu, given a list of ITEMS returns a menu. ! 587: Each ITEM is a (STRING . VALUE) pair." ! 588: (apply 'vector items) ! 589: ) ! 590: ! 591: (defmacro defmenu (menu &rest itemlist) ! 592: "Defines MENU to be a menu, the ITEMS are (STRING . VALUE) pairs. ! 593: See sun-menu-evaluate for interpretation of ITEMS." ! 594: (list 'defconst menu (funcall 'menu-create itemlist)) ! 595: ) ! 596: ! 597: (defun sun-menu-evaluate (*menu-window* *menu-x* *menu-y* menu) ! 598: "Display a pop-up menu in WINDOW at X Y and evaluate selected item ! 599: of MENU. MENU (or its symbol-value) should be a menu defined by defmenu. ! 600: A menu ITEM is a (STRING . FORM) pair; ! 601: the FORM associated with the selected STRING is evaluated, ! 602: and the resulting value is returned. Generally these FORMs are ! 603: evaluated for their side-effects rather than their values. ! 604: If the selected form is a menu or a symbol whose value is a menu, ! 605: then it is displayed and evaluated as a pullright menu item. ! 606: If the the FORM of the first ITEM is nil, the STRING of the item ! 607: is used as a label for the menu, i.e. it's inverted and not selectible." ! 608: ! 609: (if (symbolp menu) (setq menu (symbol-value menu))) ! 610: (eval (sun-menu-internal *menu-window* *menu-x* *menu-y* 4 menu))) ! 611: ! 612: (defun sun-get-frame-data (code) ! 613: "Sends the tty-sub-window escape sequence CODE to terminal, ! 614: and returns a cons of the two numbers in returned escape sequence. ! 615: That is it returns (cons <car> <cdr>) from \"\\E[n;<car>;<cdr>t\". ! 616: CODE values: 13 = Tool-Position, 14 = Size-in-Pixels, 18 = Size-in-Chars." ! 617: (send-string-to-terminal (concat "\033[" (int-to-string code) "t")) ! 618: (let (char str x y) ! 619: (while (not (equal 116 (setq char (read-char)))) ; #\t = 116 ! 620: (setq str (cons char str))) ! 621: (setq str (mapconcat 'char-to-string (nreverse str) "")) ! 622: (string-match ";[0-9]*" str) ! 623: (setq y (substring str (1+ (match-beginning 0)) (match-end 0))) ! 624: (setq str (substring str (match-end 0))) ! 625: (string-match ";[0-9]*" str) ! 626: (setq x (substring str (1+ (match-beginning 0)) (match-end 0))) ! 627: (cons (string-to-int y) (string-to-int x)))) ! 628: ! 629: (defun sm::font-size () ! 630: "Returns font size in pixels: (cons Ysize Xsize)" ! 631: (let ((pix (sun-get-frame-data 14)) ; returns size in pixels ! 632: (chr (sun-get-frame-data 18))) ; returns size in chars ! 633: (cons (/ (car pix) (car chr)) (/ (cdr pix) (cdr chr))))) ! 634: ! 635: (defvar sm::menu-kludge-x nil ! 636: "Cached frame-to-window X-Offset for sm::menu-kludge") ! 637: (defvar sm::menu-kludge-y nil ! 638: "Cached frame-to-window Y-Offset for sm::menu-kludge") ! 639: ! 640: (defun sm::menu-kludge () ! 641: "If sunfns.c uses <Menu_Base_Kludge> this function must be here!" ! 642: (or sm::menu-kludge-y ! 643: (let ((fs (sm::font-size))) ! 644: (setq sm::menu-kludge-y (+ 8 (car fs)) ; a title line and borders ! 645: sm::menu-kludge-x 4))) ; best values depend on .defaults/Menu ! 646: (let ((wl (sun-get-frame-data 13))) ; returns frame location ! 647: (cons (+ (car wl) sm::menu-kludge-y) ! 648: (+ (cdr wl) sm::menu-kludge-x)))) ! 649: ! 650: ;;; ! 651: ;;; Function interface to selection/region ! 652: ;;; primative functions are defined in sunfns.c ! 653: ;;; ! 654: (defun sunview-yank-stuff () ! 655: "Set mark and yank the contents of the current TTYSW `STUFF' selection ! 656: into the current buffer at point. The STUFF selection contains the currently ! 657: or previously highlighted text from a TTYSW." ! 658: (interactive "*") ! 659: (set-mark-command nil) ! 660: (insert-string (sun-get-selection))) ! 661: ! 662: ;;; ! 663: (defun display-host () ! 664: "Extract <host> from DISPLAY environment variable, or return nil if not specified." ! 665: (let ((display (getenv "DISPLAY"))) ! 666: (if display ! 667: (let ((colon_at (string-match ":" display))) ! 668: (if colon_at ! 669: (if (not (zerop colon_at)) ! 670: (substring display 0 colon_at) ! 671: )))))) ! 672: ! 673: ;;; get_selection has been extended to work in X ! 674: ;;; we extend to work on remote X display... ! 675: (defun sunview-yank-clipboard () ! 676: "Set mark and yank the contents of the SunView Clipboard into the ! 677: current buffer at point." ! 678: (interactive "*") ! 679: (set-mark-command nil) ! 680: (let ((host (display-host))) ! 681: (if host ! 682: (call-process "rsh" nil t t (display-host) "get_selection" "3") ! 683: (call-process "get_selection" nil t t "3"))) ! 684: ) ! 685: ! 686: (defun sunview-yank-current-selection () ! 687: "Set mark and yank the contents of the current SunView selection ! 688: into current buffer at point. The current selection is the currently ! 689: highlighted text in either a textsw or a ttysw." ! 690: (interactive "*") ! 691: (set-mark-command nil) ! 692: (let ((host (display-host))) ! 693: (if host ! 694: (call-process "rsh" nil t t (display-host) "get_selection") ! 695: (call-process "get_selection" nil t t)))) ! 696: ! 697: (defun sunview-yank-any-selection (arg) ! 698: "Yank one of the sunview selections: ! 699: with no arg, the current selection; with minus-only prefix, the clipboard; ! 700: with any other arg, the ttysw STUFF." ! 701: (interactive "*P") ! 702: (cond ((null arg) (sunview-yank-current-selection)) ! 703: ((eq arg '-) (sunview-yank-clipboard)) ! 704: (t (sunview-yank-stuff)))) ! 705: ! 706: ;;; define the selection file used by this emacs ! 707: ;;; if not local machine, then automounter must find /net/<host>/tmp ! 708: (defvar owselectionfilex nil "Cache path to ttysw selection file (a kludge!).") ! 709: ;;; determine value at runtime, not when this file loaded into temacs ! 710: (defun owselectionfile () ! 711: (or owselectionfilex ! 712: (let* ((host (display-host)) ! 713: (filex ! 714: (if host ! 715: (concat "/net/" host "/tmp/ttyselection") ! 716: "/tmp/ttyselection"))) ! 717: (if (file-exists-p filex) ! 718: (setq owselectionfilex filex) ! 719: (progn ! 720: (message "no TTYSW selection file") ! 721: nil) ! 722: )))) ! 723: ! 724: (defun xv-yank-selection () ! 725: "Set mark and yank the contents of the current Xview selection ! 726: into the current buffer at point. The STUFF selection contains the currently ! 727: or previously highlighted text from a TTYSW." ! 728: (interactive "*") ! 729: (if (owselectionfile) ! 730: (progn ! 731: (insert-file (owselectionfile)) ! 732: (exchange-point-and-mark))) ! 733: ) ! 734: ! 735: (defun xv-select-region (beg end) ! 736: "Set the TTYSW selection to the region in the current buffer." ! 737: (interactive "r") ! 738: (if (owselectionfile) ! 739: (write-region beg end (owselectionfile) nil 'noprint)) ! 740: ) ! 741: ! 742: (defun sun-yank-selection () ! 743: "Set mark and yank the contents of the current TTYSW `STUFF' or Xview selection ! 744: into the current buffer at point." ! 745: (interactive "*") ! 746: (if (getenv "DISPLAY") ! 747: (xv-yank-selection) ! 748: (sunview-yank-stuff)) ! 749: ) ! 750: ! 751: (defun sun-select-region (beg end) ! 752: "Set the TTYSW 'STUFF' or Xview selection to the region in the current buffer." ! 753: (interactive "r") ! 754: (if (getenv "DISPLAY") ! 755: (xv-select-region beg end) ! 756: (sun-set-selection (buffer-substring beg end))) ! 757: ) ! 758: ! 759: ! 760: ! 761: ;;; ! 762: ;;; support for emacstool ! 763: ;;; This closes the window instead of stopping emacs. ! 764: ;;; ! 765: (defun suspend-emacstool (&optional stuffstring) ! 766: "If running under as a detached process emacstool, ! 767: you don't want to suspend (there is no way to resume), ! 768: just close the window, and wait for reopening." ! 769: (interactive) ! 770: (if (and (boundp 'suspend-hook) suspend-hook) ! 771: (funcall suspend-hook)) ! 772: (if stuffstring (send-string-to-terminal stuffstring)) ! 773: (send-string-to-terminal "\033[2t") ; To close EmacsTool window. ! 774: (if (and (boundp 'suspend-resume-hook) suspend-resume-hook) ! 775: (funcall suspend-resume-hook))) ! 776: ;;; ! 777: ;;; initialize mouse maps ! 778: ;;; ! 779: ! 780: (make-variable-buffer-local 'current-local-mousemap) ! 781: (setq-default current-local-mousemap nil) ! 782: (defvar current-global-mousemap (make-mousemap))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.