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