| 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. |
| 100 | The argument may be a string, a cons of two markers, or an extent. |
| 101 | In the latter cases the selection is considered to be the text |
| 102 | between 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 |
| 123 | string or a cons of two markers (in which case the selection is considered to |
| 124 | be 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 |
| 140 | secondary 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 | \f |
| 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 |
| 181 | both 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 |
| 195 | the 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. |