git.chise.org Git - chise/xemacs-chise.git.1/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 (defun x-mouse-kill (event)
  40   "Kill the text between the point and mouse and copy it to the clipboard and
  41 to the cut buffer"
  42   (interactive "@e")
  43   (let ((old-point (point)))
  44     (mouse-set-point event)
  45     (let ((s (buffer-substring old-point (point))))
  46       (x-own-clipboard s)
  47       (x-store-cutbuffer s))
  48     (kill-region old-point (point))))
  49
  50 (defun x-yank-function ()
  51   "Insert the current X selection or, if there is none, insert the X cutbuffer.
  52 A mark is pushed, so that the inserted text lies between point and mark."
  53   (push-mark)
  54   (if (region-active-p)
  55       (if (consp zmacs-region-extent)
  56           ;; pirated code from insert-rectangle in rect.el
  57           ;; perhaps that code should be modified to handle a list of extents
  58           ;; as the rectangle to be inserted?
  59           (let ((lines zmacs-region-extent)
  60                 (insertcolumn (current-column))
  61                 (first t))
  62             (push-mark)
  63             (while lines
  64               (or first
  65                   (progn
  66                     (forward-line 1)
  67                     (or (bolp) (insert ?\n))
  68                     (move-to-column insertcolumn t)))
  69               (setq first nil)
  70               (insert (extent-string (car lines)))
  71               (setq lines (cdr lines))))
  72         (insert (extent-string zmacs-region-extent)))
  73     (x-insert-selection t)))
  74
  75 (defun x-insert-selection (&optional check-cutbuffer-p move-point-event)
  76   "Insert the current selection into buffer at point."
  77   (interactive "P")
  78   (let ((text (if check-cutbuffer-p
  79                   (or (condition-case () (x-get-selection) (error ()))
  80                       (x-get-cutbuffer)
  81                       (error "No selection or cut buffer available"))
  82                 (x-get-selection))))
  83     (cond (move-point-event
  84            (mouse-set-point move-point-event)
  85            (push-mark (point)))
  86           ((interactive-p)
  87            (push-mark (point))))
  88     (insert text)
  89     ))
  90
  91 (make-obsolete 'x-set-point-and-insert-selection 'mouse-yank)
  92 (defun x-set-point-and-insert-selection (event)
  93   "Set point where clicked and insert the primary selection or the cut buffer."
  94   (interactive "e")
  95   (let ((mouse-yank-at-point nil))
  96     (mouse-yank event)))
  97
  98 (defun x-set-point-and-move-selection (event)
  99   "Set point where clicked and move the selected text to that location."
 100   (interactive "e")
 101   ;; Don't try to move the selection if x-kill-primary-selection if going
 102   ;; to fail; just let the appropriate error message get issued. (We need
 103   ;; to insert the selection and set point first, or the selection may
 104   ;; get inserted at the wrong place.)
 105   (and (x-selection-owner-p)
 106        primary-selection-extent
 107        (x-insert-selection t event))
 108   (kill-primary-selection))
 109
 110 (defun mouse-track-and-copy-to-cutbuffer (event)
 111   "Make a selection like `mouse-track', but also copy it to the cutbuffer."
 112   (interactive "e")
 113   (mouse-track event)
 114   (cond
 115    ((null primary-selection-extent)
 116     nil)
 117    ((consp primary-selection-extent)
 118     (save-excursion
 119       (set-buffer (extent-object (car primary-selection-extent)))
 120       (x-store-cutbuffer
 121        (mapconcat
 122         'identity
 123         (extract-rectangle
 124          (extent-start-position (car primary-selection-extent))
 125          (extent-end-position (car (reverse primary-selection-extent))))
 126         "\n"))))
 127    (t
 128     (save-excursion
 129       (set-buffer (extent-object primary-selection-extent))
 130       (x-store-cutbuffer
 131        (buffer-substring (extent-start-position primary-selection-extent)
 132                          (extent-end-position primary-selection-extent)))))))
 133
 134 \f
 135 (defvar x-pointers-initialized nil)
 136
 137 (defun x-init-pointer-shape (device)
 138   "Initialize the mouse-pointers of DEVICE from the X resource database."
 139   (if x-pointers-initialized  ; only do it when the first device is created
 140       nil
 141     (set-glyph-image text-pointer-glyph
 142           (or (x-get-resource "textPointer" "Cursor" 'string device)
 143               "xterm"))
 144     (set-glyph-image selection-pointer-glyph
 145           (or (x-get-resource "selectionPointer" "Cursor" 'string device)
 146               "top_left_arrow"))
 147     (set-glyph-image nontext-pointer-glyph
 148           (or (x-get-resource "spacePointer" "Cursor" 'string device)
 149               "xterm")) ; was "crosshair"
 150     (set-glyph-image modeline-pointer-glyph
 151           (or (x-get-resource "modeLinePointer" "Cursor" 'string device)
 152 ;;            "fleur"))
 153               "sb_v_double_arrow"))
 154     (set-glyph-image gc-pointer-glyph
 155           (or (x-get-resource "gcPointer" "Cursor" 'string device)
 156               "watch"))
 157     (when (featurep 'scrollbar)
 158       (set-glyph-image
 159        scrollbar-pointer-glyph
 160        (or (x-get-resource "scrollbarPointer" "Cursor" 'string device)
 161            "top_left_arrow")))
 162     (set-glyph-image busy-pointer-glyph
 163           (or (x-get-resource "busyPointer" "Cursor" 'string device)
 164               "watch"))
 165     (set-glyph-image toolbar-pointer-glyph
 166           (or (x-get-resource "toolBarPointer" "Cursor" 'string device)
 167               "left_ptr"))
 168     (set-glyph-image divider-pointer-glyph
 169           (or (x-get-resource "dividerPointer" "Cursor" 'string device)
 170               "sb_h_double_arrow"))
 171     (let ((fg
 172            (x-get-resource "pointerColor" "Foreground" 'string device)))
 173       (and fg
 174            (set-face-foreground 'pointer fg)))
 175     (let ((bg
 176            (x-get-resource "pointerBackground" "Background" 'string device)))
 177       (and bg
 178            (set-face-background 'pointer bg)))
 179     (setq x-pointers-initialized t))
 180   nil)
 181
 182 ;;; x-mouse.el ends here