lisp/emacs-lisp/lselect.el

   1 ;;; lselect.el --- Lucid interface to X Selections
   2
   3 ;; Copyright (C) 1990, 1993, 2001, 2002, 2003, 2004,
   4 ;;   2005, 2006, 2007 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 ;; This is Lucid/XEmacs stuff
  38 (defvar mouse-highlight-priority)
  39 (defvar x-lost-selection-functions)
  40 (defvar zmacs-regions)
  41
  42 (defalias 'x-get-cutbuffer 'x-get-cut-buffer)
  43 (defalias 'x-store-cutbuffer 'x-set-cut-buffer)
  44
  45 (or (facep 'primary-selection)
  46     (make-face 'primary-selection))
  47
  48 (or (facep 'secondary-selection)
  49     (make-face 'secondary-selection))
  50
  51 (defun x-get-secondary-selection ()
  52   "Return text selected from some X window."
  53   (x-get-selection-internal 'SECONDARY 'STRING))
  54
  55 (defvar primary-selection-extent nil
  56   "The extent of the primary selection; don't use this.")
  57
  58 (defvar secondary-selection-extent nil
  59   "The extent of the secondary selection; don't use this.")
  60
  61
  62 (defun x-select-make-extent-for-selection (selection previous-extent face)
  63   ;; Given a selection, this makes an extent in the buffer which holds that
  64   ;; selection, for highlighting purposes.  If the selection isn't associated
  65   ;; with a buffer, this does nothing.
  66   (let ((buffer nil)
  67         (valid (and (extentp previous-extent)
  68                     (extent-buffer previous-extent)
  69                     (buffer-name (extent-buffer previous-extent))))
  70         start end)
  71     (cond ((stringp selection)
  72            ;; if we're selecting a string, lose the previous extent used
  73            ;; to highlight the selection.
  74            (setq valid nil))
  75           ((consp selection)
  76            (setq start (min (car selection) (cdr selection))
  77                  end (max (car selection) (cdr selection))
  78                  valid (and valid
  79                             (eq (marker-buffer (car selection))
  80                                 (extent-buffer previous-extent)))
  81                  buffer (marker-buffer (car selection))))
  82           ((extentp selection)
  83            (setq start (extent-start-position selection)
  84                  end (extent-end-position selection)
  85                  valid (and valid
  86                             (eq (extent-buffer selection)
  87                                 (extent-buffer previous-extent)))
  88                  buffer (extent-buffer selection)))
  89           )
  90     (if (and (not valid)
  91              (extentp previous-extent)
  92              (extent-buffer previous-extent)
  93              (buffer-name (extent-buffer previous-extent)))
  94         (delete-extent previous-extent))
  95     (if (not buffer)
  96         ;; string case
  97         nil
  98       ;; normal case
  99       (if valid
 100           (set-extent-endpoints previous-extent start end)
 101         (setq previous-extent (make-extent start end buffer))
 102         ;; use same priority as mouse-highlighting so that conflicts between
 103         ;; the selection extent and a mouse-highlighted extent are resolved
 104         ;; by the usual size-and-endpoint-comparison method.
 105         (set-extent-priority previous-extent mouse-highlight-priority)
 106         (set-extent-face previous-extent face)))))
 107
 108
 109 (defun x-own-selection (selection &optional type)
 110   "Make a primary X Selection of the given argument.
 111 The argument may be a string, a cons of two markers, or an extent.
 112 In the latter cases the selection is considered to be the text
 113 between the markers, or the between extents endpoints."
 114   (interactive (if (not current-prefix-arg)
 115                    (list (read-string "Store text for pasting: "))
 116                  (list (cons ;; these need not be ordered.
 117                         (copy-marker (point-marker))
 118                         (copy-marker (mark-marker))))))
 119   (or type (setq type 'PRIMARY))
 120   (x-set-selection selection type)
 121   (cond ((eq type 'PRIMARY)
 122          (setq primary-selection-extent
 123                (x-select-make-extent-for-selection
 124                 selection primary-selection-extent 'primary-selection)))
 125         ((eq type 'SECONDARY)
 126          (setq secondary-selection-extent
 127                (x-select-make-extent-for-selection
 128                 selection secondary-selection-extent 'secondary-selection))))
 129   selection)
 130
 131
 132 (defun x-own-secondary-selection (selection &optional type)
 133   "Make a secondary X Selection of the given argument.  The argument may be a
 134 string or a cons of two markers (in which case the selection is considered to
 135 be the text between those markers.)"
 136   (interactive (if (not current-prefix-arg)
 137                    (list (read-string "Store text for pasting: "))
 138                  (list (cons ;; these need not be ordered.
 139                         (copy-marker (point-marker))
 140                         (copy-marker (mark-marker))))))
 141   (x-own-selection selection 'SECONDARY))
 142
 143
 144 (defun x-own-clipboard (string)
 145   "Paste the given string to the X Clipboard."
 146   (x-own-selection string 'CLIPBOARD))
 147
 148
 149 (defun x-disown-selection (&optional secondary-p)
 150   "Assuming we own the selection, disown it.  With an argument, discard the
 151 secondary selection instead of the primary selection."
 152   (x-disown-selection-internal (if secondary-p 'SECONDARY 'PRIMARY)))
 153
 154 (defun x-dehilight-selection (selection)
 155   "for use as a value of `x-lost-selection-functions'."
 156   (cond ((eq selection 'PRIMARY)
 157          (if primary-selection-extent
 158              (let ((inhibit-quit t))
 159                (delete-extent primary-selection-extent)
 160                (setq primary-selection-extent nil)))
 161          (if zmacs-regions (zmacs-deactivate-region)))
 162         ((eq selection 'SECONDARY)
 163          (if secondary-selection-extent
 164              (let ((inhibit-quit t))
 165                (delete-extent secondary-selection-extent)
 166                (setq secondary-selection-extent nil)))))
 167   nil)
 168
 169 (setq x-lost-selection-functions 'x-dehilight-selection)
 170
 171 (defun x-notice-selection-requests (selection type successful)
 172   "for possible use as the value of `x-sent-selection-functions'."
 173   (if (not successful)
 174       (message "Selection request failed to convert %s to %s"
 175                selection type)
 176     (message "Sent selection %s as %s" selection type)))
 177
 178 (defun x-notice-selection-failures (selection type successful)
 179   "for possible use as the value of `x-sent-selection-functions'."
 180   (or successful
 181       (message "Selection request failed to convert %s to %s"
 182                selection type)))
 183
 184 ;(setq x-sent-selection-functions 'x-notice-selection-requests)
 185 ;(setq x-sent-selection-functions 'x-notice-selection-failures)
 186
 187 \f
 188 ;; Random utility functions
 189
 190 (defun x-kill-primary-selection ()
 191   "If there is a selection, delete the text it covers, and copy it to
 192 both the kill ring and the Clipboard."
 193   (interactive)
 194   (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
 195   (setq last-command nil)
 196   (or primary-selection-extent
 197       (error "the primary selection is not an extent?"))
 198   (save-excursion
 199     (set-buffer (extent-buffer primary-selection-extent))
 200     (kill-region (extent-start-position primary-selection-extent)
 201                  (extent-end-position primary-selection-extent)))
 202   (x-disown-selection nil))
 203
 204 (defun x-delete-primary-selection ()
 205   "If there is a selection, delete the text it covers *without* copying it to
 206 the kill ring or the Clipboard."
 207   (interactive)
 208   (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
 209   (setq last-command nil)
 210   (or primary-selection-extent
 211       (error "the primary selection is not an extent?"))
 212   (save-excursion
 213     (set-buffer (extent-buffer primary-selection-extent))
 214     (delete-region (extent-start-position primary-selection-extent)
 215                    (extent-end-position primary-selection-extent)))
 216   (x-disown-selection nil))
 217
 218 (defun x-copy-primary-selection ()
 219   "If there is a selection, copy it to both the kill ring and the Clipboard."
 220   (interactive)
 221   (setq last-command nil)
 222   (or (x-selection-owner-p) (error "Emacs does not own the primary selection"))
 223   (or primary-selection-extent
 224       (error "the primary selection is not an extent?"))
 225   (save-excursion
 226     (set-buffer (extent-buffer primary-selection-extent))
 227     (copy-region-as-kill (extent-start-position primary-selection-extent)
 228                          (extent-end-position primary-selection-extent))))
 229
 230 (defun x-yank-clipboard-selection ()
 231   "If someone owns a Clipboard selection, insert it at point."
 232   (interactive)
 233   (setq last-command nil)
 234   (let ((clip (x-get-clipboard)))
 235     (or clip (error "there is no clipboard selection"))
 236     (push-mark)
 237     (insert clip)))
 238
 239 (provide 'lselect)
 240
 241 ;; arch-tag: 92fa54d4-c5d1-4e9b-ad58-cf1e13930556
 242 ;;; lselect.el ends here