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. 111The argument may be a string, a cons of two markers, or an extent. 112In the latter cases the selection is considered to be the text 113between 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 134string or a cons of two markers (in which case the selection is considered to 135be 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 151secondary 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 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 192both 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 206the 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 243