| 1 | ;;; select.el --- lisp portion of standard selection support |
| 2 | |
| 3 | ;; Maintainer: FSF |
| 4 | ;; Keywords: internal |
| 5 | |
| 6 | ;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004, |
| 7 | ;; 2005, 2006, 2007 Free Software Foundation, Inc. |
| 8 | ;; Based partially on earlier release by Lucid. |
| 9 | |
| 10 | ;; This file is part of GNU Emacs. |
| 11 | |
| 12 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 13 | ;; it under the terms of the GNU General Public License as published by |
| 14 | ;; the Free Software Foundation; either version 3, or (at your option) |
| 15 | ;; any later version. |
| 16 | |
| 17 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 18 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 19 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 20 | ;; GNU General Public License for more details. |
| 21 | |
| 22 | ;; You should have received a copy of the GNU General Public License |
| 23 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 24 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 25 | ;; Boston, MA 02110-1301, USA. |
| 26 | |
| 27 | ;;; Commentary: |
| 28 | |
| 29 | ;;; Code: |
| 30 | |
| 31 | ;; This is for temporary compatibility with pre-release Emacs 19. |
| 32 | (defalias 'x-selection 'x-get-selection) |
| 33 | (defun x-get-selection (&optional type data-type) |
| 34 | "Return the value of an X Windows selection. |
| 35 | The argument TYPE (default `PRIMARY') says which selection, |
| 36 | and the argument DATA-TYPE (default `STRING') says |
| 37 | how to convert the data. |
| 38 | |
| 39 | TYPE may be any symbol \(but nil stands for `PRIMARY'). However, |
| 40 | only a few symbols are commonly used. They conventionally have |
| 41 | all upper-case names. The most often used ones, in addition to |
| 42 | `PRIMARY', are `SECONDARY' and `CLIPBOARD'. |
| 43 | |
| 44 | DATA-TYPE is usually `STRING', but can also be one of the symbols |
| 45 | in `selection-converter-alist', which see." |
| 46 | (let ((data (x-get-selection-internal (or type 'PRIMARY) |
| 47 | (or data-type 'STRING))) |
| 48 | coding) |
| 49 | (when (and (stringp data) |
| 50 | (setq data-type (get-text-property 0 'foreign-selection data))) |
| 51 | (setq coding (if (eq data-type 'UTF8_STRING) |
| 52 | 'utf-8 |
| 53 | (or next-selection-coding-system |
| 54 | selection-coding-system)) |
| 55 | data (decode-coding-string data coding)) |
| 56 | (put-text-property 0 (length data) 'foreign-selection data-type data)) |
| 57 | data)) |
| 58 | |
| 59 | (defun x-get-clipboard () |
| 60 | "Return text pasted to the clipboard." |
| 61 | (x-get-selection-internal 'CLIPBOARD 'STRING)) |
| 62 | |
| 63 | (defun x-set-selection (type data) |
| 64 | "Make an X Windows selection of type TYPE and value DATA. |
| 65 | The argument TYPE (nil means `PRIMARY') says which selection, and |
| 66 | DATA specifies the contents. TYPE must be a symbol. \(It can also |
| 67 | be a string, which stands for the symbol with that name, but this |
| 68 | is considered obsolete.) DATA may be a string, a symbol, an |
| 69 | integer (or a cons of two integers or list of two integers). |
| 70 | |
| 71 | The selection may also be a cons of two markers pointing to the same buffer, |
| 72 | or an overlay. In these cases, the selection is considered to be the text |
| 73 | between the markers *at whatever time the selection is examined*. |
| 74 | Thus, editing done in the buffer after you specify the selection |
| 75 | can alter the effective value of the selection. |
| 76 | |
| 77 | The data may also be a vector of valid non-vector selection values. |
| 78 | |
| 79 | The return value is DATA. |
| 80 | |
| 81 | Interactively, this command sets the primary selection. Without |
| 82 | prefix argument, it reads the selection in the minibuffer. With |
| 83 | prefix argument, it uses the text of the region as the selection value ." |
| 84 | (interactive (if (not current-prefix-arg) |
| 85 | (list 'PRIMARY (read-string "Set text for pasting: ")) |
| 86 | (list 'PRIMARY (buffer-substring (region-beginning) (region-end))))) |
| 87 | ;; This is for temporary compatibility with pre-release Emacs 19. |
| 88 | (if (stringp type) |
| 89 | (setq type (intern type))) |
| 90 | (or (x-valid-simple-selection-p data) |
| 91 | (and (vectorp data) |
| 92 | (let ((valid t) |
| 93 | (i (1- (length data)))) |
| 94 | (while (>= i 0) |
| 95 | (or (x-valid-simple-selection-p (aref data i)) |
| 96 | (setq valid nil)) |
| 97 | (setq i (1- i))) |
| 98 | valid)) |
| 99 | (signal 'error (list "invalid selection" data))) |
| 100 | (or type (setq type 'PRIMARY)) |
| 101 | (if data |
| 102 | (x-own-selection-internal type data) |
| 103 | (x-disown-selection-internal type)) |
| 104 | data) |
| 105 | |
| 106 | (defun x-valid-simple-selection-p (data) |
| 107 | (or (stringp data) |
| 108 | (symbolp data) |
| 109 | (integerp data) |
| 110 | (and (consp data) |
| 111 | (integerp (car data)) |
| 112 | (or (integerp (cdr data)) |
| 113 | (and (consp (cdr data)) |
| 114 | (integerp (car (cdr data)))))) |
| 115 | (overlayp data) |
| 116 | (and (consp data) |
| 117 | (markerp (car data)) |
| 118 | (markerp (cdr data)) |
| 119 | (marker-buffer (car data)) |
| 120 | (marker-buffer (cdr data)) |
| 121 | (eq (marker-buffer (car data)) |
| 122 | (marker-buffer (cdr data))) |
| 123 | (buffer-name (marker-buffer (car data))) |
| 124 | (buffer-name (marker-buffer (cdr data)))))) |
| 125 | \f |
| 126 | ;;; Cut Buffer support |
| 127 | |
| 128 | (defun x-get-cut-buffer (&optional which-one) |
| 129 | "Returns the value of one of the 8 X server cut-buffers. |
| 130 | Optional arg WHICH-ONE should be a number from 0 to 7, defaulting to 0. |
| 131 | Cut buffers are considered obsolete; you should use selections instead." |
| 132 | (x-get-cut-buffer-internal |
| 133 | (if which-one |
| 134 | (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3 |
| 135 | CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7] |
| 136 | which-one) |
| 137 | 'CUT_BUFFER0))) |
| 138 | |
| 139 | (defun x-set-cut-buffer (string &optional push) |
| 140 | "Store STRING into the X server's primary cut buffer. |
| 141 | If PUSH is non-nil, also rotate the cut buffers: |
| 142 | this means the previous value of the primary cut buffer moves to the second |
| 143 | cut buffer, and the second to the third, and so on (there are 8 buffers.) |
| 144 | Cut buffers are considered obsolete; you should use selections instead." |
| 145 | (or (stringp string) (signal 'wrong-type-argument (list 'string string))) |
| 146 | (if push |
| 147 | (x-rotate-cut-buffers-internal 1)) |
| 148 | (x-store-cut-buffer-internal 'CUT_BUFFER0 string)) |
| 149 | |
| 150 | \f |
| 151 | ;;; Functions to convert the selection into various other selection types. |
| 152 | ;;; Every selection type that Emacs handles is implemented this way, except |
| 153 | ;;; for TIMESTAMP, which is a special case. |
| 154 | |
| 155 | (eval-when-compile (require 'ccl)) |
| 156 | |
| 157 | (define-ccl-program ccl-check-utf-8 |
| 158 | '(0 |
| 159 | ((r0 = 1) |
| 160 | (loop |
| 161 | (read-if (r1 < #x80) (repeat) |
| 162 | ((r0 = 0) |
| 163 | (if (r1 < #xC2) (end)) |
| 164 | (read r2) |
| 165 | (if ((r2 & #xC0) != #x80) (end)) |
| 166 | (if (r1 < #xE0) ((r0 = 1) (repeat))) |
| 167 | (read r2) |
| 168 | (if ((r2 & #xC0) != #x80) (end)) |
| 169 | (if (r1 < #xF0) ((r0 = 1) (repeat))) |
| 170 | (read r2) |
| 171 | (if ((r2 & #xC0) != #x80) (end)) |
| 172 | (if (r1 < #xF8) ((r0 = 1) (repeat))) |
| 173 | (read r2) |
| 174 | (if ((r2 & #xC0) != #x80) (end)) |
| 175 | (if (r1 == #xF8) ((r0 = 1) (repeat))) |
| 176 | (end)))))) |
| 177 | "Check if the input unibyte string is a valid UTF-8 sequence or not. |
| 178 | If it is valid, set the register `r0' to 1, else set it to 0.") |
| 179 | |
| 180 | (defun string-utf-8-p (string) |
| 181 | "Return non-nil if STRING is a unibyte string of valid UTF-8 sequence." |
| 182 | (if (or (not (stringp string)) |
| 183 | (multibyte-string-p string)) |
| 184 | (error "Not a unibyte string: %s" string)) |
| 185 | (let ((status (make-vector 9 0))) |
| 186 | (ccl-execute-on-string ccl-check-utf-8 status string) |
| 187 | (= (aref status 0) 1))) |
| 188 | |
| 189 | |
| 190 | (defun xselect-convert-to-string (selection type value) |
| 191 | (let (str coding) |
| 192 | ;; Get the actual string from VALUE. |
| 193 | (cond ((stringp value) |
| 194 | (setq str value)) |
| 195 | |
| 196 | ((overlayp value) |
| 197 | (save-excursion |
| 198 | (or (buffer-name (overlay-buffer value)) |
| 199 | (error "selection is in a killed buffer")) |
| 200 | (set-buffer (overlay-buffer value)) |
| 201 | (setq str (buffer-substring (overlay-start value) |
| 202 | (overlay-end value))))) |
| 203 | ((and (consp value) |
| 204 | (markerp (car value)) |
| 205 | (markerp (cdr value))) |
| 206 | (or (eq (marker-buffer (car value)) (marker-buffer (cdr value))) |
| 207 | (signal 'error |
| 208 | (list "markers must be in the same buffer" |
| 209 | (car value) (cdr value)))) |
| 210 | (save-excursion |
| 211 | (set-buffer (or (marker-buffer (car value)) |
| 212 | (error "selection is in a killed buffer"))) |
| 213 | (setq str (buffer-substring (car value) (cdr value)))))) |
| 214 | |
| 215 | (when str |
| 216 | ;; If TYPE is nil, this is a local request, thus return STR as |
| 217 | ;; is. Otherwise, encode STR. |
| 218 | (if (not type) |
| 219 | str |
| 220 | (setq coding (or next-selection-coding-system selection-coding-system)) |
| 221 | (if coding |
| 222 | (setq coding (coding-system-base coding)) |
| 223 | (setq coding 'raw-text)) |
| 224 | (let ((inhibit-read-only t)) |
| 225 | ;; Suppress producing escape sequences for compositions. |
| 226 | (remove-text-properties 0 (length str) '(composition nil) str) |
| 227 | (cond |
| 228 | ((eq type 'TEXT) |
| 229 | (if (not (multibyte-string-p str)) |
| 230 | ;; Don't have to encode unibyte string. |
| 231 | (setq type 'STRING) |
| 232 | ;; If STR contains only ASCII, Latin-1, and raw bytes, |
| 233 | ;; encode STR by iso-latin-1, and return it as type |
| 234 | ;; `STRING'. Otherwise, encode STR by CODING. In that |
| 235 | ;; case, the returing type depends on CODING. |
| 236 | (let ((charsets (find-charset-string str))) |
| 237 | (setq charsets |
| 238 | (delq 'ascii |
| 239 | (delq 'latin-iso8859-1 |
| 240 | (delq 'eight-bit-control |
| 241 | (delq 'eight-bit-graphic charsets))))) |
| 242 | (if charsets |
| 243 | (setq str (encode-coding-string str coding) |
| 244 | type (if (memq coding '(compound-text |
| 245 | compound-text-with-extensions)) |
| 246 | 'COMPOUND_TEXT |
| 247 | 'STRING)) |
| 248 | (setq type 'STRING |
| 249 | str (encode-coding-string str 'iso-latin-1)))))) |
| 250 | |
| 251 | ((eq type 'COMPOUND_TEXT) |
| 252 | (setq str (encode-coding-string str coding))) |
| 253 | |
| 254 | ((eq type 'STRING) |
| 255 | (if (memq coding '(compound-text |
| 256 | compound-text-with-extensions)) |
| 257 | (setq str (string-make-unibyte str)) |
| 258 | (setq str (encode-coding-string str coding)))) |
| 259 | |
| 260 | ((eq type 'UTF8_STRING) |
| 261 | (if (multibyte-string-p str) |
| 262 | (setq str (encode-coding-string str 'utf-8))) |
| 263 | (if (not (string-utf-8-p str)) |
| 264 | (setq str nil))) ;; Decline request as we don't have UTF-8 data. |
| 265 | (t |
| 266 | (error "Unknow selection type: %S" type)) |
| 267 | ))) |
| 268 | |
| 269 | (setq next-selection-coding-system nil) |
| 270 | (cons type str)))) |
| 271 | |
| 272 | |
| 273 | (defun xselect-convert-to-length (selection type value) |
| 274 | (let ((value |
| 275 | (cond ((stringp value) |
| 276 | (length value)) |
| 277 | ((overlayp value) |
| 278 | (abs (- (overlay-end value) (overlay-start value)))) |
| 279 | ((and (consp value) |
| 280 | (markerp (car value)) |
| 281 | (markerp (cdr value))) |
| 282 | (or (eq (marker-buffer (car value)) |
| 283 | (marker-buffer (cdr value))) |
| 284 | (signal 'error |
| 285 | (list "markers must be in the same buffer" |
| 286 | (car value) (cdr value)))) |
| 287 | (abs (- (car value) (cdr value))))))) |
| 288 | (if value ; force it to be in 32-bit format. |
| 289 | (cons (ash value -16) (logand value 65535)) |
| 290 | nil))) |
| 291 | |
| 292 | (defun xselect-convert-to-targets (selection type value) |
| 293 | ;; return a vector of atoms, but remove duplicates first. |
| 294 | (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist))) |
| 295 | (rest all)) |
| 296 | (while rest |
| 297 | (cond ((memq (car rest) (cdr rest)) |
| 298 | (setcdr rest (delq (car rest) (cdr rest)))) |
| 299 | ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret |
| 300 | (setcdr rest (cdr (cdr rest)))) |
| 301 | (t |
| 302 | (setq rest (cdr rest))))) |
| 303 | (apply 'vector all))) |
| 304 | |
| 305 | (defun xselect-convert-to-delete (selection type value) |
| 306 | (x-disown-selection-internal selection) |
| 307 | ;; A return value of nil means that we do not know how to do this conversion, |
| 308 | ;; and replies with an "error". A return value of NULL means that we have |
| 309 | ;; done the conversion (and any side-effects) but have no value to return. |
| 310 | 'NULL) |
| 311 | |
| 312 | (defun xselect-convert-to-filename (selection type value) |
| 313 | (cond ((overlayp value) |
| 314 | (buffer-file-name (or (overlay-buffer value) |
| 315 | (error "selection is in a killed buffer")))) |
| 316 | ((and (consp value) |
| 317 | (markerp (car value)) |
| 318 | (markerp (cdr value))) |
| 319 | (buffer-file-name (or (marker-buffer (car value)) |
| 320 | (error "selection is in a killed buffer")))) |
| 321 | (t nil))) |
| 322 | |
| 323 | (defun xselect-convert-to-charpos (selection type value) |
| 324 | (let (a b tmp) |
| 325 | (cond ((cond ((overlayp value) |
| 326 | (setq a (overlay-start value) |
| 327 | b (overlay-end value))) |
| 328 | ((and (consp value) |
| 329 | (markerp (car value)) |
| 330 | (markerp (cdr value))) |
| 331 | (setq a (car value) |
| 332 | b (cdr value)))) |
| 333 | (setq a (1- a) b (1- b)) ; zero-based |
| 334 | (if (< b a) (setq tmp a a b b tmp)) |
| 335 | (cons 'SPAN |
| 336 | (vector (cons (ash a -16) (logand a 65535)) |
| 337 | (cons (ash b -16) (logand b 65535)))))))) |
| 338 | |
| 339 | (defun xselect-convert-to-lineno (selection type value) |
| 340 | (let (a b buf tmp) |
| 341 | (cond ((cond ((and (consp value) |
| 342 | (markerp (car value)) |
| 343 | (markerp (cdr value))) |
| 344 | (setq a (marker-position (car value)) |
| 345 | b (marker-position (cdr value)) |
| 346 | buf (marker-buffer (car value)))) |
| 347 | ((overlayp value) |
| 348 | (setq buf (overlay-buffer value) |
| 349 | a (overlay-start value) |
| 350 | b (overlay-end value))) |
| 351 | ) |
| 352 | (save-excursion |
| 353 | (set-buffer buf) |
| 354 | (setq a (count-lines 1 a) |
| 355 | b (count-lines 1 b))) |
| 356 | (if (< b a) (setq tmp a a b b tmp)) |
| 357 | (cons 'SPAN |
| 358 | (vector (cons (ash a -16) (logand a 65535)) |
| 359 | (cons (ash b -16) (logand b 65535)))))))) |
| 360 | |
| 361 | (defun xselect-convert-to-colno (selection type value) |
| 362 | (let (a b buf tmp) |
| 363 | (cond ((cond ((and (consp value) |
| 364 | (markerp (car value)) |
| 365 | (markerp (cdr value))) |
| 366 | (setq a (car value) |
| 367 | b (cdr value) |
| 368 | buf (marker-buffer a))) |
| 369 | ((overlayp value) |
| 370 | (setq buf (overlay-buffer value) |
| 371 | a (overlay-start value) |
| 372 | b (overlay-end value))) |
| 373 | ) |
| 374 | (save-excursion |
| 375 | (set-buffer buf) |
| 376 | (goto-char a) |
| 377 | (setq a (current-column)) |
| 378 | (goto-char b) |
| 379 | (setq b (current-column))) |
| 380 | (if (< b a) (setq tmp a a b b tmp)) |
| 381 | (cons 'SPAN |
| 382 | (vector (cons (ash a -16) (logand a 65535)) |
| 383 | (cons (ash b -16) (logand b 65535)))))))) |
| 384 | |
| 385 | (defun xselect-convert-to-os (selection type size) |
| 386 | (symbol-name system-type)) |
| 387 | |
| 388 | (defun xselect-convert-to-host (selection type size) |
| 389 | (system-name)) |
| 390 | |
| 391 | (defun xselect-convert-to-user (selection type size) |
| 392 | (user-full-name)) |
| 393 | |
| 394 | (defun xselect-convert-to-class (selection type size) |
| 395 | "Convert selection to class. |
| 396 | This function returns the string \"Emacs\"." |
| 397 | "Emacs") |
| 398 | |
| 399 | ;; We do not try to determine the name Emacs was invoked with, |
| 400 | ;; because it is not clean for a program's behavior to depend on that. |
| 401 | (defun xselect-convert-to-name (selection type size) |
| 402 | "Convert selection to name. |
| 403 | This function returns the string \"emacs\"." |
| 404 | "emacs") |
| 405 | |
| 406 | (defun xselect-convert-to-integer (selection type value) |
| 407 | (and (integerp value) |
| 408 | (cons (ash value -16) (logand value 65535)))) |
| 409 | |
| 410 | (defun xselect-convert-to-atom (selection type value) |
| 411 | (and (symbolp value) value)) |
| 412 | |
| 413 | (defun xselect-convert-to-identity (selection type value) ; used internally |
| 414 | (vector value)) |
| 415 | |
| 416 | (setq selection-converter-alist |
| 417 | '((TEXT . xselect-convert-to-string) |
| 418 | (COMPOUND_TEXT . xselect-convert-to-string) |
| 419 | (STRING . xselect-convert-to-string) |
| 420 | (UTF8_STRING . xselect-convert-to-string) |
| 421 | (TARGETS . xselect-convert-to-targets) |
| 422 | (LENGTH . xselect-convert-to-length) |
| 423 | (DELETE . xselect-convert-to-delete) |
| 424 | (FILE_NAME . xselect-convert-to-filename) |
| 425 | (CHARACTER_POSITION . xselect-convert-to-charpos) |
| 426 | (LINE_NUMBER . xselect-convert-to-lineno) |
| 427 | (COLUMN_NUMBER . xselect-convert-to-colno) |
| 428 | (OWNER_OS . xselect-convert-to-os) |
| 429 | (HOST_NAME . xselect-convert-to-host) |
| 430 | (USER . xselect-convert-to-user) |
| 431 | (CLASS . xselect-convert-to-class) |
| 432 | (NAME . xselect-convert-to-name) |
| 433 | (ATOM . xselect-convert-to-atom) |
| 434 | (INTEGER . xselect-convert-to-integer) |
| 435 | (_EMACS_INTERNAL . xselect-convert-to-identity) |
| 436 | )) |
| 437 | |
| 438 | (provide 'select) |
| 439 | |
| 440 | ;;; arch-tag: bb634f97-8a3b-4b0a-b940-f6e09982328c |
| 441 | ;;; select.el ends here |