Mercurial > hg > xemacs-beta

comparison lisp/select.el @ 2624:8174a45f637c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2005-03-01 00:21:18 by aidan] Were I not a total newbie at using Patcher, I would suspect a bug in it. The change described in 16931.35825.340535.36815@parhasard.net to xemacs-patches@ includes an update to lisp/select.el; the corresponding CVS commit, done, AFAIR, from Patcher, doesn't.
author aidan
date Tue, 01 Mar 2005 00:21:18 +0000
parents e7ee5f8bde58
children 0ba09d009197
comparison
equal deleted inserted replaced
2623:48facb601f29 2624:8174a45f637c
31 31
32 ;; This file is dumped with XEmacs 32 ;; This file is dumped with XEmacs
33 33
34 ;;; Code: 34 ;;; Code:
35 35
36 (defvar selected-text-type 36 ;; We prefer UTF8_STRING to COMPOUND_TEXT because, even though the latter
37 (if (featurep 'mule) '(COMPOUND_TEXT STRING) 'STRING) 37 ;; gives us more information when taking data from other XEmacs invocations,
38 "The type atom used to obtain selections from the X server. 38 ;; Mozilla will happily give us broken COMPOUND_TEXT where a non-broken
39 Can be either a valid X selection data type, or a list of such types. 39 ;; UTF8_STRING is available.
40 COMPOUND_TEXT and STRING are the most commonly used data types. 40 (defvar selection-preferred-types
41 If a list is provided, the types are tried in sequence until 41 (let ((res '(UTF8_STRING COMPOUND_TEXT STRING image/png image/gif
42 there is a successful conversion.") 42 image/jpeg image/tiff image/xpm image/xbm)))
43 (unless (featurep 'mule) (delq 'COMPOUND_TEXT res))
44 res)
45 "An ordered list of X11 type atoms for selections we want to receive.
46 We prefer UTF8_STRING over COMPOUND_TEXT, for compatibility with a certain
47 widely-used browser suite, and COMPOUND_TEXT over STRING. (COMPOUND_TEXT
48 isn't available on non-Mule.) We also accept several image types.
49
50 For compatibility, this can be a single atom. ")
51
52 ;; Renamed because it was just ridiculous for it to be mostly image formats
53 ;; and named selected-text-type.
54 (define-obsolete-variable-alias 'selected-text-type 'selection-preferred-types)
43 55
44 (defvar selection-sets-clipboard nil 56 (defvar selection-sets-clipboard nil
45 "Controls the selection's relationship to the clipboard. 57 "Controls the selection's relationship to the clipboard.
46 When non-nil, any operation that sets the primary selection will also 58 When non-nil, any operation that sets the primary selection will also
47 set the clipboard.") 59 set the clipboard.")
54 (interactive) 66 (interactive)
55 (and (console-on-window-system-p) 67 (and (console-on-window-system-p)
56 (cut-copy-clear-internal 'copy))) 68 (cut-copy-clear-internal 'copy)))
57 69
58 (defun kill-primary-selection () 70 (defun kill-primary-selection ()
59 "Copy the selection to the Clipboard and the kill ring, then deleted it. 71 "Copy the selection to the Clipboard and the kill ring, then delete it.
60 This is similar to the command \\[kill-region] except that it will 72 This is similar to the command \\[kill-region] except that it will
61 save to the Clipboard even if that command doesn't, and it handles rectangles 73 save to the Clipboard even if that command doesn't, and it handles rectangles
62 properly." 74 properly."
63 (interactive "*") 75 (interactive "*")
64 (and (console-on-window-system-p) 76 (and (console-on-window-system-p)
95 "Return the value of one of the cut buffers. 107 "Return the value of one of the cut buffers.
96 This will do nothing under anything other than X.") 108 This will do nothing under anything other than X.")
97 109
98 (defun get-selection-no-error (&optional type data-type) 110 (defun get-selection-no-error (&optional type data-type)
99 "Return the value of a window-system selection. 111 "Return the value of a window-system selection.
100 The argument TYPE (default `PRIMARY') says which selection, 112 The argument TYPE (default `PRIMARY') says which selection, and the argument
101 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule) 113 DATA-TYPE (defaulting to the value of `selection-preferred-types'), says how
102 says how to convert the data. Returns NIL if there is no selection." 114 to convert the data. Returns NIL if there is no selection."
103 (condition-case nil (get-selection type data-type) (t nil))) 115 (condition-case nil (get-selection type data-type) (t nil)))
104 116
105 (defun get-selection (&optional type data-type) 117 (defun get-selection (&optional type data-type)
106 "Return the value of a window-system selection. 118 "Return the value of a window-system selection.
107 The argument TYPE (default `PRIMARY') says which selection, 119 The argument TYPE (default `PRIMARY') says which selection, and the argument
108 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule) 120 DATA-TYPE (defaulting to the value of, and compatible with,
109 says how to convert the data. If there is no selection an error is signalled. 121 `selection-preferred-types') says how to convert the data. If
110 Not suitable in a `interprogram-paste-function', q.v." 122 there is no selection an error is signalled. Not suitable in a
123 `interprogram-paste-function', q.v."
111 (or type (setq type 'PRIMARY)) 124 (or type (setq type 'PRIMARY))
112 (or data-type (setq data-type selected-text-type)) 125 (or data-type (setq data-type selection-preferred-types))
113 (if (consp data-type) 126 (if (consp data-type)
114 (condition-case err 127 ;; TARGETS is a vector; we want a list so we can memq --> append it to
115 (get-selection-internal type (car data-type)) 128 ;; nil.
116 (selection-conversion-error 129 (let ((targets (append (get-selection-internal type 'TARGETS) nil))
117 (if (cdr data-type) 130 res)
118 (get-selection type (cdr data-type)) 131 (catch 'converted
119 (signal (car err) (cdr err))))) 132 (if targets
133 (dolist (current-preference data-type)
134 (condition-case err
135 (if (and (memq current-preference targets)
136 (setq res (get-selection-internal
137 type current-preference)))
138 (throw 'converted res))
139 (selection-conversion-error
140 nil))))
141 ;; The source app didn't offer us anything compatible in TARGETS,
142 ;; or they're not negotiating at all. (That is, we're probably not
143 ;; on X11.) Try to convert to the types specified by our caller,
144 ;; and throw an error if the last one of those fails.
145 (while data-type
146 (condition-case err
147 (progn
148 (setq res (get-selection-internal type (car data-type)))
149 (throw 'converted res))
150 (selection-conversion-error
151 (if (cdr data-type)
152 (setq data-type (pop data-type))
153 (signal (car err) (cdr err))))))))
120 (get-selection-internal type data-type))) 154 (get-selection-internal type data-type)))
121 155
122 (defun get-selection-foreign (&optional type data-type) 156 (defun get-selection-foreign (&optional type data-type)
123 "Return the value of a window-system selection, or nil if XEmacs owns it. 157 "Return the value of a window-system selection, or nil if XEmacs owns it.
124 The argument TYPE (default `PRIMARY') says which selection, 158 The argument TYPE (default `PRIMARY') says which selection, and the argument
125 and the argument DATA-TYPE (default `STRING', or `COMPOUND_TEXT' under Mule) 159 DATA-TYPE (defaulting to the value of `selection-preferred-types' which see)
126 says how to convert the data. If there is no selection an error is signalled. 160 says how to convert the data. If there is no selection an error is
127 See `interprogram-paste-function' for more information." 161 signalled. See `interprogram-paste-function' for more information."
128 (unless (selection-owner-p type) 162 (unless (selection-owner-p type)
129 (get-selection type data-type))) 163 (get-selection type data-type)))
130 164
131 ;; FSFmacs calls this `x-set-selection', and reverses the 165 ;; FSFmacs calls this `x-set-selection', and reverses the
132 ;; first two arguments (duh ...). This order is more logical. 166 ;; first two arguments (duh ...). This order is more logical.
253 287
254 (defun select-make-extent-for-selection (selection previous-extent) 288 (defun select-make-extent-for-selection (selection previous-extent)
255 ;; Given a selection, this makes an extent in the buffer which holds that 289 ;; Given a selection, this makes an extent in the buffer which holds that
256 ;; selection, for highlighting purposes. If the selection isn't associated 290 ;; selection, for highlighting purposes. If the selection isn't associated
257 ;; with a buffer, this does nothing. 291 ;; with a buffer, this does nothing.
292 ;;
293 ;; Something similar needs to be hooked into the rectangle functions.
258 (let ((buffer nil) 294 (let ((buffer nil)
259 (valid (and (extentp previous-extent) 295 (valid (and (extentp previous-extent)
260 (extent-object previous-extent) 296 (extent-object previous-extent)
261 (buffer-live-p (extent-object previous-extent)))) 297 (buffer-live-p (extent-object previous-extent))))
262 start end) 298 start end)
389 "Attempt to convert the specified external VALUE to the specified DATA-TYPE, 425 "Attempt to convert the specified external VALUE to the specified DATA-TYPE,
390 for the specified SELECTION. Return nil if this is impossible, or a 426 for the specified SELECTION. Return nil if this is impossible, or a
391 suitable internal representation otherwise." 427 suitable internal representation otherwise."
392 (when value 428 (when value
393 (let ((handler-fn (cdr (assq type selection-converter-in-alist)))) 429 (let ((handler-fn (cdr (assq type selection-converter-in-alist))))
394 (when handler-fn 430 (if handler-fn
395 (apply handler-fn (list selection type value)))))) 431 (apply handler-fn (list selection type value))
432 value))))
396 433
397 (defun select-convert-out (selection type value) 434 (defun select-convert-out (selection type value)
398 "Attempt to convert the specified internal VALUE for the specified DATA-TYPE 435 "Attempt to convert the specified internal VALUE for the specified DATA-TYPE
399 and SELECTION. Return nil if this is impossible, or a suitable external 436 and SELECTION. Return nil if this is impossible, or a suitable external
400 representation otherwise." 437 representation otherwise."
437 (save-restriction 474 (save-restriction
438 (widen) 475 (widen)
439 (buffer-substring (car value) (cdr value))))) 476 (buffer-substring (car value) (cdr value)))))
440 (t nil))) 477 (t nil)))
441 478
479 (defun select-convert-to-timestamp (selection type value)
480 (let ((ts (get-xemacs-selection-timestamp selection)))
481 (if ts (cons 'TIMESTAMP ts))))
482
483 (defun select-convert-to-utf-8-text (selection type value)
484 (cond ((stringp value)
485 (cons 'UTF8_STRING (encode-coding-string value 'utf-8)))
486 ((extentp value)
487 (save-excursion
488 (set-buffer (extent-object value))
489 (save-restriction
490 (widen)
491 (cons 'UTF8_STRING
492 (encode-coding-string
493 (buffer-substring (extent-start-position value)
494 (extent-end-position value)) 'utf-8)))))
495 ((and (consp value)
496 (markerp (car value))
497 (markerp (cdr value)))
498 (or (eq (marker-buffer (car value)) (marker-buffer (cdr value)))
499 (signal 'error
500 (list "markers must be in the same buffer"
501 (car value) (cdr value))))
502 (save-excursion
503 (set-buffer (or (marker-buffer (car value))
504 (error "selection is in a killed buffer")))
505 (save-restriction
506 (widen)
507 (cons 'UTF8_STRING (encode-coding-string
508 (buffer-substring (car value) (cdr value))
509 'utf-8)))))
510 (t nil)))
511
442 (defun select-coerce-to-text (selection type value) 512 (defun select-coerce-to-text (selection type value)
443 (select-convert-to-text selection type value)) 513 (select-convert-to-text selection type value))
444
445 (defun select-convert-from-text (selection type value)
446 (when (stringp value)
447 value))
448 514
449 (defun select-convert-to-string (selection type value) 515 (defun select-convert-to-string (selection type value)
450 (let ((outval (select-convert-to-text selection type value))) 516 (let ((outval (select-convert-to-text selection type value)))
451 ;; force the string to be not in Compound Text format. This grubby 517 ;; force the string to be not in Compound Text format. This grubby
452 ;; hack will go soon, to be replaced by a more general mechanism. 518 ;; hack will go soon, to be replaced by a more general mechanism.
475 (abs (- (car value) (cdr value))))))) 541 (abs (- (car value) (cdr value)))))))
476 (if value ; force it to be in 32-bit format. 542 (if value ; force it to be in 32-bit format.
477 (cons (ash value -16) (logand value 65535)) 543 (cons (ash value -16) (logand value 65535))
478 nil))) 544 nil)))
479 545
480 (defun select-convert-from-length (selection type value)
481 (select-convert-to-length selection type value))
482
483 (defun select-convert-to-targets (selection type value) 546 (defun select-convert-to-targets (selection type value)
484 ;; return a vector of atoms, but remove duplicates first. 547 ;; return a vector of atoms, but remove duplicates first.
485 (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist))) 548 (let* ((all (cons 'TIMESTAMP (mapcar 'car selection-converter-alist)))
486 (rest all)) 549 (rest all))
487 (while rest 550 (while rest
506 (markerp (car value)) 569 (markerp (car value))
507 (markerp (cdr value))) 570 (markerp (cdr value)))
508 (buffer-file-name (or (marker-buffer (car value)) 571 (buffer-file-name (or (marker-buffer (car value))
509 (error "selection is in a killed buffer")))) 572 (error "selection is in a killed buffer"))))
510 (t nil))) 573 (t nil)))
511
512 (defun select-convert-from-filename (selection type value)
513 (when (stringp value)
514 value))
515 574
516 (defun select-convert-to-charpos (selection type value) 575 (defun select-convert-to-charpos (selection type value)
517 (let (a b tmp) 576 (let (a b tmp)
518 (cond ((cond ((extentp value) 577 (cond ((cond ((extentp value)
519 (setq a (extent-start-position value) 578 (setq a (extent-start-position value)
680 value))) 739 value)))
681 740
682 (t nil) 741 (t nil)
683 )) 742 ))
684 743
744 (defun select-convert-from-ip-address (selection type value)
745 (if (and (stringp value)
746 (= (length value) 4))
747 (format "%d.%d.%d.%d"
748 (aref value 0) (aref value 1) (aref value 2) (aref value 3))))
749
685 (defun select-convert-to-atom (selection type value) 750 (defun select-convert-to-atom (selection type value)
686 (and (symbolp value) value)) 751 (and (symbolp value) value))
687 752
753 (defun select-convert-from-utf-8-text (selection type value)
754 (decode-coding-string value 'utf-8))
755
756 (defun select-convert-from-utf-16-le-text (selection type value)
757 (decode-coding-string value 'utf-16-le))
758
759 ;; Image conversion.
760 (defun select-convert-from-image-data (image-type value)
761 "Take an image type specification--one of the image types this XEmacs
762 supports--and some data in that format, return a space, with a glyph
763 corresponding to that data as an end-glyph extent property of that space. "
764 (let* ((str (make-string 1 ?\ ))
765 (extent (make-extent 0 1 str))
766 (glyph (make-glyph (vector image-type ':data value))))
767 (when glyph
768 (set-extent-property extent 'invisible t)
769 (set-extent-property extent 'start-open t)
770 (set-extent-property extent 'end-open t)
771 (set-extent-property extent 'duplicable t)
772 (set-extent-property extent 'atomic t)
773 (set-extent-end-glyph extent glyph)
774 str)))
775
776 ;; Could automate defining these functions these with a macro, but damned if
777 ;; I can get that to work. Anyway, this is more readable.
778
779 (defun select-convert-from-image/gif (selection type value)
780 (if (featurep 'gif) (select-convert-from-image-data 'gif value)))
781
782 (defun select-convert-from-image/jpeg (selection type value)
783 (if (featurep 'jpeg) (select-convert-from-image-data 'jpeg value)))
784
785 (defun select-convert-from-image/png (selection type value)
786 (if (featurep 'png) (select-convert-from-image-data 'png value)))
787
788 (defun select-convert-from-image/tiff (selection type value)
789 (if (featurep 'tiff) (select-convert-from-image-data 'tiff value)))
790
791 (defun select-convert-from-image/xpm (selection type value)
792 (if (featurep 'xpm) (select-convert-from-image-data 'xpm value)))
793
794 (defun select-convert-from-image/xbm (selection type value)
795 (if (featurep 'xbm) (select-convert-from-image-data 'xbm value)))
796
688 ;;; CF_xxx conversions 797 ;;; CF_xxx conversions
689 (defun select-convert-from-cf-text (selection type value) 798 (defun select-convert-from-cf-text (selection type value)
690 (let ((value (decode-coding-string value 'mswindows-multibyte))) 799 (if (find-coding-system 'mswindows-multibyte)
691 (replace-in-string (if (string-match "\0" value) 800 (let ((value (decode-coding-string value 'mswindows-multibyte)))
692 (substring value 0 (match-beginning 0)) 801 (replace-in-string (if (string-match "\0" value)
693 value) 802 (substring value 0 (match-beginning 0))
694 "\\(\r\n\\|\n\r\\)" "\n" t))) 803 value)
804 "\\(\r\n\\|\n\r\\)" "\n" t))))
695 805
696 (defun select-convert-from-cf-unicodetext (selection type value) 806 (defun select-convert-from-cf-unicodetext (selection type value)
697 (let ((value (decode-coding-string value 'mswindows-unicode))) 807 (if (find-coding-system 'mswindows-unicode)
698 (replace-in-string (if (string-match "\0" value) 808 (let ((value (decode-coding-string value 'mswindows-unicode)))
699 (substring value 0 (match-beginning 0)) 809 (replace-in-string (if (string-match "\0" value)
700 value) 810 (substring value 0 (match-beginning 0))
701 "\\(\r\n\\|\n\r\\)" "\n" t))) 811 value)
812 "\\(\r\n\\|\n\r\\)" "\n" t))))
702 813
703 (defun select-convert-to-cf-text (selection type value) 814 (defun select-convert-to-cf-text (selection type value)
704 (let ((text (select-convert-to-text selection type value))) 815 (if (find-coding-system 'mswindows-multibyte)
705 (encode-coding-string 816 (let ((text (select-convert-to-text selection type value)))
706 (concat (replace-in-string text "\n" "\r\n" t) "\0") 817 (encode-coding-string
707 'mswindows-multibyte))) 818 (concat (replace-in-string text "\n" "\r\n" t) "\0")
819 'mswindows-multibyte))))
708 820
709 (defun select-convert-to-cf-unicodetext (selection type value) 821 (defun select-convert-to-cf-unicodetext (selection type value)
710 (let ((text (select-convert-to-text selection type value))) 822 (if (find-coding-system 'mswindows-unicode)
711 (encode-coding-string 823 (let ((text (select-convert-to-text selection type value)))
712 (concat (replace-in-string text "\n" "\r\n" t) "\0") 824 (encode-coding-string
713 'mswindows-unicode))) 825 (concat (replace-in-string text "\n" "\r\n" t) "\0")
826 'mswindows-unicode))))
714 827
715 ;;; Appenders 828 ;;; Appenders
716 (defun select-append-to-text (selection type value1 value2) 829 (defun select-append-to-text (selection type value1 value2)
717 (let ((text1 (select-convert-to-text selection 'STRING value1)) 830 (let ((text1 (select-convert-to-text selection 'STRING value1))
718 (text2 (select-convert-to-text selection 'STRING value2))) 831 (text2 (select-convert-to-text selection 'STRING value2)))
786 (defun select-buffer-killed-text (selection type value buffer) 899 (defun select-buffer-killed-text (selection type value buffer)
787 (select-buffer-killed-default selection type value buffer)) 900 (select-buffer-killed-default selection type value buffer))
788 901
789 ;; Types listed in here can be selections of XEmacs 902 ;; Types listed in here can be selections of XEmacs
790 (setq selection-converter-out-alist 903 (setq selection-converter-out-alist
791 '((TEXT . select-convert-to-text) 904 '((TIMESTAMP . select-convert-to-timestamp)
905 (UTF8_STRING . select-convert-to-utf-8-text)
906 (TEXT . select-convert-to-text)
792 (STRING . select-convert-to-string) 907 (STRING . select-convert-to-string)
793 (COMPOUND_TEXT . select-convert-to-compound-text) 908 (COMPOUND_TEXT . select-convert-to-compound-text)
794 (TARGETS . select-convert-to-targets) 909 (TARGETS . select-convert-to-targets)
795 (LENGTH . select-convert-to-length) 910 (LENGTH . select-convert-to-length)
796 (DELETE . select-convert-to-delete) 911 (DELETE . select-convert-to-delete)
811 )) 926 ))
812 927
813 ;; Types listed here can be selections foreign to XEmacs 928 ;; Types listed here can be selections foreign to XEmacs
814 (setq selection-converter-in-alist 929 (setq selection-converter-in-alist
815 '(; Specific types that get handled by generic converters 930 '(; Specific types that get handled by generic converters
816 (COMPOUND_TEXT . select-convert-from-text)
817 (SOURCE_LOC . select-convert-from-text)
818 (OWNER_OS . select-convert-from-text)
819 (HOST_NAME . select-convert-from-text)
820 (USER . select-convert-from-text)
821 (CLASS . select-convert-from-text)
822 (NAME . select-convert-from-text)
823 ; Generic types
824 (INTEGER . select-convert-from-integer) 931 (INTEGER . select-convert-from-integer)
825 (TEXT . select-convert-from-text) 932 (TIMESTAMP . select-convert-from-integer)
826 (STRING . select-convert-from-text) 933 (LENGTH . select-convert-from-integer)
827 (LENGTH . select-convert-from-length) 934 (LIST_LENGTH . select-convert-from-integer)
828 (FILE_NAME . select-convert-from-filename) 935 (CLIENT_WINDOW . select-convert-from-integer)
936 (PROCESS . select-convert-from-integer)
937 (IP_ADDRESS . select-convert-from-ip-address)
938 ;; We go after UTF8_STRING in preference to STRING because Mozilla,
939 ;; at least, does bad things with non-Latin-1 Unicode characters in
940 ;; STRING.
941 (UTF8_STRING . select-convert-from-utf-8-text)
829 (CF_TEXT . select-convert-from-cf-text) 942 (CF_TEXT . select-convert-from-cf-text)
830 (CF_UNICODETEXT . select-convert-from-cf-unicodetext) 943 (CF_UNICODETEXT . select-convert-from-cf-unicodetext)
944 (text/html . select-convert-from-utf-16-le-text) ; Mozilla
945 (text/_moz_htmlcontext . select-convert-from-utf-16-le-text)
946 (text/_moz_htmlinfo . select-convert-from-utf-16-le-text)
947 (image/png . select-convert-from-image/png)
948 (image/gif . select-convert-from-image/gif)
949 (image/jpeg . select-convert-from-image/jpeg )
950 (image/tiff . select-convert-from-image/tiff )
951 (image/xpm . select-convert-from-image/xpm)
952 (image/xbm . select-convert-from-image/xbm)
831 )) 953 ))
832 954
833 ;; Types listed here have special coercion functions that can munge 955 ;; Types listed here have special coercion functions that can munge
834 ;; other types. This can also be used to add special features - e.g. 956 ;; other types. This can also be used to add special features - e.g.
835 ;; being able to pass a region or a cons of markers to own-selection, 957 ;; being able to pass a region or a cons of markers to own-selection,