cgit.sxemacs.org Git - sxemacs/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: SXEmacs Development Team
   7 ;; Keywords: mouse, dumped
   8
   9 ;; This file is part of SXEmacs.
  10
  11 ;; SXEmacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; SXEmacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Synched up with: Not synched.
  25
  26 ;;; Commentary:
  27
  28 ;; This file is dumped with SXEmacs (when X support is compiled in).
  29
  30 ;;; Code:
  31
  32 (globally-declare-fboundp
  33  '(x-store-cutbuffer x-get-resource))
  34
  35 ;;(define-key global-map 'button2 'x-set-point-and-insert-selection)
  36 ;; This is reserved for use by Hyperbole.
  37 ;;(define-key global-map '(shift button2) 'x-mouse-kill)
  38 (define-key global-map '(control button2) 'x-set-point-and-move-selection)
  39
  40 (define-obsolete-function-alias 'x-insert-selection 'insert-selection)
  41
  42 (defun x-mouse-kill (event)
  43   "Kill the text between the point and mouse and copy it to the clipboard and
  44 to the cut buffer."
  45   (interactive "@e")
  46   (let ((old-point (point)))
  47     (mouse-set-point event)
  48     (let ((s (buffer-substring old-point (point))))
  49       (own-clipboard s)
  50       (x-store-cutbuffer s))
  51     (kill-region old-point (point))))
  52
  53 (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
  54 (defun x-set-point-and-insert-selection (event)
  55   "Set point where clicked and insert the primary selection or the cut buffer."
  56   (interactive "e")
  57   (let ((mouse-yank-at-point nil))
  58     (mouse-yank event)))
  59
  60 (defun x-set-point-and-move-selection (event)
  61   "Set point where clicked and move the selected text to that location."
  62   (interactive "e")
  63   ;; Don't try to move the selection if x-kill-primary-selection if going
  64   ;; to fail; just let the appropriate error message get issued. (We need
  65   ;; to insert the selection and set point first, or the selection may
  66   ;; get inserted at the wrong place.)
  67   (and (selection-owner-p)
  68        primary-selection-extent
  69        (insert-selection t event))
  70   (kill-primary-selection))
  71
  72 (defun mouse-track-and-copy-to-cutbuffer (event)
  73   "Make a selection like `mouse-track', but also copy it to the cutbuffer."
  74   (interactive "e")
  75   (mouse-track event)
  76   (cond
  77    ((null primary-selection-extent)
  78     nil)
  79    ((consp primary-selection-extent)
  80     (save-excursion
  81       (set-buffer (extent-object (car primary-selection-extent)))
  82       (x-store-cutbuffer
  83        (mapconcat
  84         #'identity
  85         (declare-fboundp
  86          (extract-rectangle
  87           (extent-start-position (car primary-selection-extent))
  88           (extent-end-position (car (reverse primary-selection-extent)))))
  89         "\n"))))
  90    (t
  91     (save-excursion
  92       (set-buffer (extent-object primary-selection-extent))
  93       (x-store-cutbuffer
  94        (buffer-substring (extent-start-position primary-selection-extent)
  95                          (extent-end-position primary-selection-extent)))))))
  96
  97 \f
  98 (defvar x-pointers-initialized nil)
  99
 100 (defun x-init-pointer-shape (device)
 101   "Initialize the mouse-pointers of DEVICE from the X resource database."
 102   (if x-pointers-initialized  ; only do it when the first device is created
 103       nil
 104     (set-glyph-image text-pointer-glyph
 105           (or (x-get-resource "textPointer" "Cursor" 'string device nil 'warn)
 106               [cursor-font :data "xterm"]))
 107     (set-glyph-image selection-pointer-glyph
 108           (or (x-get-resource "selectionPointer" "Cursor" 'string device
 109                               nil 'warn)
 110               [cursor-font :data "top_left_arrow"]))
 111     (set-glyph-image nontext-pointer-glyph
 112           (or (x-get-resource "spacePointer" "Cursor" 'string device nil 'warn)
 113               [cursor-font :data "xterm"])) ; was "crosshair"
 114     (set-glyph-image modeline-pointer-glyph
 115           (or (x-get-resource "modeLinePointer" "Cursor" 'string device
 116                               nil 'warn)
 117 ;;            "fleur"))
 118               [cursor-font :data "sb_v_double_arrow"]))
 119     (set-glyph-image gc-pointer-glyph
 120           (or (x-get-resource "gcPointer" "Cursor" 'string device nil 'warn)
 121               [cursor-font :data "watch"]))
 122     (when (featurep 'scrollbar)
 123       (set-glyph-image
 124        scrollbar-pointer-glyph
 125        (or (x-get-resource "scrollbarPointer" "Cursor" 'string device
 126                            nil 'warn)
 127            ;; bizarrely if we don't specify the specific locale (x) this
 128            ;; gets instantiated on the stream device. Bad puppy.
 129            [cursor-font :data "top_left_arrow"]) 'global '(default x)))
 130     (set-glyph-image busy-pointer-glyph
 131           (or (x-get-resource "busyPointer" "Cursor" 'string device nil 'warn)
 132               [cursor-font :data "watch"]))
 133     (set-glyph-image toolbar-pointer-glyph
 134           (or (x-get-resource "toolBarPointer" "Cursor" 'string device
 135                               nil 'warn)
 136               [cursor-font :data "left_ptr"]))
 137     (set-glyph-image divider-pointer-glyph
 138           (or (x-get-resource "dividerPointer" "Cursor" 'string device
 139                               nil 'warn)
 140               [cursor-font :data "sb_h_double_arrow"]))
 141     (let ((fg
 142            (x-get-resource "pointerColor" "Foreground" 'string device
 143                            nil 'warn)))
 144       (and fg
 145            (set-face-foreground 'pointer fg)))
 146     (let ((bg
 147            (x-get-resource "pointerBackground" "Background" 'string device
 148                            nil 'warn)))
 149       (and bg
 150            (set-face-background 'pointer bg)))
 151     (setq x-pointers-initialized t))
 152   nil)
 153
 154 ;;; x-mouse.el ends here