![[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.