Return to sup-mouse.el CVS log

Up to [Apple XNU] / GNUtools / emacs / lisp

Annotation of GNUtools/emacs/lisp/sup-mouse.el, revision 1.1

1.1     ! root        1: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !             2: ;;                                                                          ;;
        !             3: ;;     File:     sup-mouse.el                                               ;;
        !             4: ;;     Author:   Wolfgang Rupprecht                                         ;;
        !             5: ;;     Created:  Fri Nov 21 19:22:22 1986                                   ;;
        !             6: ;;     Contents: supdup mouse support for lisp machines                     ;;
        !             7: ;;                                                                          ;;
        !             8: ;;     (from code originally written by John Robinson@bbn for the bitgraph)  ;;
        !             9: ;;                                                                          ;;
        !            10: ;;     $Log$                                                                ;;
        !            11: ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
        !            12: 
        !            13: ;; GNU Emacs code for lambda/supdup mouse
        !            14: ;; Copyright (C) Free Software Foundation 1985, 1986
        !            15: 
        !            16: ;; This file is part of GNU Emacs.
        !            17: 
        !            18: ;; GNU Emacs is free software; you can redistribute it and/or modify
        !            19: ;; it under the terms of the GNU General Public License as published by
        !            20: ;; the Free Software Foundation; either version 1, or (at your option)
        !            21: ;; any later version.
        !            22: 
        !            23: ;; GNU Emacs is distributed in the hope that it will be useful,
        !            24: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
        !            25: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
        !            26: ;; GNU General Public License for more details.
        !            27: 
        !            28: ;; You should have received a copy of the GNU General Public License
        !            29: ;; along with GNU Emacs; see the file COPYING.  If not, write to
        !            30: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
        !            31: 
        !            32: ;;;  User customization option:
        !            33: 
        !            34: (defvar sup-mouse-fast-select-window nil
        !            35:   "*Non-nil for mouse hits to select new window, then execute; else just select.")
        !            36: 
        !            37: (defconst mouse-left 0)
        !            38: (defconst mouse-center 1)
        !            39: (defconst mouse-right 2)
        !            40: 
        !            41: (defconst mouse-2left 4)
        !            42: (defconst mouse-2center 5)
        !            43: (defconst mouse-2right 6)
        !            44: 
        !            45: (defconst mouse-3left 8)
        !            46: (defconst mouse-3center 9)
        !            47: (defconst mouse-3right 10)
        !            48: 
        !            49: ;;;  Defuns:
        !            50: 
        !            51: (defun sup-mouse-report ()
        !            52:   "This function is called directly by the mouse, it parses and
        !            53: executes the mouse commands.
        !            54: 
        !            55:  L move point          *  |---- These apply for mouse click in a window.
        !            56: 2L delete word            |
        !            57: 3L copy word             | If sup-mouse-fast-select-window is nil,
        !            58:  C move point and yank *  | just selects that window.
        !            59: 2C yank pop              |
        !            60:  R set mark            *  |
        !            61: 2R delete region         |
        !            62: 3R copy region           |
        !            63: 
        !            64: on modeline                on \"scroll bar\"   in minibuffer
        !            65:  L scroll-up               line to top         execute-extended-command
        !            66:  C proportional goto-char   line to middle     mouse-help
        !            67:  R scroll-down             line to bottom      eval-expression"
        !            68:   
        !            69:   (interactive)
        !            70:   (let*
        !            71: ;; expect a string of <esc>:<buttons>;<x-pos>;<y-pos>c
        !            72:       ((buttons (sup-get-tty-num ?\;))
        !            73:        (x (sup-get-tty-num ?\;))
        !            74:        (y (sup-get-tty-num ?c))
        !            75:        (window (sup-pos-to-window x y))
        !            76:        (edges (window-edges window))
        !            77:        (old-window (selected-window))
        !            78:        (in-minibuf-p (eq y (1- (screen-height))))
        !            79:        (same-window-p (and (not in-minibuf-p) (eq window old-window)))
        !            80:        (in-modeline-p (eq y (1- (nth 3 edges))))
        !            81:        (in-scrollbar-p (>= x (1- (nth 2 edges)))))
        !            82:     (setq x (- x (nth 0 edges)))
        !            83:     (setq y (- y (nth 1 edges)))
        !            84: 
        !            85: ;    (error "mouse-hit %d %d %d" buttons x y) ;;;; debug
        !            86: 
        !            87:     (cond (in-modeline-p
        !            88:           (select-window window)
        !            89:           (cond ((= buttons mouse-left)
        !            90:                  (scroll-up))
        !            91:                 ((= buttons mouse-right)
        !            92:                  (scroll-down))
        !            93:                 ((= buttons mouse-center)
        !            94:                  (goto-char (/ (* x
        !            95:                                   (- (point-max) (point-min)))
        !            96:                                (1- (window-width))))
        !            97:                  (beginning-of-line)
        !            98:                  (what-cursor-position)))
        !            99:           (select-window old-window))
        !           100:          (in-scrollbar-p
        !           101:           (select-window window)
        !           102:           (scroll-up
        !           103:            (cond ((= buttons mouse-left)
        !           104:                   y)
        !           105:                  ((= buttons mouse-right)
        !           106:                   (+ y (- 2 (window-height))))
        !           107:                  ((= buttons mouse-center)
        !           108:                   (/ (+ 2 y y (- (window-height))) 2))
        !           109:                  (t
        !           110:                   0)))
        !           111:           (select-window old-window))
        !           112:          (same-window-p
        !           113:           (cond ((= buttons mouse-left)
        !           114:                  (sup-move-point-to-x-y x y))
        !           115:                 ((= buttons mouse-2left)
        !           116:                  (sup-move-point-to-x-y x y)
        !           117:                  (kill-word 1))
        !           118:                 ((= buttons mouse-3left)
        !           119:                  (sup-move-point-to-x-y x y)
        !           120:                  (save-excursion
        !           121:                    (copy-region-as-kill
        !           122:                     (point) (progn (forward-word 1) (point))))
        !           123:                  (setq this-command 'yank)
        !           124:                  )
        !           125:                 ((= buttons mouse-right)
        !           126:                  (push-mark)
        !           127:                  (sup-move-point-to-x-y x y)
        !           128:                  (exchange-point-and-mark))
        !           129:                 ((= buttons mouse-2right)
        !           130:                  (push-mark)
        !           131:                  (sup-move-point-to-x-y x y)
        !           132:                  (kill-region (mark) (point)))
        !           133:                 ((= buttons mouse-3right)
        !           134:                  (push-mark)
        !           135:                  (sup-move-point-to-x-y x y)
        !           136:                  (copy-region-as-kill (mark) (point))
        !           137:                  (setq this-command 'yank))
        !           138:                 ((= buttons mouse-center)
        !           139:                  (sup-move-point-to-x-y x y)
        !           140:                  (setq this-command 'yank)
        !           141:                  (yank))
        !           142:                 ((= buttons mouse-2center)
        !           143:                  (yank-pop 1))
        !           144:                 )
        !           145:           )
        !           146:          (in-minibuf-p
        !           147:           (cond ((= buttons mouse-right)
        !           148:                  (call-interactively 'eval-expression))
        !           149:                 ((= buttons mouse-left)
        !           150:                  (call-interactively 'execute-extended-command))
        !           151:                 ((= buttons mouse-center)
        !           152:                  (describe-function 'sup-mouse-report)); silly self help 
        !           153:                 ))
        !           154:          (t                            ;in another window
        !           155:           (select-window window)
        !           156:           (cond ((not sup-mouse-fast-select-window))
        !           157:                 ((= buttons mouse-left)
        !           158:                  (sup-move-point-to-x-y x y))
        !           159:                 ((= buttons mouse-right)
        !           160:                  (push-mark)
        !           161:                  (sup-move-point-to-x-y x y)
        !           162:                  (exchange-point-and-mark))
        !           163:                 ((= buttons mouse-center)
        !           164:                  (sup-move-point-to-x-y x y)
        !           165:                  (setq this-command 'yank)
        !           166:                  (yank))
        !           167:                 ))
        !           168:          )))
        !           169: 
        !           170: 
        !           171: (defun sup-get-tty-num (term-char)
        !           172:   "Read from terminal until TERM-CHAR is read, and return intervening number.
        !           173: Upon non-numeric not matching TERM-CHAR signal an error."
        !           174:   (let
        !           175:       ((num 0)
        !           176:        (char (read-char)))
        !           177:     (while (and (>= char ?0)
        !           178:                (<= char ?9))
        !           179:       (setq num (+ (* num 10) (- char ?0)))
        !           180:       (setq char (read-char)))
        !           181:     (or (eq term-char char)
        !           182:        (error "Invalid data format in mouse command"))
        !           183:     num))
        !           184: 
        !           185: (defun sup-move-point-to-x-y (x y)
        !           186:   "Position cursor in window coordinates.
        !           187: X and Y are 0-based character positions in the window."
        !           188:   (move-to-window-line y)
        !           189:   (move-to-column x)
        !           190:   )
        !           191: 
        !           192: (defun sup-pos-to-window (x y)
        !           193:   "Find window corresponding to screen coordinates.
        !           194: X and Y are 0-based character positions on the screen."
        !           195:   (let ((edges (window-edges))
        !           196:        (window nil))
        !           197:     (while (and (not (eq window (selected-window)))
        !           198:                (or (<  y (nth 1 edges))
        !           199:                    (>= y (nth 3 edges))
        !           200:                    (<  x (nth 0 edges))
        !           201:                    (>= x (nth 2 edges))))
        !           202:       (setq window (next-window window))
        !           203:       (setq edges (window-edges window))
        !           204:       )
        !           205:     (or window (selected-window))
        !           206:     )
        !           207:   )

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.