Mercurial > hg > xemacs-beta

comparison lisp/select.el @ 5473:ac37a5f7e5be

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 17 Mar 2011 23:42:59 +0100
parents 0af042a0c116 ed74d2ca7082
children 5273dd66a1ba
comparison
equal deleted inserted replaced
5472:e79980ee5efe 5473:ac37a5f7e5be
34 ;; We prefer UTF8_STRING to COMPOUND_TEXT because, even though the latter 34 ;; We prefer UTF8_STRING to COMPOUND_TEXT because, even though the latter
35 ;; gives us more information when taking data from other XEmacs invocations, 35 ;; gives us more information when taking data from other XEmacs invocations,
36 ;; Mozilla will happily give us broken COMPOUND_TEXT where a non-broken 36 ;; Mozilla will happily give us broken COMPOUND_TEXT where a non-broken
37 ;; UTF8_STRING is available. 37 ;; UTF8_STRING is available.
38 (defvar selection-preferred-types 38 (defvar selection-preferred-types
39 (let ((res '(UTF8_STRING COMPOUND_TEXT STRING image/png image/gif 39 `(UTF8_STRING ,@(and (featurep 'mule) '(COMPOUND_TEXT)) STRING
40 image/jpeg image/tiff image/xpm image/xbm))) 40 ,@(mapcan #'(lambda (format)
41 (unless (featurep 'mule) (delq 'COMPOUND_TEXT res)) 41 (and (featurep format)
42 res) 42 (list (intern (format "image/%s" format)))))
43 '(png gif jpeg tiff xpm xbm)))
43 "An ordered list of X11 type atoms for selections we want to receive. 44 "An ordered list of X11 type atoms for selections we want to receive.
44 We prefer UTF8_STRING over COMPOUND_TEXT, for compatibility with a certain 45 We prefer UTF8_STRING over COMPOUND_TEXT, for compatibility with a certain
45 widely-used browser suite, and COMPOUND_TEXT over STRING. (COMPOUND_TEXT 46 widely-used browser suite, and COMPOUND_TEXT over STRING. (COMPOUND_TEXT
46 isn't available on non-Mule.) We also accept several image types. 47 isn't available on non-Mule.) We also accept several image types.
47 48
272 ;; Note that it is possible for the region to be in the "active" state 273 ;; Note that it is possible for the region to be in the "active" state
273 ;; and not be hilighted, if it is in the active state and then some other 274 ;; and not be hilighted, if it is in the active state and then some other
274 ;; application asserts the selection. This is probably not a big deal. 275 ;; application asserts the selection. This is probably not a big deal.
275 276
276 (defun activate-region-as-selection () 277 (defun activate-region-as-selection ()
277 (cond ((and-fboundp #'mouse-track-rectangle-p 278 (cond ((and-fboundp 'mouse-track-rectangle-p
278 (mouse-track-rectangle-p 279 (mouse-track-rectangle-p
279 (mouse-track-activate-rectangular-selection)))) 280 (mouse-track-activate-rectangular-selection))))
280 ((marker-buffer (mark-marker t)) 281 ((marker-buffer (mark-marker t))
281 (own-selection (cons (point-marker t) (mark-marker t)))))) 282 (own-selection (cons (point-marker t) (mark-marker t))))))
282 283
344 ;; the extent (the visual indication), and the region between point 345 ;; the extent (the visual indication), and the region between point
345 ;; and mark (the actual selection value) become different! 346 ;; and mark (the actual selection value) become different!
346 (set-extent-property previous-extent 'end-open nil) 347 (set-extent-property previous-extent 'end-open nil)
347 348
348 (cond 349 (cond
349 ((and-fboundp #'mouse-track-rectangle-p 350 ((and-fboundp 'mouse-track-rectangle-p
350 (mouse-track-rectangle-p 351 (mouse-track-rectangle-p
351 (setq previous-extent (list previous-extent)) 352 (setq previous-extent (list previous-extent))
352 (default-mouse-track-next-move-rect start end previous-extent) 353 (default-mouse-track-next-move-rect start end previous-extent)
353 )))) 354 ))))
354 previous-extent)))) 355 previous-extent))))
375 (marker-buffer (cdr data))) 376 (marker-buffer (cdr data)))
376 (buffer-live-p (marker-buffer (car data))) 377 (buffer-live-p (marker-buffer (car data)))
377 (buffer-live-p (marker-buffer (cdr data)))))) 378 (buffer-live-p (marker-buffer (cdr data))))))
378 379
379 (defun cut-copy-clear-internal (mode) 380 (defun cut-copy-clear-internal (mode)
380 (or (memq mode '(cut copy clear)) (error "unkown mode %S" mode)) 381 (or (memq mode '(cut copy clear)) (error "unknown mode %S" mode))
381 (or (selection-owner-p) 382 (or (selection-owner-p)
382 (error "XEmacs does not own the primary selection")) 383 (error "XEmacs does not own the primary selection"))
383 (setq last-command nil) 384 (setq last-command nil)
384 (or primary-selection-extent 385 (or primary-selection-extent
385 (error "the primary selection is not an extent?")) 386 (error "the primary selection is not an extent?"))
773 (set-extent-property extent 'duplicable t) 774 (set-extent-property extent 'duplicable t)
774 (set-extent-property extent 'atomic t) 775 (set-extent-property extent 'atomic t)
775 (set-extent-end-glyph extent glyph) 776 (set-extent-end-glyph extent glyph)
776 str))) 777 str)))
777 778
778 ;; Could automate defining these functions these with a macro, but damned if 779 (macrolet
779 ;; I can get that to work. Anyway, this is more readable. 780 ((create-image-functions (&rest formats)
780 781 (cons
781 (defun select-convert-from-image/gif (selection type value) 782 'progn
782 (if (featurep 'gif) (select-convert-from-image-data 'gif value))) 783 (mapcar
783 784 #'(lambda (format)
784 (defun select-convert-from-image/jpeg (selection type value) 785 `(if (featurep ',format)
785 (if (featurep 'jpeg) (select-convert-from-image-data 'jpeg value))) 786 (defalias (intern (concat "select-convert-from-image/"
786 787 ,(symbol-name format)))
787 (defun select-convert-from-image/png (selection type value) 788 #'(lambda (selection type value)
788 (if (featurep 'png) (select-convert-from-image-data 'png value))) 789 (select-convert-from-image-data ',format
789 790 value))))) formats))))
790 (defun select-convert-from-image/tiff (selection type value) 791 (create-image-functions gif jpeg png tiff xpm xbm))
791 (if (featurep 'tiff) (select-convert-from-image-data 'tiff value)))
792
793 (defun select-convert-from-image/xpm (selection type value)
794 (if (featurep 'xpm) (select-convert-from-image-data 'xpm value)))
795
796 (defun select-convert-from-image/xbm (selection type value)
797 (if (featurep 'xbm) (select-convert-from-image-data 'xbm value)))
798 792
799 ;;; CF_xxx conversions 793 ;;; CF_xxx conversions
800 (defun select-convert-from-cf-text (selection type value) 794 (defun select-convert-from-cf-text (selection type value)
801 (if (find-coding-system 'mswindows-multibyte) 795 (if (find-coding-system 'mswindows-multibyte)
802 (let ((value (decode-coding-string value 'mswindows-multibyte))) 796 (let ((value (decode-coding-string value 'mswindows-multibyte)))
927 (CF_UNICODETEXT . select-convert-to-cf-unicodetext) 921 (CF_UNICODETEXT . select-convert-to-cf-unicodetext)
928 )) 922 ))
929 923
930 ;; Types listed here can be selections foreign to XEmacs 924 ;; Types listed here can be selections foreign to XEmacs
931 (setq selection-converter-in-alist 925 (setq selection-converter-in-alist
932 '(; Specific types that get handled by generic converters 926 `(; Specific types that get handled by generic converters
933 (INTEGER . select-convert-from-integer) 927 (INTEGER . select-convert-from-integer)
934 (TIMESTAMP . select-convert-from-integer) 928 (TIMESTAMP . select-convert-from-integer)
935 (LENGTH . select-convert-from-integer) 929 (LENGTH . select-convert-from-integer)
936 (LIST_LENGTH . select-convert-from-integer) 930 (LIST_LENGTH . select-convert-from-integer)
937 (CLIENT_WINDOW . select-convert-from-integer) 931 (CLIENT_WINDOW . select-convert-from-integer)
944 (CF_TEXT . select-convert-from-cf-text) 938 (CF_TEXT . select-convert-from-cf-text)
945 (CF_UNICODETEXT . select-convert-from-cf-unicodetext) 939 (CF_UNICODETEXT . select-convert-from-cf-unicodetext)
946 (text/html . select-convert-from-utf-16-le-text) ; Mozilla 940 (text/html . select-convert-from-utf-16-le-text) ; Mozilla
947 (text/_moz_htmlcontext . select-convert-from-utf-16-le-text) 941 (text/_moz_htmlcontext . select-convert-from-utf-16-le-text)
948 (text/_moz_htmlinfo . select-convert-from-utf-16-le-text) 942 (text/_moz_htmlinfo . select-convert-from-utf-16-le-text)
949 (image/png . select-convert-from-image/png) 943 ,@(loop
950 (image/gif . select-convert-from-image/gif) 944 for format in '(gif jpeg png tiff xpm xbm)
951 (image/jpeg . select-convert-from-image/jpeg ) 945 nconc (if (featurep format)
952 (image/tiff . select-convert-from-image/tiff ) 946 (list (cons (intern (format "image/%s" format))
953 (image/xpm . select-convert-from-image/xpm) 947 (intern (format "select-convert-from-image/%s"
954 (image/xbm . select-convert-from-image/xbm) 948 format))))))))
955 ))
956 949
957 ;; Types listed here have special coercion functions that can munge 950 ;; Types listed here have special coercion functions that can munge
958 ;; other types. This can also be used to add special features - e.g. 951 ;; other types. This can also be used to add special features - e.g.
959 ;; being able to pass a region or a cons of markers to own-selection, 952 ;; being able to pass a region or a cons of markers to own-selection,
960 ;; but getting the *current* text in the region back when calling 953 ;; but getting the *current* text in the region back when calling