git.chise.org Git - chise/xemacs-chise.git-/blob - lisp/x-mouse.el

   1 ;;; x-mouse.el --- Mouse support for X window system.
   2
   3 ;; Copyright (C) 1985, 1992-4, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995, 1996 Ben Wing.
   5
   6 ;; Maintainer: XEmacs Development Team
   7 ;; Keywords: mouse, dumped
   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
  23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24 ;; Boston, MA 02111-1307, USA.
  25
  26 ;;; Synched up with: Not synched.
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with XEmacs (when X support is compiled in).
  31
  32 ;;; Code:
  33
  34 ;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
  35 ;; This is reserved for use by Hyperbole.
  36 ;;(define-key global-map '(shift button2) 'x-mouse-kill)
  37 (define-key global-map '(control button2) 'x-set-point-and-move-selection)
  38
  39 (define-obsolete-function-alias 'x-insert-selection 'insert-selection)
  40
  41 (defun x-mouse-kill (event)
  42   "Kill the text between the point and mouse and copy it to the clipboard and
  43 to the cut buffer."
  44   (interactive "@e")
  45   (let ((old-point (point)))
  46     (mouse-set-point event)
  47     (let ((s (buffer-substring old-point (point))))
  48       (own-clipboard s)
  49       (x-store-cutbuffer s))
  50     (kill-region old-point (point))))
  51
  52 (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
  53 (defun x-set-point-and-insert-selection (event)
  54   "Set point where clicked and insert the primary selection or the cut buffer."
  55   (interactive "e")
  56   (let ((mouse-yank-at-point nil))
  57     (mouse-yank event)))
  58
  59 (defun x-set-point-and-move-selection (event)
  60   "Set point where clicked and move the selected text to that location."
  61   (interactive "e")
  62   ;; Don't try to move the selection if x-kill-primary-selection if going
  63   ;; to fail; just let the appropriate error message get issued. (We need
  64   ;; to insert the selection and set point first, or the selection may
  65   ;; get inserted at the wrong place.)
  66   (and (selection-owner-p)
  67        primary-selection-extent
  68        (insert-selection t event))
  69   (kill-primary-selection))
  70
  71 (defun mouse-track-and-copy-to-cutbuffer (event)
  72   "Make a selection like `mouse-track', but also copy it to the cutbuffer."
  73   (interactive "e")
  74   (mouse-track event)
  75   (cond
  76    ((null primary-selection-extent)
  77     nil)
  78    ((consp primary-selection-extent)
  79     (save-excursion
  80       (set-buffer (extent-object (car primary-selection-extent)))
  81       (x-store-cutbuffer
  82        (mapconcat
  83         #'identity
  84         (extract-rectangle
  85          (extent-start-position (car primary-selection-extent))
  86          (extent-end-position (car (reverse primary-selection-extent))))
  87         "\n"))))
  88    (t
  89     (save-excursion
  90       (set-buffer (extent-object primary-selection-extent))
  91       (x-store-cutbuffer
  92        (buffer-substring (extent-start-position primary-selection-extent)
  93                          (extent-end-position primary-selection-extent)))))))
  94
  95 \f
  96 (defvar x-pointers-initialized nil)
  97
  98 (defun x-init-pointer-shape (device)
  99   "Initialize the mouse-pointers of DEVICE from the X resource database."
 100   (if x-pointers-initialized  ; only do it when the first device is created
 101       nil
 102     (set-glyph-image text-pointer-glyph
 103           (or (x-get-resource "textPointer" "Cursor" 'string device nil 'warn)
 104               [cursor-font :data "xterm"]))
 105     (set-glyph-image selection-pointer-glyph
 106           (or (x-get-resource "selectionPointer" "Cursor" 'string device
 107                               nil 'warn)
 108               [cursor-font :data "top_left_arrow"]))
 109     (set-glyph-image nontext-pointer-glyph
 110           (or (x-get-resource "spacePointer" "Cursor" 'string device nil 'warn)
 111               [cursor-font :data "xterm"])) ; was "crosshair"
 112     (set-glyph-image modeline-pointer-glyph
 113           (or (x-get-resource "modeLinePointer" "Cursor" 'string device
 114                               nil 'warn)
 115 ;;            "fleur"))
 116               [cursor-font :data "sb_v_double_arrow"]))
 117     (set-glyph-image gc-pointer-glyph
 118           (or (x-get-resource "gcPointer" "Cursor" 'string device nil 'warn)
 119               [cursor-font :data "watch"]))
 120     (when (featurep 'scrollbar)
 121       (set-glyph-image
 122        scrollbar-pointer-glyph
 123        (or (x-get-resource "scrollbarPointer" "Cursor" 'string device
 124                            nil 'warn)
 125            ;; bizarrely if we don't specify the specific locale (x) this
 126            ;; gets instantiated on the stream device. Bad puppy.
 127            [cursor-font :data "top_left_arrow"]) 'global '(default x)))
 128     (set-glyph-image busy-pointer-glyph
 129           (or (x-get-resource "busyPointer" "Cursor" 'string device nil 'warn)
 130               [cursor-font :data "watch"]))
 131     (set-glyph-image toolbar-pointer-glyph
 132           (or (x-get-resource "toolBarPointer" "Cursor" 'string device
 133                               nil 'warn)
 134               [cursor-font :data "left_ptr"]))
 135     (set-glyph-image divider-pointer-glyph
 136           (or (x-get-resource "dividerPointer" "Cursor" 'string device
 137                               nil 'warn)
 138               [cursor-font :data "sb_h_double_arrow"]))
 139     (let ((fg
 140            (x-get-resource "pointerColor" "Foreground" 'string device
 141                            nil 'warn)))
 142       (and fg
 143            (set-face-foreground 'pointer fg)))
 144     (let ((bg
 145            (x-get-resource "pointerBackground" "Background" 'string device
 146                            nil 'warn)))
 147       (and bg
 148            (set-face-background 'pointer bg)))
 149     (setq x-pointers-initialized t))
 150   nil)
 151
 152 ;;; x-mouse.el ends here