![[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 [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to sun-mouse.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / lisp |
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.