Return to sun-mouse.el CVS log

Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp

Annotation of 43BSDReno/contrib/emacs-18.55/lisp/sun-mouse.el, revision 1.1

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