code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/lselect.el

   1 ;;; lselect.el --- Lucid interface to X Selections
   2
   3 ;; Copyright (C) 1990, 1993, 2002, 2003, 2004,
   4 ;;   2005 Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: emulations
   8
   9 ;; This won't completely work until we support or emulate Lucid-style extents.
  10 ;; Based on Lucid's selection code.
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  26 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  27 ;; Boston, MA 02110-1301, USA.
  28
  29 ;;; Commentary:
  30
  31 ;;; Code:
  32
  33 ;; The selection code requires us to use certain symbols whose names are
  34 ;; all upper-case; this may seem tasteless, but it makes there be a 1:1
  35 ;; correspondence between these symbols and X Atoms (which are upcased.)
  36
  37 (defalias 'x-get-cutbuffer 'x-get-cut-buffer)
  38 (defalias 'x-store-cutbuffer 'x-set-cut-buffer)
  39
  40 (or (facep 'primary-selection)
  41     (make-face 'primary-selection))
  42
  43 (or (facep 'secondary-selection)
  44     (make-face 'secondary-selection))
  45
  46 (defun x-get-secondary-selection ()
  47   "Return text selected from some X window."
  48   (x-get-selection-internal 'SECONDARY 'STRING))
  49
  50 (defvar primary-selection-extent nil
  51   "The extent of the primary selection; don't use this.")
  52
  53 (defvar secondary-selection-extent nil
  54   "The extent of the secondary selection; don't use this.")
  55
  56
  57 (defun x-select-make-extent-for-selection (selection previous-extent face)
  58   ;; Given a selection, this makes an extent in the buffer which holds that
  59   ;; selection, for highlighting purposes.  If the selection isn't associated
  60   ;; with a buffer, this does nothing.
  61   (let ((buffer nil)
  62         (valid (and (extentp previous-extent)
  63                     (extent-buffer previous-extent)
  64                     (buffer-name (extent-buffer previous-extent))))
  65         start end)
  66     (cond ((stringp selection)
  67            ;; if we're selecting a string, lose the previous extent used
  68            ;; to highlight the selection.
  69            (setq valid nil))
  70           ((consp selection)
  71            (setq start (min (car selection) (cdr selection))
  72                  end (max (car selection) (cdr selection))
  73                  valid (and valid
  74                             (eq (marker-buffer (car selection))
  75                                 (extent-buffer previous-extent)))
  76                  buffer (marker-buffer (car selection))))
  77           ((extentp selection)
  78            (setq start (extent-start-position selection)
  79                  end (extent-end-position selection)
  80                  valid (and valid
  81                             (eq (extent-buffer selection)
  82                                 (extent-buffer previous-extent)))
  83                  buffer (extent-buffer selection)))
  84           )
  85     (if (and (not valid)
  86              (extentp previous-extent)
  87              (extent-buffer previous-extent)
  88              (buffer-name (extent-buffer previous-extent)))
  89         (delete-extent previous-extent))
  90     (if (not buffer)
  91         ;; string case
  92         nil
  93       ;; normal case
  94       (if valid
  95           (set-extent-endpoints previous-extent start end)
  96         (setq previous-extent (make-extent start end buffer))
  97         ;; use same priority as mouse-highlighting so that conflicts between
  98         ;; the selection extent and a mouse-highlighted extent are resolved
  99         ;; by the usual size-and-endpoint-comparison method.
 100         (set-extent-priority previous-extent mouse-highlight-priority)
 101         (set-extent-face previous-extent face)))))
 102
 103
 104 (defun x-own-selection (selection &optional type)
 105   "Make a primary X Selection of the given argument.
 106 The argument may be a string, a cons of two markers, or an extent.
 107 In the latter cases the selection is considered to be the text
 108 between the markers, or the between extents endpoints."
 109   (interactive (if (not current-prefix-arg)
 110                    (list (read-string "Store text for pasting: "))
 111                  (list (cons ;; these need not be ordered.
 112                         (copy-marker (point-marker))
 113                         (copy-marker (mark-marker))))))
 114   (or type (setq type 'PRIMARY))
 115   (x-set-selection selection type)
 116   (cond ((eq type 'PRIMARY)
 117          (setq primary-selection-extent
 118                (x-select-make-extent-for-selection
 119                 selection primary-selection-extent 'primary-selection)))
 120         ((eq type 'SECONDARY)
 121          (setq secondary-selection-extent
 122                (x-select-make-extent-for-selection
 123                 selection secondary-selection-extent 'secondary-selection))))
 124   selection)
 125
 126
 127 (defun x-own-secondary-selection (selection &optional type)
 128   "Make a secondary X Selection of the given argument.  The argument may be a
 129 string or a cons of two markers (in which case the selection is considered to
 130 be the text between those markers.)"
 131   (interactive (if (not current-prefix-arg)
 132                    (list (read-string "Store text for pasting: "))
 133                  (list (cons ;; these need not be ordered.
 134                         (copy-marker (point-marker))
 135                         (copy-marker (mark-marker))))))
 136   (x-own-selection selection 'SECONDARY))
 137
 138
 139 (defun x-own-clipboard (string)
 140   "Paste the given string to the X Clipboard."
 141   (x-own-selection string 'CLIPBOARD))
 142
 143
 144 (defun x-disown-selection (&optional secondary-p)
 145   "Assuming we own the selection, disown it.  With an argument, discard the
 146 secondary selection instead of the primary selection."
 147   (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
 148
 149 (defun x-dehilight-selection (selection)
 150   "for use as a value of `x-lost-selection-functions'."
 151   (cond ((eq selection 'PRIMARY)
 152          (if primary-selection-extent
 153              (let ((inhibit-quit t))
 154                (delete-extent primary-selection-extent)
 155                (setq primary-selection-extent nil)))
 156          (if zmacs-regions (zmacs-deactivate-region)))
 157         ((eq selection 'SECONDARY)
 158          (if secondary-selection-extent
 159              (let ((inhibit-quit t))
 160                (delete-extent secondary-selection-extent)
 161                (setq secondary-selection-extent nil)))))
 162   nil)
 163
 164 (setq x-lost-selection-functions 'x-dehilight-selection)
 165
 166 (defun x-notice-selection-requests (selection type successful)
 167   "for possible use as the value of `x-sent-selection-functions'."
 168   (if (not successful)
 169       (message "Selection request failed to convert %s to %s"
 170                selection type)
 171     (message "Sent selection %s as %s" selection type)))
 172
 173 (defun x-notice-selection-failures (selection type successful)
 174   "for possible use as the value of `x-sent-selection-functions'."
 175   (or successful
 176       (message "Selection request failed to convert %s to %s"
 177                selection type)))
 178
 179 ;(setq x-sent-selection-functions 'x-notice-selection-requests)
 180 ;(setq x-sent-selection-functions 'x-notice-selection-failures)
 181
 182 \f
 183 ;; Random utility functions
 184
 185 (defun x-kill-primary-selection ()
 186   "If there is a selection, delete the text it covers, and copy it to
 187 both the kill ring and the Clipboard."
 188   (interactive)
 189   (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
 190   (setq last-command nil)
 191   (or primary-selection-extent
 192       (error "the primary selection is not an extent?"))
 193   (save-excursion
 194     (set-buffer (extent-buffer primary-selection-extent))
 195     (kill-region (extent-start-position primary-selection-extent)
 196                  (extent-end-position primary-selection-extent)))
 197   (x-disown-selection nil))
 198
 199 (defun x-delete-primary-selection ()
 200   "If there is a selection, delete the text it covers *without* copying it to
 201 the kill ring or the Clipboard."
 202   (interactive)
 203   (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
 204   (setq last-command nil)
 205   (or primary-selection-extent
 206       (error "the primary selection is not an extent?"))
 207   (save-excursion
 208     (set-buffer (extent-buffer primary-selection-extent))
 209     (delete-region (extent-start-position primary-selection-extent)
 210                    (extent-end-position primary-selection-extent)))
 211   (x-disown-selection nil))
 212
 213 (defun x-copy-primary-selection ()
 214   "If there is a selection, copy it to both the kill ring and the Clipboard."
 215   (interactive)
 216   (setq last-command nil)
 217   (or (x-selection-owner-p) (error "emacs does not own the primary selection"))
 218   (or primary-selection-extent
 219       (error "the primary selection is not an extent?"))
 220   (save-excursion
 221     (set-buffer (extent-buffer primary-selection-extent))
 222     (copy-region-as-kill (extent-start-position primary-selection-extent)
 223                          (extent-end-position primary-selection-extent))))
 224
 225 (defun x-yank-clipboard-selection ()
 226   "If someone owns a Clipboard selection, insert it at point."
 227   (interactive)
 228   (setq last-command nil)
 229   (let ((clip (x-get-clipboard)))
 230     (or clip (error "there is no clipboard selection"))
 231     (push-mark)
 232     (insert clip)))
 233
 234 (provide 'lselect)
 235
 236 ;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556
 237 ;;; lselect.el ends here