| 1 | ;;; select.el --- lisp portion of standard selection support. |
| 2 | |
| 3 | ;; Keywords: internal |
| 4 | |
| 5 | ;; Copyright (c) 1993, 1994 Free Software Foundation, Inc. |
| 6 | ;; Based partially on earlier release by Lucid. |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 13 | ;; any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 22 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 23 | ;; Boston, MA 02111-1307, USA. |
| 24 | |
| 25 | ;;; Code: |
| 26 | |
| 27 | ;; This is for temporary compatibility with pre-release Emacs 19. |
| 28 | (defalias 'x-selection 'x-get-selection) |
| 29 | (defun x-get-selection (&optional type data-type) |
| 30 | "Return the value of an X Windows selection. |
| 31 | The argument TYPE (default `PRIMARY') says which selection, |
| 32 | and the argument DATA-TYPE (default `STRING') says |
| 33 | how to convert the data." |
| 34 | (x-get-selection-internal (or type 'PRIMARY) (or data-type 'STRING))) |
| 35 | |
| 36 | (defun x-get-clipboard () |
| 37 | "Return text pasted to the clipboard." |
| 38 | (x-get-selection-internal 'CLIPBOARD 'STRING)) |
| 39 | |
| 40 | (defun x-set-selection (type data) |
| 41 | "Make an X Windows selection of type TYPE and value DATA. |
| 42 | The argument TYPE (default `PRIMARY') says which selection, |
| 43 | and DATA specifies the contents. DATA may be a string, |
| 44 | a symbol, an integer (or a cons of two integers or list of two integers). |
| 45 | |
| 46 | The selection may also be a cons of two markers pointing to the same buffer, |
| 47 | or an overlay. In these cases, the selection is considered to be the text |
| 48 | between the markers *at whatever time the selection is examined*. |
| 49 | Thus, editing done in the buffer after you specify the selection |
| 50 | can alter the effective value of the selection. |
| 51 | |
| 52 | The data may also be a vector of valid non-vector selection values. |
| 53 | |
| 54 | Interactively, the text of the region is used as the selection value |
| 55 | if the prefix arg is set." |
| 56 | (interactive (if (not current-prefix-arg) |
| 57 | (list 'PRIMARY (read-string "Set text for pasting: ")) |
| 58 | (list 'PRIMARY (buffer-substring (region-beginning) (region-end))))) |
| 59 | ;; This is for temporary compatibility with pre-release Emacs 19. |
| 60 | (if (stringp type) |
| 61 | (setq type (intern type))) |
| 62 | (or (x-valid-simple-selection-p data) |
| 63 | (and (vectorp data) |
| 64 | (let ((valid t) |
| 65 | (i (1- (length data)))) |
| 66 | (while (>= i 0) |
| 67 | (or (x-valid-simple-selection-p (aref data i)) |
| 68 | (setq valid nil)) |
| 69 | (setq i (1- i))) |
| 70 | valid)) |
| 71 | (signal 'error (list "invalid selection" data))) |
| 72 | (or type (setq type 'PRIMARY)) |
| 73 | (if data |
| 74 | (x-own-selection-internal type data) |
| 75 | (x-disown-selection-internal type)) |
| 76 | data) |
| 77 | |
| 78 | (defun x-valid-simple-selection-p (data) |
| 79 | (or (stringp data) |
| 80 | (symbolp data) |
| 81 | (integerp data) |
| 82 | (and (consp data) |
| 83 | (integerp (car data)) |
| 84 | (or (integerp (cdr data)) |
| 85 | (and (consp (cdr data)) |
| 86 | (integerp (car (cdr data)))))) |
| 87 | (overlayp data) |
| 88 | (and (consp data) |
| 89 | (markerp (car data)) |
| 90 | (markerp (cdr data)) |
| 91 | (marker-buffer (car data)) |
| 92 | (marker-buffer (cdr data)) |
| 93 | (eq (marker-buffer (car data)) |
| 94 | (marker-buffer (cdr data))) |
| 95 | (buffer-name (marker-buffer (car data))) |
| 96 | (buffer-name (marker-buffer (cdr data)))))) |
| 97 | \f |
| 98 | ;;; Cut Buffer support |
| 99 | |
| 100 | (defun x-get-cut-buffer (&optional which-one) |
| 101 | "Returns the value of one of the 8 X server cut-buffers. Optional arg |
| 102 | WHICH-ONE should be a number from 0 to 7, defaulting to 0. |
| 103 | Cut buffers are considered obsolete; you should use selections instead." |
| 104 | (x-get-cut-buffer-internal |
| 105 | (if which-one |
| 106 | (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3 |
| 107 | CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7] |
| 108 | which-one) |
| 109 | 'CUT_BUFFER0))) |
| 110 | |
| 111 | (defun x-set-cut-buffer (string &optional push) |
| 112 | "Store STRING into the X server's primary cut buffer. |
| 113 | If PUSH is non-nil, also rotate the cut buffers: |
| 114 | this means the previous value of the primary cut buffer moves the second |
| 115 | cut buffer, and the second to the third, and so on (there are 8 buffers.) |
| 116 | Cut buffers are considered obsolete; you should use selections instead." |
| 117 | ;; Check the data type of STRING. |
| 118 | (substring string 0 0) |
| 119 | (if push |
| 120 | (x-rotate-cut-buffers-internal 1)) |
| 121 | (x-store-cut-buffer-internal 'CUT_BUFFER0 string)) |
| 122 | |
| 123 | \f |
| 124 | ;;; Functions to convert the selection into various other selection types. |
| 125 | ;;; Every selection type that Emacs handles is implemented this way, except |
| 126 | ;;; for TIMESTAMP, which is a special case. |
| 127 | |
| 128 | (defun xselect-convert-to-string (selection type value) |
| 129 | (cond ((stringp value) |
| 130 | value) |
| 131 | ((overlayp value) |
| 132 | (save-excursion |
| 133 | (or (buffer-name (overlay-buffer value)) |
| 134 | (error "selection is in a killed buffer")) |
| 135 | (set-buffer (overlay-buffer value)) |
| 136 | (buffer-substring (overlay-start value) |
| 137 | (overlay-end value)))) |
| 138 | ((and (consp value) |
| 139 | (markerp (car value)) |
| 140 | (markerp (cdr value))) |
| 141 | (or (eq (marker-buffer (car value)) (marker-buffer (cdr value))) |
| 142 | (signal 'error |
| 143 | (list "markers must be in the same buffer" |
| 144 | (car value) (cdr value)))) |
| 145 | (save-excursion |
| 146 | (set-buffer (or (marker-buffer (car value)) |
| 147 | (error "selection is in a killed buffer"))) |
| 148 | (buffer-substring (car value) (cdr value)))) |
| 149 | (t nil))) |
| 150 | |
| 151 | (defun xselect-convert-to-length (selection type value) |
| 152 | (let ((value |
| 153 | (cond ((stringp value) |
| 154 | (length value)) |
| 155 | ((overlayp value) |
| 156 | (abs (- (overlay-end value) (overlay-start value)))) |
| 157 | ((and (consp value) |
| 158 | (markerp (car value)) |
| 159 | (markerp (cdr value))) |
| 160 | (or (eq (marker-buffer (car value)) |
| 161 | (marker-buffer (cdr value))) |
| 162 | (signal 'error |
| 163 | (list "markers must be in the same buffer" |
| 164 | (car value) (cdr value)))) |
| 165 | (abs (- (car value) (cdr value))))))) |
| 166 | (if value ; force it to be in 32-bit format. |
| 167 | (cons (ash value -16) (logand value 65535)) |
| 168 | nil))) |
| 169 | |
| 170 | (defun xselect-convert-to-targets (selection type value) |
| 171 | ;; return a vector of atoms, but remove duplicates first. |
| 172 | (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist))) |
| 173 | (rest all)) |
| 174 | (while rest |
| 175 | (cond ((memq (car rest) (cdr rest)) |
| 176 | (setcdr rest (delq (car rest) (cdr rest)))) |
| 177 | ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret |
| 178 | (setcdr rest (cdr (cdr rest)))) |
| 179 | (t |
| 180 | (setq rest (cdr rest))))) |
| 181 | (apply 'vector all))) |
| 182 | |
| 183 | (defun xselect-convert-to-delete (selection type value) |
| 184 | (x-disown-selection-internal selection) |
| 185 | ;; A return value of nil means that we do not know how to do this conversion, |
| 186 | ;; and replies with an "error". A return value of NULL means that we have |
| 187 | ;; done the conversion (and any side-effects) but have no value to return. |
| 188 | 'NULL) |
| 189 | |
| 190 | (defun xselect-convert-to-filename (selection type value) |
| 191 | (cond ((overlayp value) |
| 192 | (buffer-file-name (or (overlay-buffer value) |
| 193 | (error "selection is in a killed buffer")))) |
| 194 | ((and (consp value) |
| 195 | (markerp (car value)) |
| 196 | (markerp (cdr value))) |
| 197 | (buffer-file-name (or (marker-buffer (car value)) |
| 198 | (error "selection is in a killed buffer")))) |
| 199 | (t nil))) |
| 200 | |
| 201 | (defun xselect-convert-to-charpos (selection type value) |
| 202 | (let (a b tmp) |
| 203 | (cond ((cond ((overlayp value) |
| 204 | (setq a (overlay-start value) |
| 205 | b (overlay-end value))) |
| 206 | ((and (consp value) |
| 207 | (markerp (car value)) |
| 208 | (markerp (cdr value))) |
| 209 | (setq a (car value) |
| 210 | b (cdr value)))) |
| 211 | (setq a (1- a) b (1- b)) ; zero-based |
| 212 | (if (< b a) (setq tmp a a b b tmp)) |
| 213 | (cons 'SPAN |
| 214 | (vector (cons (ash a -16) (logand a 65535)) |
| 215 | (cons (ash b -16) (logand b 65535)))))))) |
| 216 | |
| 217 | (defun xselect-convert-to-lineno (selection type value) |
| 218 | (let (a b buf tmp) |
| 219 | (cond ((cond ((and (consp value) |
| 220 | (markerp (car value)) |
| 221 | (markerp (cdr value))) |
| 222 | (setq a (marker-position (car value)) |
| 223 | b (marker-position (cdr value)) |
| 224 | buf (marker-buffer (car value)))) |
| 225 | ((overlayp value) |
| 226 | (setq buf (overlay-buffer value) |
| 227 | a (overlay-start value) |
| 228 | b (overlay-end value))) |
| 229 | ) |
| 230 | (save-excursion |
| 231 | (set-buffer buf) |
| 232 | (setq a (count-lines 1 a) |
| 233 | b (count-lines 1 b))) |
| 234 | (if (< b a) (setq tmp a a b b tmp)) |
| 235 | (cons 'SPAN |
| 236 | (vector (cons (ash a -16) (logand a 65535)) |
| 237 | (cons (ash b -16) (logand b 65535)))))))) |
| 238 | |
| 239 | (defun xselect-convert-to-colno (selection type value) |
| 240 | (let (a b buf tmp) |
| 241 | (cond ((cond ((and (consp value) |
| 242 | (markerp (car value)) |
| 243 | (markerp (cdr value))) |
| 244 | (setq a (car value) |
| 245 | b (cdr value) |
| 246 | buf (marker-buffer a))) |
| 247 | ((overlayp value) |
| 248 | (setq buf (overlay-buffer value) |
| 249 | a (overlay-start value) |
| 250 | b (overlay-end value))) |
| 251 | ) |
| 252 | (save-excursion |
| 253 | (set-buffer buf) |
| 254 | (goto-char a) |
| 255 | (setq a (current-column)) |
| 256 | (goto-char b) |
| 257 | (setq b (current-column))) |
| 258 | (if (< b a) (setq tmp a a b b tmp)) |
| 259 | (cons 'SPAN |
| 260 | (vector (cons (ash a -16) (logand a 65535)) |
| 261 | (cons (ash b -16) (logand b 65535)))))))) |
| 262 | |
| 263 | (defun xselect-convert-to-os (selection type size) |
| 264 | (symbol-name system-type)) |
| 265 | |
| 266 | (defun xselect-convert-to-host (selection type size) |
| 267 | (system-name)) |
| 268 | |
| 269 | (defun xselect-convert-to-user (selection type size) |
| 270 | (user-full-name)) |
| 271 | |
| 272 | (defun xselect-convert-to-class (selection type size) |
| 273 | "Emacs") |
| 274 | |
| 275 | ;; We do not try to determine the name Emacs was invoked with, |
| 276 | ;; because it is not clean for a program's behavior to depend on that. |
| 277 | (defun xselect-convert-to-name (selection type size) |
| 278 | "emacs") |
| 279 | |
| 280 | (defun xselect-convert-to-integer (selection type value) |
| 281 | (and (integerp value) |
| 282 | (cons (ash value -16) (logand value 65535)))) |
| 283 | |
| 284 | (defun xselect-convert-to-atom (selection type value) |
| 285 | (and (symbolp value) value)) |
| 286 | |
| 287 | (defun xselect-convert-to-identity (selection type value) ; used internally |
| 288 | (vector value)) |
| 289 | |
| 290 | (setq selection-converter-alist |
| 291 | '((TEXT . xselect-convert-to-string) |
| 292 | (COMPOUND_TEXT . xselect-convert-to-string) |
| 293 | (STRING . xselect-convert-to-string) |
| 294 | (TARGETS . xselect-convert-to-targets) |
| 295 | (LENGTH . xselect-convert-to-length) |
| 296 | (DELETE . xselect-convert-to-delete) |
| 297 | (FILE_NAME . xselect-convert-to-filename) |
| 298 | (CHARACTER_POSITION . xselect-convert-to-charpos) |
| 299 | (LINE_NUMBER . xselect-convert-to-lineno) |
| 300 | (COLUMN_NUMBER . xselect-convert-to-colno) |
| 301 | (OWNER_OS . xselect-convert-to-os) |
| 302 | (HOST_NAME . xselect-convert-to-host) |
| 303 | (USER . xselect-convert-to-user) |
| 304 | (CLASS . xselect-convert-to-class) |
| 305 | (NAME . xselect-convert-to-name) |
| 306 | (ATOM . xselect-convert-to-atom) |
| 307 | (INTEGER . xselect-convert-to-integer) |
| 308 | (_EMACS_INTERNAL . xselect-convert-to-identity) |
| 309 | )) |
| 310 | |
| 311 | (provide 'select) |
| 312 | |
| 313 | ;;; select.el ends here. |