| 1 | ;;; select.el --- lisp portion of standard selection support |
| 2 | |
| 3 | ;; Copyright (C) 1993-1994, 2001-2014 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Maintainer: emacs-devel@gnu.org |
| 6 | ;; Keywords: internal |
| 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 3 of the License, or |
| 13 | ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | |
| 25 | ;; Based partially on earlier release by Lucid. |
| 26 | |
| 27 | ;;; Code: |
| 28 | |
| 29 | (defcustom selection-coding-system nil |
| 30 | "Coding system for communicating with other programs. |
| 31 | |
| 32 | For MS-Windows and MS-DOS: |
| 33 | When sending or receiving text via selection and clipboard, the text |
| 34 | is encoded or decoded by this coding system. The default value is |
| 35 | the current system default encoding on 9x/Me, `utf-16le-dos' |
| 36 | \(Unicode) on NT/W2K/XP, and `iso-latin-1-dos' on MS-DOS. |
| 37 | |
| 38 | For X Windows: |
| 39 | When sending text via selection and clipboard, if the target |
| 40 | data-type matches with the type of this coding system, it is used |
| 41 | for encoding the text. Otherwise (including the case that this |
| 42 | variable is nil), a proper coding system is used as below: |
| 43 | |
| 44 | data-type coding system |
| 45 | --------- ------------- |
| 46 | UTF8_STRING utf-8 |
| 47 | COMPOUND_TEXT compound-text-with-extensions |
| 48 | STRING iso-latin-1 |
| 49 | C_STRING no-conversion |
| 50 | |
| 51 | When receiving text, if this coding system is non-nil, it is used |
| 52 | for decoding regardless of the data-type. If this is nil, a |
| 53 | proper coding system is used according to the data-type as above. |
| 54 | |
| 55 | See also the documentation of the variable `x-select-request-type' how |
| 56 | to control which data-type to request for receiving text. |
| 57 | |
| 58 | The default value is nil." |
| 59 | :type 'coding-system |
| 60 | :group 'mule |
| 61 | ;; Default was compound-text-with-extensions in 22.x (pre-unicode). |
| 62 | :version "23.1" |
| 63 | :set (lambda (symbol value) |
| 64 | (set-selection-coding-system value) |
| 65 | (set symbol value))) |
| 66 | |
| 67 | (defvar next-selection-coding-system nil |
| 68 | "Coding system for the next communication with other programs. |
| 69 | Usually, `selection-coding-system' is used for communicating with |
| 70 | other programs (X Windows clients or MS Windows programs). But, if this |
| 71 | variable is set, it is used for the next communication only. |
| 72 | After the communication, this variable is set to nil.") |
| 73 | |
| 74 | (declare-function x-get-selection-internal "xselect.c" |
| 75 | (selection-symbol target-type &optional time-stamp terminal)) |
| 76 | |
| 77 | ;; Only declared obsolete in 23.3. |
| 78 | (define-obsolete-function-alias 'x-selection 'x-get-selection "at least 19.34") |
| 79 | |
| 80 | (defun x-get-selection (&optional type data-type) |
| 81 | "Return the value of an X Windows selection. |
| 82 | The argument TYPE (default `PRIMARY') says which selection, |
| 83 | and the argument DATA-TYPE (default `STRING') says |
| 84 | how to convert the data. |
| 85 | |
| 86 | TYPE may be any symbol \(but nil stands for `PRIMARY'). However, |
| 87 | only a few symbols are commonly used. They conventionally have |
| 88 | all upper-case names. The most often used ones, in addition to |
| 89 | `PRIMARY', are `SECONDARY' and `CLIPBOARD'. |
| 90 | |
| 91 | DATA-TYPE is usually `STRING', but can also be one of the symbols |
| 92 | in `selection-converter-alist', which see. This argument is |
| 93 | ignored on MS-Windows and MS-DOS." |
| 94 | (let ((data (x-get-selection-internal (or type 'PRIMARY) |
| 95 | (or data-type 'STRING))) |
| 96 | coding) |
| 97 | (when (and (stringp data) |
| 98 | (setq data-type (get-text-property 0 'foreign-selection data))) |
| 99 | (setq coding (or next-selection-coding-system |
| 100 | selection-coding-system |
| 101 | (cond ((eq data-type 'UTF8_STRING) |
| 102 | 'utf-8) |
| 103 | ((eq data-type 'COMPOUND_TEXT) |
| 104 | 'compound-text-with-extensions) |
| 105 | ((eq data-type 'C_STRING) |
| 106 | nil) |
| 107 | ((eq data-type 'STRING) |
| 108 | 'iso-8859-1) |
| 109 | (t |
| 110 | (error "Unknown selection data type: %S" type)))) |
| 111 | data (if coding (decode-coding-string data coding) |
| 112 | (string-to-multibyte data))) |
| 113 | (setq next-selection-coding-system nil) |
| 114 | (put-text-property 0 (length data) 'foreign-selection data-type data)) |
| 115 | data)) |
| 116 | |
| 117 | (defun x-get-clipboard () |
| 118 | "Return text pasted to the clipboard." |
| 119 | (x-get-selection-internal 'CLIPBOARD 'STRING)) |
| 120 | |
| 121 | (declare-function x-own-selection-internal "xselect.c" |
| 122 | (selection-name selection-value &optional frame)) |
| 123 | (declare-function x-disown-selection-internal "xselect.c" |
| 124 | (selection &optional time terminal)) |
| 125 | |
| 126 | (defun x-set-selection (type data) |
| 127 | "Make an X selection of type TYPE and value DATA. |
| 128 | The argument TYPE (nil means `PRIMARY') says which selection, and |
| 129 | DATA specifies the contents. TYPE must be a symbol. \(It can also |
| 130 | be a string, which stands for the symbol with that name, but this |
| 131 | is considered obsolete.) DATA may be a string, a symbol, an |
| 132 | integer (or a cons of two integers or list of two integers). |
| 133 | |
| 134 | The selection may also be a cons of two markers pointing to the same buffer, |
| 135 | or an overlay. In these cases, the selection is considered to be the text |
| 136 | between the markers *at whatever time the selection is examined*. |
| 137 | Thus, editing done in the buffer after you specify the selection |
| 138 | can alter the effective value of the selection. |
| 139 | |
| 140 | The data may also be a vector of valid non-vector selection values. |
| 141 | |
| 142 | The return value is DATA. |
| 143 | |
| 144 | Interactively, this command sets the primary selection. Without |
| 145 | prefix argument, it reads the selection in the minibuffer. With |
| 146 | prefix argument, it uses the text of the region as the selection value. |
| 147 | |
| 148 | Note that on MS-Windows, primary and secondary selections set by Emacs |
| 149 | are not available to other programs." |
| 150 | (interactive (if (not current-prefix-arg) |
| 151 | (list 'PRIMARY (read-string "Set text for pasting: ")) |
| 152 | (list 'PRIMARY (buffer-substring (region-beginning) (region-end))))) |
| 153 | (if (stringp type) (setq type (intern type))) |
| 154 | (or (x-valid-simple-selection-p data) |
| 155 | (and (vectorp data) |
| 156 | (let ((valid t) |
| 157 | (i (1- (length data)))) |
| 158 | (while (>= i 0) |
| 159 | (or (x-valid-simple-selection-p (aref data i)) |
| 160 | (setq valid nil)) |
| 161 | (setq i (1- i))) |
| 162 | valid)) |
| 163 | (signal 'error (list "invalid selection" data))) |
| 164 | (or type (setq type 'PRIMARY)) |
| 165 | (if data |
| 166 | (x-own-selection-internal type data) |
| 167 | (x-disown-selection-internal type)) |
| 168 | data) |
| 169 | |
| 170 | (defun x-valid-simple-selection-p (data) |
| 171 | (or (bufferp data) |
| 172 | (and (consp data) |
| 173 | (markerp (car data)) |
| 174 | (markerp (cdr data)) |
| 175 | (marker-buffer (car data)) |
| 176 | (buffer-name (marker-buffer (car data))) |
| 177 | (eq (marker-buffer (car data)) |
| 178 | (marker-buffer (cdr data)))) |
| 179 | (stringp data) |
| 180 | (and (overlayp data) |
| 181 | (overlay-buffer data) |
| 182 | (buffer-name (overlay-buffer data))) |
| 183 | (symbolp data) |
| 184 | (integerp data))) |
| 185 | \f |
| 186 | ;; Functions to convert the selection into various other selection types. |
| 187 | ;; Every selection type that Emacs handles is implemented this way, except |
| 188 | ;; for TIMESTAMP, which is a special case. |
| 189 | |
| 190 | (defun xselect--selection-bounds (value) |
| 191 | "Return bounds of X selection value VALUE. |
| 192 | The return value is a list (BEG END BUF) if VALUE is a cons of |
| 193 | two markers or an overlay. Otherwise, it is nil." |
| 194 | (cond ((bufferp value) |
| 195 | (with-current-buffer value |
| 196 | (when (mark t) |
| 197 | (list (mark t) (point) value)))) |
| 198 | ((and (consp value) |
| 199 | (markerp (car value)) |
| 200 | (markerp (cdr value))) |
| 201 | (when (and (marker-buffer (car value)) |
| 202 | (buffer-name (marker-buffer (car value))) |
| 203 | (eq (marker-buffer (car value)) |
| 204 | (marker-buffer (cdr value)))) |
| 205 | (list (marker-position (car value)) |
| 206 | (marker-position (cdr value)) |
| 207 | (marker-buffer (car value))))) |
| 208 | ((overlayp value) |
| 209 | (when (overlay-buffer value) |
| 210 | (list (overlay-start value) |
| 211 | (overlay-end value) |
| 212 | (overlay-buffer value)))))) |
| 213 | |
| 214 | (defun xselect--int-to-cons (n) |
| 215 | (cons (ash n -16) (logand n 65535))) |
| 216 | |
| 217 | (defun xselect--encode-string (type str &optional can-modify) |
| 218 | (when str |
| 219 | ;; If TYPE is nil, this is a local request; return STR as-is. |
| 220 | (if (null type) |
| 221 | str |
| 222 | ;; Otherwise, encode STR. |
| 223 | (let ((coding (or next-selection-coding-system |
| 224 | selection-coding-system))) |
| 225 | (if coding |
| 226 | (setq coding (coding-system-base coding))) |
| 227 | (let ((inhibit-read-only t)) |
| 228 | ;; Suppress producing escape sequences for compositions. |
| 229 | ;; But avoid modifying the string if it's a buffer name etc. |
| 230 | (unless can-modify (setq str (substring str 0))) |
| 231 | (remove-text-properties 0 (length str) '(composition nil) str) |
| 232 | ;; For X selections, TEXT is a polymorphic target; choose |
| 233 | ;; the actual type from `UTF8_STRING', `COMPOUND_TEXT', |
| 234 | ;; `STRING', and `C_STRING'. On Nextstep, always use UTF-8 |
| 235 | ;; (see ns_string_to_pasteboard_internal in nsselect.m). |
| 236 | (when (eq type 'TEXT) |
| 237 | (cond |
| 238 | ((featurep 'ns) |
| 239 | (setq type 'UTF8_STRING)) |
| 240 | ((not (multibyte-string-p str)) |
| 241 | (setq type 'C_STRING)) |
| 242 | (t |
| 243 | (let (non-latin-1 non-unicode eight-bit) |
| 244 | (mapc #'(lambda (x) |
| 245 | (if (>= x #x100) |
| 246 | (if (< x #x110000) |
| 247 | (setq non-latin-1 t) |
| 248 | (if (< x #x3FFF80) |
| 249 | (setq non-unicode t) |
| 250 | (setq eight-bit t))))) |
| 251 | str) |
| 252 | (setq type (if (or non-unicode |
| 253 | (and |
| 254 | non-latin-1 |
| 255 | ;; If a coding is specified for |
| 256 | ;; selection, and that is |
| 257 | ;; compatible with COMPOUND_TEXT, |
| 258 | ;; use it. |
| 259 | coding |
| 260 | (eq (coding-system-get coding :mime-charset) |
| 261 | 'x-ctext))) |
| 262 | 'COMPOUND_TEXT |
| 263 | (if non-latin-1 'UTF8_STRING |
| 264 | (if eight-bit 'C_STRING |
| 265 | 'STRING)))))))) |
| 266 | (cond |
| 267 | ((eq type 'UTF8_STRING) |
| 268 | (if (or (not coding) |
| 269 | (not (eq (coding-system-type coding) 'utf-8))) |
| 270 | (setq coding 'utf-8)) |
| 271 | (setq str (encode-coding-string str coding))) |
| 272 | |
| 273 | ((eq type 'STRING) |
| 274 | (if (or (not coding) |
| 275 | (not (eq (coding-system-type coding) 'charset))) |
| 276 | (setq coding 'iso-8859-1)) |
| 277 | (setq str (encode-coding-string str coding))) |
| 278 | |
| 279 | ((eq type 'COMPOUND_TEXT) |
| 280 | (if (or (not coding) |
| 281 | (not (eq (coding-system-type coding) 'iso-2022))) |
| 282 | (setq coding 'compound-text-with-extensions)) |
| 283 | (setq str (encode-coding-string str coding))) |
| 284 | |
| 285 | ((eq type 'C_STRING) |
| 286 | (setq str (string-make-unibyte str))) |
| 287 | |
| 288 | (t |
| 289 | (error "Unknown selection type: %S" type))))) |
| 290 | |
| 291 | (setq next-selection-coding-system nil) |
| 292 | (cons type str)))) |
| 293 | |
| 294 | (defun xselect-convert-to-string (_selection type value) |
| 295 | (let ((str (cond ((stringp value) value) |
| 296 | ((setq value (xselect--selection-bounds value)) |
| 297 | (with-current-buffer (nth 2 value) |
| 298 | (buffer-substring (nth 0 value) |
| 299 | (nth 1 value))))))) |
| 300 | (xselect--encode-string type str t))) |
| 301 | |
| 302 | (defun xselect-convert-to-length (_selection _type value) |
| 303 | (let ((len (cond ((stringp value) |
| 304 | (length value)) |
| 305 | ((setq value (xselect--selection-bounds value)) |
| 306 | (abs (- (nth 0 value) (nth 1 value))))))) |
| 307 | (if len |
| 308 | (xselect--int-to-cons len)))) |
| 309 | |
| 310 | (defun xselect-convert-to-targets (_selection _type _value) |
| 311 | ;; return a vector of atoms, but remove duplicates first. |
| 312 | (let* ((all (cons 'TIMESTAMP |
| 313 | (cons 'MULTIPLE |
| 314 | (mapcar 'car selection-converter-alist)))) |
| 315 | (rest all)) |
| 316 | (while rest |
| 317 | (cond ((memq (car rest) (cdr rest)) |
| 318 | (setcdr rest (delq (car rest) (cdr rest)))) |
| 319 | ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret |
| 320 | (setcdr rest (cdr (cdr rest)))) |
| 321 | (t |
| 322 | (setq rest (cdr rest))))) |
| 323 | (apply 'vector all))) |
| 324 | |
| 325 | (defun xselect-convert-to-delete (selection _type _value) |
| 326 | (x-disown-selection-internal selection) |
| 327 | ;; A return value of nil means that we do not know how to do this conversion, |
| 328 | ;; and replies with an "error". A return value of NULL means that we have |
| 329 | ;; done the conversion (and any side-effects) but have no value to return. |
| 330 | 'NULL) |
| 331 | |
| 332 | (defun xselect-convert-to-filename (_selection _type value) |
| 333 | (when (setq value (xselect--selection-bounds value)) |
| 334 | (xselect--encode-string 'TEXT (buffer-file-name (nth 2 value))))) |
| 335 | |
| 336 | (defun xselect-convert-to-charpos (_selection _type value) |
| 337 | (when (setq value (xselect--selection-bounds value)) |
| 338 | (let ((beg (1- (nth 0 value))) ; zero-based |
| 339 | (end (1- (nth 1 value)))) |
| 340 | (cons 'SPAN (vector (xselect--int-to-cons (min beg end)) |
| 341 | (xselect--int-to-cons (max beg end))))))) |
| 342 | |
| 343 | (defun xselect-convert-to-lineno (_selection _type value) |
| 344 | (when (setq value (xselect--selection-bounds value)) |
| 345 | (with-current-buffer (nth 2 value) |
| 346 | (let ((beg (line-number-at-pos (nth 0 value))) |
| 347 | (end (line-number-at-pos (nth 1 value)))) |
| 348 | (cons 'SPAN (vector (xselect--int-to-cons (min beg end)) |
| 349 | (xselect--int-to-cons (max beg end)))))))) |
| 350 | |
| 351 | (defun xselect-convert-to-colno (_selection _type value) |
| 352 | (when (setq value (xselect--selection-bounds value)) |
| 353 | (with-current-buffer (nth 2 value) |
| 354 | (let ((beg (progn (goto-char (nth 0 value)) (current-column))) |
| 355 | (end (progn (goto-char (nth 1 value)) (current-column)))) |
| 356 | (cons 'SPAN (vector (xselect--int-to-cons (min beg end)) |
| 357 | (xselect--int-to-cons (max beg end)))))))) |
| 358 | |
| 359 | (defun xselect-convert-to-os (_selection _type _size) |
| 360 | (xselect--encode-string 'TEXT (symbol-name system-type))) |
| 361 | |
| 362 | (defun xselect-convert-to-host (_selection _type _size) |
| 363 | (xselect--encode-string 'TEXT (system-name))) |
| 364 | |
| 365 | (defun xselect-convert-to-user (_selection _type _size) |
| 366 | (xselect--encode-string 'TEXT (user-full-name))) |
| 367 | |
| 368 | (defun xselect-convert-to-class (_selection _type _size) |
| 369 | "Convert selection to class. |
| 370 | This function returns the string \"Emacs\"." |
| 371 | "Emacs") |
| 372 | |
| 373 | ;; We do not try to determine the name Emacs was invoked with, |
| 374 | ;; because it is not clean for a program's behavior to depend on that. |
| 375 | (defun xselect-convert-to-name (_selection _type _size) |
| 376 | "Convert selection to name. |
| 377 | This function returns the string \"emacs\"." |
| 378 | "emacs") |
| 379 | |
| 380 | (defun xselect-convert-to-integer (_selection _type value) |
| 381 | (and (integerp value) |
| 382 | (xselect--int-to-cons value))) |
| 383 | |
| 384 | (defun xselect-convert-to-atom (_selection _type value) |
| 385 | (and (symbolp value) value)) |
| 386 | |
| 387 | (defun xselect-convert-to-identity (_selection _type value) ; used internally |
| 388 | (vector value)) |
| 389 | |
| 390 | ;; Null target that tells clipboard managers we support SAVE_TARGETS |
| 391 | ;; (see freedesktop.org Clipboard Manager spec). |
| 392 | (defun xselect-convert-to-save-targets (selection _type _value) |
| 393 | (when (eq selection 'CLIPBOARD) |
| 394 | 'NULL)) |
| 395 | |
| 396 | (setq selection-converter-alist |
| 397 | '((TEXT . xselect-convert-to-string) |
| 398 | (COMPOUND_TEXT . xselect-convert-to-string) |
| 399 | (STRING . xselect-convert-to-string) |
| 400 | (UTF8_STRING . xselect-convert-to-string) |
| 401 | (TARGETS . xselect-convert-to-targets) |
| 402 | (LENGTH . xselect-convert-to-length) |
| 403 | (DELETE . xselect-convert-to-delete) |
| 404 | (FILE_NAME . xselect-convert-to-filename) |
| 405 | (CHARACTER_POSITION . xselect-convert-to-charpos) |
| 406 | (LINE_NUMBER . xselect-convert-to-lineno) |
| 407 | (COLUMN_NUMBER . xselect-convert-to-colno) |
| 408 | (OWNER_OS . xselect-convert-to-os) |
| 409 | (HOST_NAME . xselect-convert-to-host) |
| 410 | (USER . xselect-convert-to-user) |
| 411 | (CLASS . xselect-convert-to-class) |
| 412 | (NAME . xselect-convert-to-name) |
| 413 | (ATOM . xselect-convert-to-atom) |
| 414 | (INTEGER . xselect-convert-to-integer) |
| 415 | (SAVE_TARGETS . xselect-convert-to-save-targets) |
| 416 | (_EMACS_INTERNAL . xselect-convert-to-identity))) |
| 417 | |
| 418 | (provide 'select) |
| 419 | |
| 420 | ;;; select.el ends here |