lisp/term/sun-mouse.el

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