[bpt/emacs.git] / lisp / select.el

;;; select.el --- lisp portion of standard selection support

;; Maintainer: FSF
;; Keywords: internal

;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
;; Based partially on earlier release by Lucid.

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;; This is for temporary compatibility with pre-release Emacs 19.
(defalias 'x-selection 'x-get-selection)
(defun x-get-selection (&optional type data-type)
  "Return the value of an X Windows selection.
The argument TYPE (default `PRIMARY') says which selection,
and the argument DATA-TYPE (default `STRING') says
how to convert the data.

TYPE may be any symbol \(but nil stands for `PRIMARY').  However,
only a few symbols are commonly used.  They conventionally have
all upper-case names.  The most often used ones, in addition to
`PRIMARY', are `SECONDARY' and `CLIPBOARD'.

DATA-TYPE is usually `STRING', but can also be one of the symbols
in `selection-converter-alist', which see."
  (let ((data (x-get-selection-internal (or type 'PRIMARY)
					(or data-type 'STRING)))
	coding)
    (when (and (stringp data)
	       (setq data-type (get-text-property 0 'foreign-selection data)))
      (setq coding (if (eq data-type 'UTF8_STRING)
		       'utf-8
		     (or next-selection-coding-system
			 selection-coding-system))
	    data (decode-coding-string data coding))
      (put-text-property 0 (length data) 'foreign-selection data-type data))
    data))

(defun x-get-clipboard ()
  "Return text pasted to the clipboard."
  (x-get-selection-internal 'CLIPBOARD 'STRING))

(defun x-set-selection (type data)
  "Make an X Windows selection of type TYPE and value DATA.
The argument TYPE (nil means `PRIMARY') says which selection, and
DATA specifies the contents.  TYPE must be a symbol.  \(It can also
be a string, which stands for the symbol with that name, but this
is considered obsolete.)  DATA may be a string, a symbol, an
integer (or a cons of two integers or list of two integers).

The selection may also be a cons of two markers pointing to the same buffer,
or an overlay.  In these cases, the selection is considered to be the text
between the markers *at whatever time the selection is examined*.
Thus, editing done in the buffer after you specify the selection
can alter the effective value of the selection.

The data may also be a vector of valid non-vector selection values.

The return value is DATA.

Interactively, this command sets the primary selection.  Without
prefix argument, it reads the selection in the minibuffer.  With
prefix argument, it uses the text of the region as the selection value ."
  (interactive (if (not current-prefix-arg)
		   (list 'PRIMARY (read-string "Set text for pasting: "))
		 (list 'PRIMARY (buffer-substring (region-beginning) (region-end)))))
  ;; This is for temporary compatibility with pre-release Emacs 19.
  (if (stringp type)
      (setq type (intern type)))
  (or (x-valid-simple-selection-p data)
      (and (vectorp data)
	   (let ((valid t)
		 (i (1- (length data))))
	     (while (>= i 0)
	       (or (x-valid-simple-selection-p (aref data i))
		   (setq valid nil))
	       (setq i (1- i)))
	     valid))
      (signal 'error (list "invalid selection" data)))
  (or type (setq type 'PRIMARY))
  (if data
      (x-own-selection-internal type data)
    (x-disown-selection-internal type))
  data)

(defun x-valid-simple-selection-p (data)
  (or (stringp data)
      (symbolp data)
      (integerp data)
      (and (consp data)
	   (integerp (car data))
	   (or (integerp (cdr data))
	       (and (consp (cdr data))
		    (integerp (car (cdr data))))))
      (overlayp data)
      (and (consp data)
	   (markerp (car data))
	   (markerp (cdr data))
	   (marker-buffer (car data))
	   (marker-buffer (cdr data))
	   (eq (marker-buffer (car data))
	       (marker-buffer (cdr data)))
	   (buffer-name (marker-buffer (car data)))
	   (buffer-name (marker-buffer (cdr data))))))
\f
;;; Cut Buffer support

(declare-function x-get-cut-buffer-internal "xselect.c")

(defun x-get-cut-buffer (&optional which-one)
  "Returns the value of one of the 8 X server cut-buffers.
Optional arg WHICH-ONE should be a number from 0 to 7, defaulting to 0.
Cut buffers are considered obsolete; you should use selections instead."
  (x-get-cut-buffer-internal
   (if which-one
       (aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3
	      CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7]
	     which-one)
     'CUT_BUFFER0)))

(declare-function x-rotate-cut-buffers-internal "xselect.c")
(declare-function x-store-cut-buffer-internal "xselect.c")

(defun x-set-cut-buffer (string &optional push)
  "Store STRING into the X server's primary cut buffer.
If PUSH is non-nil, also rotate the cut buffers:
this means the previous value of the primary cut buffer moves to the second
cut buffer, and the second to the third, and so on (there are 8 buffers.)
Cut buffers are considered obsolete; you should use selections instead."
  (or (stringp string) (signal 'wrong-type-argument (list 'string string)))
  (if push
      (x-rotate-cut-buffers-internal 1))
  (x-store-cut-buffer-internal 'CUT_BUFFER0 string))

\f
;;; Functions to convert the selection into various other selection types.
;;; Every selection type that Emacs handles is implemented this way, except
;;; for TIMESTAMP, which is a special case.

(eval-when-compile (require 'ccl))

(define-ccl-program ccl-check-utf-8
  '(0
    ((r0 = 1)
     (loop
      (read-if (r1 < #x80) (repeat)
	((r0 = 0)
	 (if (r1 < #xC2) (end))
	 (read r2)
	 (if ((r2 & #xC0) != #x80) (end))
	 (if (r1 < #xE0) ((r0 = 1) (repeat)))
	 (read r2)
	 (if ((r2 & #xC0) != #x80) (end))
	 (if (r1 < #xF0) ((r0 = 1) (repeat)))
	 (read r2)
	 (if ((r2 & #xC0) != #x80) (end))
	 (if (r1 < #xF8) ((r0 = 1) (repeat)))
	 (read r2)
	 (if ((r2 & #xC0) != #x80) (end))
	 (if (r1 == #xF8) ((r0 = 1) (repeat)))
	 (end))))))
  "Check if the input unibyte string is a valid UTF-8 sequence or not.
If it is valid, set the register `r0' to 1, else set it to 0.")

(defun string-utf-8-p (string)
  "Return non-nil if STRING is a unibyte string of valid UTF-8 sequence."
  (if (or (not (stringp string))
	  (multibyte-string-p string))
      (error "Not a unibyte string: %s" string))
  (let ((status (make-vector 9 0)))
    (ccl-execute-on-string ccl-check-utf-8 status string)
    (= (aref status 0) 1)))


(defun xselect-convert-to-string (selection type value)
  (let (str coding)
    ;; Get the actual string from VALUE.
    (cond ((stringp value)
	   (setq str value))

	  ((overlayp value)
	   (save-excursion
	     (or (buffer-name (overlay-buffer value))
		 (error "selection is in a killed buffer"))
	     (set-buffer (overlay-buffer value))
	     (setq str (buffer-substring (overlay-start value)
					 (overlay-end value)))))
	  ((and (consp value)
		(markerp (car value))
		(markerp (cdr value)))
	   (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
	       (signal 'error
		       (list "markers must be in the same buffer"
			     (car value) (cdr value))))
	   (save-excursion
	     (set-buffer (or (marker-buffer (car value))
			     (error "selection is in a killed buffer")))
	     (setq str (buffer-substring (car value) (cdr value))))))

    (when str
      ;; If TYPE is nil, this is a local request, thus return STR as
      ;; is.  Otherwise, encode STR.
      (if (not type)
	  str
	(setq coding (or next-selection-coding-system selection-coding-system))
	(if coding
	    (setq coding (coding-system-base coding))
	  (setq coding 'raw-text))
	(let ((inhibit-read-only t))
	  ;; Suppress producing escape sequences for compositions.
	  (remove-text-properties 0 (length str) '(composition nil) str)
	  (cond
	   ((eq type 'TEXT)
	    (if (not (multibyte-string-p str))
		;; Don't have to encode unibyte string.
		(setq type 'STRING)
	      ;; If STR contains only ASCII, Latin-1, and raw bytes,
	      ;; encode STR by iso-latin-1, and return it as type
	      ;; `STRING'.  Otherwise, encode STR by CODING.  In that
	      ;; case, the returing type depends on CODING.
	      (let ((charsets (find-charset-string str)))
		(setq charsets
		      (delq 'ascii
			    (delq 'latin-iso8859-1
				  (delq 'eight-bit-control
					(delq 'eight-bit-graphic charsets)))))
		(if charsets
		    (setq str (encode-coding-string str coding)
			  type (if (memq coding '(compound-text
						  compound-text-with-extensions))
				   'COMPOUND_TEXT
				 'STRING))
		  (setq type 'STRING
			str (encode-coding-string str 'iso-latin-1))))))

	   ((eq type 'COMPOUND_TEXT)
	    (setq str (encode-coding-string str coding)))

	   ((eq type 'STRING)
	    (if (memq coding '(compound-text
			       compound-text-with-extensions))
		(setq str (string-make-unibyte str))
	      (setq str (encode-coding-string str coding))))

	   ((eq type 'UTF8_STRING)
	    (if (multibyte-string-p str)
		(setq str (encode-coding-string str 'utf-8)))
	    (if (not (string-utf-8-p str))
		(setq str nil))) ;; Decline request as we don't have UTF-8 data.
	   (t
	    (error "Unknow selection type: %S" type))
	   )))

      (setq next-selection-coding-system nil)
      (cons type str))))


(defun xselect-convert-to-length (selection type value)
  (let ((value
	 (cond ((stringp value)
		(length value))
	       ((overlayp value)
		(abs (- (overlay-end value) (overlay-start value))))
	       ((and (consp value)
		     (markerp (car value))
		     (markerp (cdr value)))
		(or (eq (marker-buffer (car value))
			(marker-buffer (cdr value)))
		    (signal 'error
			    (list "markers must be in the same buffer"
				  (car value) (cdr value))))
		(abs (- (car value) (cdr value)))))))
    (if value ; force it to be in 32-bit format.
	(cons (ash value -16) (logand value 65535))
      nil)))

(defun xselect-convert-to-targets (selection type value)
  ;; return a vector of atoms, but remove duplicates first.
  (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
	 (rest all))
    (while rest
      (cond ((memq (car rest) (cdr rest))
	     (setcdr rest (delq (car rest) (cdr rest))))
	    ((eq (car (cdr rest)) '_EMACS_INTERNAL)  ; shh, it's a secret
	     (setcdr rest (cdr (cdr rest))))
	    (t
	     (setq rest (cdr rest)))))
    (apply 'vector all)))

(defun xselect-convert-to-delete (selection type value)
  (x-disown-selection-internal selection)
  ;; A return value of nil means that we do not know how to do this conversion,
  ;; and replies with an "error".  A return value of NULL means that we have
  ;; done the conversion (and any side-effects) but have no value to return.
  'NULL)

(defun xselect-convert-to-filename (selection type value)
  (cond ((overlayp value)
	 (buffer-file-name (or (overlay-buffer value)
			       (error "selection is in a killed buffer"))))
	((and (consp value)
	      (markerp (car value))
	      (markerp (cdr value)))
	 (buffer-file-name (or (marker-buffer (car value))
			       (error "selection is in a killed buffer"))))
	(t nil)))

(defun xselect-convert-to-charpos (selection type value)
  (let (a b tmp)
    (cond ((cond ((overlayp value)
		  (setq a (overlay-start value)
			b (overlay-end value)))
		 ((and (consp value)
		       (markerp (car value))
		       (markerp (cdr value)))
		  (setq a (car value)
			b (cdr value))))
	   (setq a (1- a) b (1- b)) ; zero-based
	   (if (< b a) (setq tmp a a b b tmp))
	   (cons 'SPAN
		 (vector (cons (ash a -16) (logand a 65535))
			 (cons (ash b -16) (logand b 65535))))))))

(defun xselect-convert-to-lineno (selection type value)
  (let (a b buf tmp)
    (cond ((cond ((and (consp value)
		       (markerp (car value))
		       (markerp (cdr value)))
		  (setq a (marker-position (car value))
			b (marker-position (cdr value))
			buf (marker-buffer (car value))))
		 ((overlayp value)
		  (setq buf (overlay-buffer value)
			a (overlay-start value)
			b (overlay-end value)))
		 )
	   (save-excursion
	     (set-buffer buf)
	     (setq a (count-lines 1 a)
		   b (count-lines 1 b)))
	   (if (< b a) (setq tmp a a b b tmp))
	   (cons 'SPAN
		 (vector (cons (ash a -16) (logand a 65535))
			 (cons (ash b -16) (logand b 65535))))))))

(defun xselect-convert-to-colno (selection type value)
  (let (a b buf tmp)
    (cond ((cond ((and (consp value)
		       (markerp (car value))
		       (markerp (cdr value)))
		  (setq a (car value)
			b (cdr value)
			buf (marker-buffer a)))
		 ((overlayp value)
		  (setq buf (overlay-buffer value)
			a (overlay-start value)
			b (overlay-end value)))
		 )
	   (save-excursion
	     (set-buffer buf)
	     (goto-char a)
	     (setq a (current-column))
	     (goto-char b)
	     (setq b (current-column)))
	   (if (< b a) (setq tmp a a b b tmp))
	   (cons 'SPAN
		 (vector (cons (ash a -16) (logand a 65535))
			 (cons (ash b -16) (logand b 65535))))))))

(defun xselect-convert-to-os (selection type size)
  (symbol-name system-type))

(defun xselect-convert-to-host (selection type size)
  (system-name))

(defun xselect-convert-to-user (selection type size)
  (user-full-name))

(defun xselect-convert-to-class (selection type size)
  "Convert selection to class.
This function returns the string \"Emacs\"."
  "Emacs")

;; We do not try to determine the name Emacs was invoked with,
;; because it is not clean for a program's behavior to depend on that.
(defun xselect-convert-to-name (selection type size)
  "Convert selection to name.
This function returns the string \"emacs\"."
  "emacs")

(defun xselect-convert-to-integer (selection type value)
  (and (integerp value)
       (cons (ash value -16) (logand value 65535))))

(defun xselect-convert-to-atom (selection type value)
  (and (symbolp value) value))

(defun xselect-convert-to-identity (selection type value) ; used internally
  (vector value))

(setq selection-converter-alist
      '((TEXT . xselect-convert-to-string)
	(COMPOUND_TEXT . xselect-convert-to-string)
	(STRING . xselect-convert-to-string)
	(UTF8_STRING . xselect-convert-to-string)
	(TARGETS . xselect-convert-to-targets)
	(LENGTH . xselect-convert-to-length)
	(DELETE . xselect-convert-to-delete)
	(FILE_NAME . xselect-convert-to-filename)
	(CHARACTER_POSITION . xselect-convert-to-charpos)
	(LINE_NUMBER . xselect-convert-to-lineno)
	(COLUMN_NUMBER . xselect-convert-to-colno)
	(OWNER_OS . xselect-convert-to-os)
	(HOST_NAME . xselect-convert-to-host)
	(USER . xselect-convert-to-user)
	(CLASS . xselect-convert-to-class)
	(NAME . xselect-convert-to-name)
	(ATOM . xselect-convert-to-atom)
	(INTEGER . xselect-convert-to-integer)
	(_EMACS_INTERNAL . xselect-convert-to-identity)
	))

(provide 'select)

;;; arch-tag: bb634f97-8a3b-4b0a-b940-f6e09982328c
;;; select.el ends here
Commit	Line	Data
60370d40	1	;;; select.el --- lisp portion of standard selection support
3109d63f	2
30764597	3	;; Maintainer: FSF
3109d63f ER	4	;; Keywords: internal
3109d63f ER	5
c90f2757	6	;; Copyright (C) 1993, 1994, 2001, 2002, 2003, 2004,
409cc4a3	7	;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
3109d63f ER	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
b4aa6026	14	;; the Free Software Foundation; either version 3, or (at your option)
3109d63f ER	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
b578f267	23	;; along with GNU Emacs; see the file COPYING. If not, write to the
086add15 LK	24	;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
086add15 LK	25	;; Boston, MA 02110-1301, USA.
3109d63f	26
60370d40 PJ	27	;;; Commentary:
60370d40 PJ	28
3109d63f ER	29	;;; Code:
	30
	31	;; This is for temporary compatibility with pre-release Emacs 19.
31e1d920	32	(defalias 'x-selection 'x-get-selection)
3109d63f ER	33	(defun x-get-selection (&optional type data-type)
3109d63f ER	34	"Return the value of an X Windows selection.
47fb2723	35	The argument TYPE (default `PRIMARY') says which selection,
4029fd9a	36	and the argument DATA-TYPE (default `STRING') says
76058c27 EZ	37	how to convert the data.
76058c27 EZ	38
15a24762 LT	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
76058c27 EZ	44	DATA-TYPE is usually `STRING', but can also be one of the symbols
76058c27 EZ	45	in `selection-converter-alist', which see."
f147fd76 KH	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))
3109d63f ER	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.
15a24762 LT	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).
5038b790 RS	70
5038b790 RS	71	The selection may also be a cons of two markers pointing to the same buffer,
47fb2723	72	or an overlay. In these cases, the selection is considered to be the text
5038b790 RS	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
15a24762 LT	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 ."
3109d63f	84	(interactive (if (not current-prefix-arg)
5038b790	85	(list 'PRIMARY (read-string "Set text for pasting: "))
1b270b55	86	(list 'PRIMARY (buffer-substring (region-beginning) (region-end)))))
3109d63f ER	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))))))
6eac0de6	115	(overlayp data)
3109d63f ER	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
c2649d3f JB	128	(declare-function x-get-cut-buffer-internal "xselect.c")
c2649d3f JB	129
3109d63f	130	(defun x-get-cut-buffer (&optional which-one)
8157ac14 PJ	131	"Returns the value of one of the 8 X server cut-buffers.
8157ac14 PJ	132	Optional arg WHICH-ONE should be a number from 0 to 7, defaulting to 0.
3109d63f ER	133	Cut buffers are considered obsolete; you should use selections instead."
	134	(x-get-cut-buffer-internal
	135	(if which-one
	136	(aref [CUT_BUFFER0 CUT_BUFFER1 CUT_BUFFER2 CUT_BUFFER3
	137	CUT_BUFFER4 CUT_BUFFER5 CUT_BUFFER6 CUT_BUFFER7]
	138	which-one)
	139	'CUT_BUFFER0)))
	140
c2649d3f JB	141	(declare-function x-rotate-cut-buffers-internal "xselect.c")
	142	(declare-function x-store-cut-buffer-internal "xselect.c")
	143
39479f7e	144	(defun x-set-cut-buffer (string &optional push)
3109d63f	145	"Store STRING into the X server's primary cut buffer.
39479f7e	146	If PUSH is non-nil, also rotate the cut buffers:
47fb2723	147	this means the previous value of the primary cut buffer moves to the second
3109d63f ER	148	cut buffer, and the second to the third, and so on (there are 8 buffers.)
3109d63f ER	149	Cut buffers are considered obsolete; you should use selections instead."
47fb2723	150	(or (stringp string) (signal 'wrong-type-argument (list 'string string)))
39479f7e RS	151	(if push
39479f7e RS	152	(x-rotate-cut-buffers-internal 1))
3109d63f ER	153	(x-store-cut-buffer-internal 'CUT_BUFFER0 string))
	154
	155	\f
	156	;;; Functions to convert the selection into various other selection types.
	157	;;; Every selection type that Emacs handles is implemented this way, except
	158	;;; for TIMESTAMP, which is a special case.
	159
1df04e22 JD	160	(eval-when-compile (require 'ccl))
	161
	162	(define-ccl-program ccl-check-utf-8
	163	'(0
	164	((r0 = 1)
	165	(loop
	166	(read-if (r1 < #x80) (repeat)
	167	((r0 = 0)
	168	(if (r1 < #xC2) (end))
	169	(read r2)
	170	(if ((r2 & #xC0) != #x80) (end))
	171	(if (r1 < #xE0) ((r0 = 1) (repeat)))
	172	(read r2)
	173	(if ((r2 & #xC0) != #x80) (end))
	174	(if (r1 < #xF0) ((r0 = 1) (repeat)))
	175	(read r2)
	176	(if ((r2 & #xC0) != #x80) (end))
	177	(if (r1 < #xF8) ((r0 = 1) (repeat)))
	178	(read r2)
	179	(if ((r2 & #xC0) != #x80) (end))
	180	(if (r1 == #xF8) ((r0 = 1) (repeat)))
	181	(end))))))
	182	"Check if the input unibyte string is a valid UTF-8 sequence or not.
	183	If it is valid, set the register `r0' to 1, else set it to 0.")
	184
	185	(defun string-utf-8-p (string)
4837b516	186	"Return non-nil if STRING is a unibyte string of valid UTF-8 sequence."
1df04e22 JD	187	(if (or (not (stringp string))
	188	(multibyte-string-p string))
	189	(error "Not a unibyte string: %s" string))
	190	(let ((status (make-vector 9 0)))
	191	(ccl-execute-on-string ccl-check-utf-8 status string)
	192	(= (aref status 0) 1)))
	193
	194
3109d63f	195	(defun xselect-convert-to-string (selection type value)
eb1416b9 KH	196	(let (str coding)
	197	;; Get the actual string from VALUE.
	198	(cond ((stringp value)
	199	(setq str value))
	200
	201	((overlayp value)
	202	(save-excursion
	203	(or (buffer-name (overlay-buffer value))
	204	(error "selection is in a killed buffer"))
	205	(set-buffer (overlay-buffer value))
	206	(setq str (buffer-substring (overlay-start value)
	207	(overlay-end value)))))
	208	((and (consp value)
	209	(markerp (car value))
	210	(markerp (cdr value)))
	211	(or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
	212	(signal 'error
	213	(list "markers must be in the same buffer"
	214	(car value) (cdr value))))
	215	(save-excursion
	216	(set-buffer (or (marker-buffer (car value))
	217	(error "selection is in a killed buffer")))
	218	(setq str (buffer-substring (car value) (cdr value))))))
	219
	220	(when str
	221	;; If TYPE is nil, this is a local request, thus return STR as
	222	;; is. Otherwise, encode STR.
	223	(if (not type)
	224	str
	225	(setq coding (or next-selection-coding-system selection-coding-system))
	226	(if coding
	227	(setq coding (coding-system-base coding))
	228	(setq coding 'raw-text))
deae888e	229	(let ((inhibit-read-only t))
b36ee2a6	230	;; Suppress producing escape sequences for compositions.
deae888e LT	231	(remove-text-properties 0 (length str) '(composition nil) str)
	232	(cond
	233	((eq type 'TEXT)
	234	(if (not (multibyte-string-p str))
	235	;; Don't have to encode unibyte string.
	236	(setq type 'STRING)
	237	;; If STR contains only ASCII, Latin-1, and raw bytes,
	238	;; encode STR by iso-latin-1, and return it as type
	239	;; `STRING'. Otherwise, encode STR by CODING. In that
	240	;; case, the returing type depends on CODING.
	241	(let ((charsets (find-charset-string str)))
	242	(setq charsets
	243	(delq 'ascii
	244	(delq 'latin-iso8859-1
	245	(delq 'eight-bit-control
	246	(delq 'eight-bit-graphic charsets)))))
	247	(if charsets
	248	(setq str (encode-coding-string str coding)
	249	type (if (memq coding '(compound-text
	250	compound-text-with-extensions))
	251	'COMPOUND_TEXT
	252	'STRING))
	253	(setq type 'STRING
	254	str (encode-coding-string str 'iso-latin-1))))))
	255
	256	((eq type 'COMPOUND_TEXT)
	257	(setq str (encode-coding-string str coding)))
	258
	259	((eq type 'STRING)
	260	(if (memq coding '(compound-text
	261	compound-text-with-extensions))
	262	(setq str (string-make-unibyte str))
	263	(setq str (encode-coding-string str coding))))
	264
	265	((eq type 'UTF8_STRING)
1df04e22 JD	266	(if (multibyte-string-p str)
	267	(setq str (encode-coding-string str 'utf-8)))
	268	(if (not (string-utf-8-p str))
	269	(setq str nil))) ;; Decline request as we don't have UTF-8 data.
deae888e LT	270	(t
	271	(error "Unknow selection type: %S" type))
	272	)))
eb1416b9 KH	273
	274	(setq next-selection-coding-system nil)
	275	(cons type str))))
	276
3109d63f ER	277
	278	(defun xselect-convert-to-length (selection type value)
	279	(let ((value
	280	(cond ((stringp value)
	281	(length value))
6eac0de6 RS	282	((overlayp value)
6eac0de6 RS	283	(abs (- (overlay-end value) (overlay-start value))))
3109d63f ER	284	((and (consp value)
	285	(markerp (car value))
	286	(markerp (cdr value)))
	287	(or (eq (marker-buffer (car value))
	288	(marker-buffer (cdr value)))
	289	(signal 'error
	290	(list "markers must be in the same buffer"
	291	(car value) (cdr value))))
	292	(abs (- (car value) (cdr value)))))))
	293	(if value ; force it to be in 32-bit format.
	294	(cons (ash value -16) (logand value 65535))
	295	nil)))
	296
	297	(defun xselect-convert-to-targets (selection type value)
	298	;; return a vector of atoms, but remove duplicates first.
	299	(let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
	300	(rest all))
	301	(while rest
	302	(cond ((memq (car rest) (cdr rest))
	303	(setcdr rest (delq (car rest) (cdr rest))))
	304	((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret
	305	(setcdr rest (cdr (cdr rest))))
	306	(t
	307	(setq rest (cdr rest)))))
	308	(apply 'vector all)))
	309
	310	(defun xselect-convert-to-delete (selection type value)
	311	(x-disown-selection-internal selection)
	312	;; A return value of nil means that we do not know how to do this conversion,
	313	;; and replies with an "error". A return value of NULL means that we have
	314	;; done the conversion (and any side-effects) but have no value to return.
	315	'NULL)
	316
	317	(defun xselect-convert-to-filename (selection type value)
6eac0de6 RS	318	(cond ((overlayp value)
	319	(buffer-file-name (or (overlay-buffer value)
	320	(error "selection is in a killed buffer"))))
3109d63f ER	321	((and (consp value)
	322	(markerp (car value))
	323	(markerp (cdr value)))
	324	(buffer-file-name (or (marker-buffer (car value))
	325	(error "selection is in a killed buffer"))))
	326	(t nil)))
	327
	328	(defun xselect-convert-to-charpos (selection type value)
	329	(let (a b tmp)
6eac0de6 RS	330	(cond ((cond ((overlayp value)
	331	(setq a (overlay-start value)
	332	b (overlay-end value)))
3109d63f ER	333	((and (consp value)
	334	(markerp (car value))
	335	(markerp (cdr value)))
	336	(setq a (car value)
	337	b (cdr value))))
	338	(setq a (1- a) b (1- b)) ; zero-based
	339	(if (< b a) (setq tmp a a b b tmp))
	340	(cons 'SPAN
	341	(vector (cons (ash a -16) (logand a 65535))
	342	(cons (ash b -16) (logand b 65535))))))))
	343
	344	(defun xselect-convert-to-lineno (selection type value)
	345	(let (a b buf tmp)
	346	(cond ((cond ((and (consp value)
	347	(markerp (car value))
	348	(markerp (cdr value)))
	349	(setq a (marker-position (car value))
	350	b (marker-position (cdr value))
	351	buf (marker-buffer (car value))))
6eac0de6 RS	352	((overlayp value)
	353	(setq buf (overlay-buffer value)
	354	a (overlay-start value)
	355	b (overlay-end value)))
3109d63f ER	356	)
	357	(save-excursion
	358	(set-buffer buf)
	359	(setq a (count-lines 1 a)
	360	b (count-lines 1 b)))
	361	(if (< b a) (setq tmp a a b b tmp))
	362	(cons 'SPAN
	363	(vector (cons (ash a -16) (logand a 65535))
	364	(cons (ash b -16) (logand b 65535))))))))
	365
	366	(defun xselect-convert-to-colno (selection type value)
	367	(let (a b buf tmp)
	368	(cond ((cond ((and (consp value)
	369	(markerp (car value))
	370	(markerp (cdr value)))
	371	(setq a (car value)
	372	b (cdr value)
	373	buf (marker-buffer a)))
6eac0de6 RS	374	((overlayp value)
	375	(setq buf (overlay-buffer value)
	376	a (overlay-start value)
	377	b (overlay-end value)))
3109d63f ER	378	)
	379	(save-excursion
	380	(set-buffer buf)
	381	(goto-char a)
	382	(setq a (current-column))
	383	(goto-char b)
	384	(setq b (current-column)))
	385	(if (< b a) (setq tmp a a b b tmp))
	386	(cons 'SPAN
	387	(vector (cons (ash a -16) (logand a 65535))
	388	(cons (ash b -16) (logand b 65535))))))))
	389
	390	(defun xselect-convert-to-os (selection type size)
	391	(symbol-name system-type))
	392
	393	(defun xselect-convert-to-host (selection type size)
	394	(system-name))
	395
	396	(defun xselect-convert-to-user (selection type size)
	397	(user-full-name))
	398
	399	(defun xselect-convert-to-class (selection type size)
47a31c6b PJ	400	"Convert selection to class.
47a31c6b PJ	401	This function returns the string \"Emacs\"."
7e773fb4	402	"Emacs")
3109d63f ER	403
	404	;; We do not try to determine the name Emacs was invoked with,
	405	;; because it is not clean for a program's behavior to depend on that.
	406	(defun xselect-convert-to-name (selection type size)
47a31c6b PJ	407	"Convert selection to name.
47a31c6b PJ	408	This function returns the string \"emacs\"."
3109d63f ER	409	"emacs")
	410
	411	(defun xselect-convert-to-integer (selection type value)
	412	(and (integerp value)
	413	(cons (ash value -16) (logand value 65535))))
	414
	415	(defun xselect-convert-to-atom (selection type value)
	416	(and (symbolp value) value))
	417
	418	(defun xselect-convert-to-identity (selection type value) ; used internally
	419	(vector value))
	420
	421	(setq selection-converter-alist
	422	'((TEXT . xselect-convert-to-string)
79501c8d	423	(COMPOUND_TEXT . xselect-convert-to-string)
3109d63f	424	(STRING . xselect-convert-to-string)
eb1416b9	425	(UTF8_STRING . xselect-convert-to-string)
3109d63f ER	426	(TARGETS . xselect-convert-to-targets)
	427	(LENGTH . xselect-convert-to-length)
	428	(DELETE . xselect-convert-to-delete)
	429	(FILE_NAME . xselect-convert-to-filename)
	430	(CHARACTER_POSITION . xselect-convert-to-charpos)
	431	(LINE_NUMBER . xselect-convert-to-lineno)
	432	(COLUMN_NUMBER . xselect-convert-to-colno)
	433	(OWNER_OS . xselect-convert-to-os)
	434	(HOST_NAME . xselect-convert-to-host)
	435	(USER . xselect-convert-to-user)
	436	(CLASS . xselect-convert-to-class)
	437	(NAME . xselect-convert-to-name)
	438	(ATOM . xselect-convert-to-atom)
	439	(INTEGER . xselect-convert-to-integer)
	440	(_EMACS_INTERNAL . xselect-convert-to-identity)
	441	))
	442
	443	(provide 'select)
	444
ab5796a9	445	;;; arch-tag: bb634f97-8a3b-4b0a-b940-f6e09982328c
60370d40	446	;;; select.el ends here