| 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 |