lisp/emacs-lisp/lselect.el

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