+
+\f
+;;; Functions to convert the selection into various other selection
+;;; types.
+
+;; These next three functions get called by C code...
+(defun select-convert-in (selection type value)
+ "Attempt to convert the specified external VALUE to the specified DATA-TYPE,
+for the specified SELECTION. Return nil if this is impossible, or a
+suitable internal representation otherwise."
+ (when value
+ (let ((handler-fn (cdr (assq type selection-converter-in-alist))))
+ (when handler-fn
+ (apply handler-fn (list selection type value))))))
+
+(defun select-convert-out (selection type value)
+ "Attempt to convert the specified internal VALUE for the specified DATA-TYPE
+and SELECTION. Return nil if this is impossible, or a suitable external
+representation otherwise."
+ (when value
+ (let ((handler-fn (cdr (assq type selection-converter-out-alist))))
+ (when handler-fn
+ (apply handler-fn (list selection type value))))))
+
+(defun select-coerce (selection type value)
+ "Attempt to convert the specified internal VALUE to a representation
+suitable for return from `get-selection' in the specified DATA-TYPE. Return
+nil if this is impossible, or a suitable representation otherwise."
+ (when value
+ (let ((handler-fn (cdr (assq type selection-coercion-alist))))
+ (when handler-fn
+ (apply handler-fn (list selection type value))))))
+
+;; The rest of the functions on this "page" are conversion handlers,
+;; append handlers and buffer-kill handlers.
+(defun select-convert-to-text (selection type value)
+ (cond ((stringp value)
+ value)
+ ((extentp value)
+ (save-excursion
+ (set-buffer (extent-object value))
+ (save-restriction
+ (widen)
+ (buffer-substring (extent-start-position value)
+ (extent-end-position 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")))
+ (save-restriction
+ (widen)
+ (buffer-substring (car value) (cdr value)))))
+ (t nil)))
+
+(defun select-coerce-to-text (selection type value)
+ (select-convert-to-text selection type value))
+
+(defun select-convert-from-text (selection type value)
+ (when (stringp value)
+ value))
+
+(defun select-convert-to-string (selection type value)
+ (let ((outval (select-convert-to-text selection type value)))
+ ;; force the string to be not in Compound Text format. This grubby
+ ;; hack will go soon, to be replaced by a more general mechanism.
+ (if (stringp outval)
+ (cons 'STRING outval)
+ outval)))
+
+(defun select-convert-to-compound-text (selection type value)
+ ;; converts to compound text automatically
+ (select-convert-to-text selection type value))
+
+(defun select-convert-to-length (selection type value)
+ (let ((value
+ (cond ((stringp value)
+ (length value))
+ ((extentp value)
+ (extent-length 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 select-convert-from-length (selection type value)
+ (select-convert-to-length selection type value))
+
+(defun select-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))))
+ (t
+ (setq rest (cdr rest)))))
+ (apply 'vector all)))
+
+(defun select-convert-to-delete (selection type value)
+ (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 select-convert-to-filename (selection type value)
+ (cond ((extentp value)
+ (buffer-file-name (or (extent-object 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 select-convert-from-filename (selection type value)
+ (when (stringp value)
+ value))
+
+(defun select-convert-to-charpos (selection type value)
+ (let (a b tmp)
+ (cond ((cond ((extentp value)
+ (setq a (extent-start-position value)
+ b (extent-end-position 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 select-convert-to-lineno (selection type value)
+ (let (a b buf tmp)
+ (cond ((cond ((extentp value)
+ (setq buf (extent-object value)
+ a (extent-start-position value)
+ b (extent-end-position value)))
+ ((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)))))
+ (save-excursion
+ (set-buffer buf)
+ (save-restriction
+ (widen)
+ (goto-char a)
+ (beginning-of-line)
+ (setq a (1+ (count-lines 1 (point))))
+ (goto-char b)
+ (beginning-of-line)
+ (setq b (1+ (count-lines 1 (point))))))
+ (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 select-convert-to-colno (selection type value)
+ (let (a b buf tmp)
+ (cond ((cond ((extentp value)
+ (setq buf (extent-object value)
+ a (extent-start-position value)
+ b (extent-end-position value)))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (setq a (car value)
+ b (cdr value)
+ buf (marker-buffer a))))
+ (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 select-convert-to-sourceloc (selection type value)
+ (let (a b buf file-name tmp)
+ (cond ((cond ((extentp value)
+ (setq buf (or (extent-object value)
+ (error "selection is in a killed buffer"))
+ a (extent-start-position value)
+ b (extent-end-position value)
+ file-name (buffer-file-name buf)))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (setq a (marker-position (car value))
+ b (marker-position (cdr value))
+ buf (or (marker-buffer (car value))
+ (error "selection is in a killed buffer"))
+ file-name (buffer-file-name buf))))
+ (save-excursion
+ (set-buffer buf)
+ (save-restriction
+ (widen)
+ (goto-char a)
+ (beginning-of-line)
+ (setq a (1+ (count-lines 1 (point))))
+ (goto-char b)
+ (beginning-of-line)
+ (setq b (1+ (count-lines 1 (point))))))
+ (if (< b a) (setq tmp a a b b tmp))
+ (format "%s:%d" file-name a)))))
+
+(defun select-convert-to-os (selection type size)
+ (symbol-name system-type))
+
+(defun select-convert-to-host (selection type size)
+ (system-name))
+
+(defun select-convert-to-user (selection type size)
+ (user-full-name))
+
+(defun select-convert-to-class (selection type size)
+ (symbol-value 'x-emacs-application-class))
+
+;; 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 select-convert-to-name (selection type size)
+ ;invocation-name
+ "xemacs")
+
+(defun select-convert-to-integer (selection type value)
+ (and (integerp value)
+ (cons (ash value -16) (logand value 65535))))
+
+;; Can convert from the following integer representations
+;;
+;; integer
+;; (integer . integer)
+;; (integer integer)
+;; (list [integer|(integer . integer)]*)
+;; (vector [integer|(integer . integer)]*)
+;;
+;; Cons'd integers get cleaned up a little.
+
+(defun select-convert-from-integer (selection type value)
+ (cond ((integerp value) ; Integer
+ value)
+
+ ((and (consp value) ; (integer . integer)
+ (integerp (car value))
+ (integerp (cdr value)))
+ (if (eq (car value) 0)
+ (cdr value)
+ (if (and (eq (car value) -1)
+ (< (cdr value) 0))
+ (cdr value)
+ value)))
+
+ ((and (listp value) ; (integer integer)
+ (eq (length value) 2)
+ (integerp (car value))
+ (integerp (cadr value)))
+ (if (eq (car value) 0)
+ (cadr value)
+ (if (and (eq (car value) -1)
+ (< (cdr value) 0))
+ (- (cadr value))
+ (cons (car value) (cadr value)))))
+
+ ((listp value) ; list
+ (if (cdr value)
+ (mapcar '(lambda (x)
+ (select-convert-from-integer selection type x))
+ value)
+ (select-convert-from-integer selection type (car value))))
+
+ ((vectorp value) ; vector
+ (if (eq (length value) 1)
+ (select-convert-from-integer selection type (aref value 0))
+ (mapvector '(lambda (x)
+ (select-convert-from-integer selection type x))
+ value)))
+
+ (t nil)
+ ))
+
+(defun select-convert-to-atom (selection type value)
+ (and (symbolp value) value))
+
+;;; CF_xxx conversions
+(defun select-convert-from-cf-text (selection type value)
+ (replace-in-string (if (string-match "\0" value)
+ (substring value 0 (match-beginning 0))
+ value)
+ "\\(\r\n\\|\n\r\\)" "\n" t))
+
+(defun select-convert-to-cf-text (selection type value)
+ (let ((text (select-convert-to-text selection type value)))
+ (concat (replace-in-string text "\n" "\r\n" t) "\0")))
+
+;;; Appenders
+(defun select-append-to-text (selection type value1 value2)
+ (let ((text1 (select-convert-to-text selection 'STRING value1))
+ (text2 (select-convert-to-text selection 'STRING value2)))
+ (if (and text1 text2)
+ (concat text1 text2)
+ nil)))
+
+(defun select-append-to-string (selection type value1 value2)
+ (select-append-to-text selection type value1 value2))
+
+(defun select-append-to-compound-text (selection type value1 value2)
+ (select-append-to-text selection type value1 value2))
+
+(defun select-append-to-cf-text (selection type value1 value2)
+ (let ((text1 (select-convert-from-cf-text selection 'CF_TEXT value1))
+ (text2 (select-convert-from-cf-text selection 'CF_TEXT value2)))
+ (if (and text1 text2)
+ (select-convert-to-cf-text selection type (concat text1 text2))
+ nil)))
+
+(defun select-append-default (selection type value1 value2)
+;; This appender gets used if the type is "nil" - i.e. default.
+;; It should probably have more cases implemented than it does - e.g.
+;; appending numbers to strings, etc...
+ (cond ((and (stringp value1) (stringp value2))
+ (select-append-to-string selection 'STRING value1 value2))
+ (t nil)))
+
+;;; Buffer kill handlers
+
+(defun select-buffer-killed-default (selection type value buffer)
+;; This handler gets used if the type is "nil".
+ (cond ((extentp value)
+ (if (eq (extent-object value) buffer)
+ ; If this selection is on the clipboard, grab it quick
+ (when (eq selection 'CLIPBOARD)
+ (save-excursion
+ (set-buffer (extent-object value))
+ (save-restriction
+ (widen)
+ (buffer-substring (extent-start-position value)
+ (extent-end-position value)))))
+ value))
+ ((markerp value)
+ (unless (eq (marker-buffer value) buffer)
+ value))
+ ((and (consp value)
+ (markerp (car value))
+ (markerp (cdr value)))
+ (if (or (eq (marker-buffer (car value)) buffer)
+ (eq (marker-buffer (cdr value)) buffer))
+ ; If this selection is on the clipboard, grab it quick
+ (when (eq selection 'CLIPBOARD)
+ (save-excursion
+ (set-buffer (marker-buffer (car value)))
+ (save-restriction
+ (widen)
+ (buffer-substring (car value) (cdr value)))))
+ value))
+ (t value)))
+
+(defun select-buffer-killed-text (selection type value buffer)
+ (select-buffer-killed-default selection type value buffer))
+
+;; Types listed in here can be selections of XEmacs
+(setq selection-converter-out-alist
+ '((TEXT . select-convert-to-text)
+ (STRING . select-convert-to-string)
+ (COMPOUND_TEXT . select-convert-to-compound-text)
+ (TARGETS . select-convert-to-targets)
+ (LENGTH . select-convert-to-length)
+ (DELETE . select-convert-to-delete)
+ (FILE_NAME . select-convert-to-filename)
+ (CHARACTER_POSITION . select-convert-to-charpos)
+ (SOURCE_LOC . select-convert-to-sourceloc)
+ (LINE_NUMBER . select-convert-to-lineno)
+ (COLUMN_NUMBER . select-convert-to-colno)
+ (OWNER_OS . select-convert-to-os)
+ (HOST_NAME . select-convert-to-host)
+ (USER . select-convert-to-user)
+ (CLASS . select-convert-to-class)
+ (NAME . select-convert-to-name)
+ (ATOM . select-convert-to-atom)
+ (INTEGER . select-convert-to-integer)
+ (CF_TEXT . select-convert-to-cf-text)
+ ))
+
+;; Types listed here can be selections foreign to XEmacs
+(setq selection-converter-in-alist
+ '(; Specific types that get handled by generic converters
+ (COMPOUND_TEXT . select-convert-from-text)
+ (SOURCE_LOC . select-convert-from-text)
+ (OWNER_OS . select-convert-from-text)
+ (HOST_NAME . select-convert-from-text)
+ (USER . select-convert-from-text)
+ (CLASS . select-convert-from-text)
+ (NAME . select-convert-from-text)
+ ; Generic types
+ (INTEGER . select-convert-from-integer)
+ (TEXT . select-convert-from-text)
+ (STRING . select-convert-from-text)
+ (LENGTH . select-convert-from-length)
+ (FILE_NAME . select-convert-from-filename)
+ (CF_TEXT . select-convert-from-cf-text)
+ ))
+
+;; Types listed here have special coercion functions that can munge
+;; other types. This can also be used to add special features - e.g.
+;; being able to pass a region or a cons of markers to own-selection,
+;; but getting the *current* text in the region back when calling
+;; get-selection.
+;;
+;; Any function listed in here *will be called* whenever a value of
+;; its type is retrieved from the internal selection cache, or when
+;; no suitable values could be found in which case XEmacs looks for
+;; values with types listed in selection-coercible-types.
+(setq selection-coercion-alist
+ '((TEXT . select-coerce-to-text)
+ (STRING . select-coerce-to-text)
+ (COMPOUND_TEXT . select-coerce-to-text)
+ (CF_TEXT . select-coerce-to-text)))
+
+;; Types listed here can be appended by own-selection
+(setq selection-appender-alist
+ '((nil . select-append-default)
+ (TEXT . select-append-to-text)
+ (STRING . select-append-to-string)
+ (COMPOUND_TEXT . select-append-to-compound-text)
+ (CF_TEXT . select-append-to-cf-text)
+ ))
+
+;; Types listed here have buffer-kill handlers
+(setq selection-buffer-killed-alist
+ '((nil . select-buffer-killed-default)
+ (TEXT . select-buffer-killed-text)
+ (STRING . select-buffer-killed-text)
+ (COMPOUND_TEXT . select-buffer-killed-text)
+ (CF_TEXT . select-buffer-killed-text)))
+
+;; Lists of types that are coercible (can be converted to other types)
+(setq selection-coercible-types '(TEXT STRING COMPOUND_TEXT))
projects / chise / xemacs-chise.git.1 / blobdiff