Index: package.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/package.lisp,v retrieving revision 1.48 diff -u -r1.48 package.lisp --- package.lisp 22 Feb 2005 03:14:26 -0000 1.48 +++ package.lisp 11 Mar 2005 15:49:16 -0000 @@ -1988,6 +1988,7 @@ #:text-style-width ;; Text selection protocol #:selection-owner + #:selection-timestamp #:selection-event #:selection-clear-event #:selection-notify-event Index: text-selection.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/text-selection.lisp,v retrieving revision 1.5 diff -u -r1.5 text-selection.lisp --- text-selection.lisp 27 Feb 2005 23:07:36 -0000 1.5 +++ text-selection.lisp 11 Mar 2005 15:49:16 -0000 @@ -244,7 +244,8 @@ :sheet owner :selection :primary)))) (when (bind-selection (port pane) pane (event-timestamp event)) - (setf (selection-owner (port pane)) pane))))) + (setf (selection-owner (port pane)) pane) + (setf (selection-timestamp (port pane)) (event-timestamp event)))))) (defun repaint-markings (pane old-markings new-markings) (let ((old-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) old-markings) Index: Backends/CLX/medium.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp,v retrieving revision 1.66 diff -u -r1.66 medium.lisp --- Backends/CLX/medium.lisp 17 Feb 2005 21:23:29 -0000 1.66 +++ Backends/CLX/medium.lisp 11 Mar 2005 15:49:16 -0000 @@ -690,7 +690,7 @@ ((xlib::index>= i src-end) i) (declare (type xlib:array-index i j)) - (setq char (xlib:char->card8 (char src i))) + (setq char (char-code (char src i))) (if (or (< char min-char-index) (> char max-char-index)) (return i) (setf (aref dst j) char))) @@ -701,7 +701,7 @@ i) (declare (type xlib:array-index i j)) (setq elt (elt src i)) - (when (characterp elt) (setq elt (xlib:char->card8 elt))) + (when (characterp elt) (setq elt (char-code elt))) (if (or (not (integerp elt)) (< elt min-char-index) (> elt max-char-index)) Index: Backends/CLX/port.lisp =================================================================== RCS file: /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp,v retrieving revision 1.108 diff -u -r1.108 port.lisp --- Backends/CLX/port.lisp 27 Feb 2005 23:07:41 -0000 1.108 +++ Backends/CLX/port.lisp 11 Mar 2005 15:49:16 -0000 @@ -165,7 +165,8 @@ (design-cache :initform (make-hash-table :test #'eq)) (pointer :reader port-pointer) (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) - (selection-owner :initform nil :accessor selection-owner))) + (selection-owner :initform nil :accessor selection-owner) + (selection-timestamp :initform nil :accessor selection-timestamp))) (defun parse-clx-server-path (path) (pop path) @@ -1317,16 +1318,18 @@ ;; :TEXT, :STRING ;; ;; :UTF8_STRING -;; As seen from xterm [make that the prefered encoding] +;; As seen from xterm [make that the preferred encoding] ;; ;; :COMPOUND_TEXT ;; Perhaps relatively easy to produce, hard to grok. ;; +;; :TARGETS +;; Clients want legitimately to find out what we support. ;;; Utilities -(defun utf-8-encode (code-points) +(defun utf8-string-encode (code-points) (let ((res (make-array (length code-points) :adjustable t :fill-pointer 0))) @@ -1379,7 +1382,8 @@ (xlib:set-selection-owner (clx-port-display port) :primary nil time) - (setf (selection-owner port) nil)) + (setf (selection-owner port) nil) + (setf (selection-timestamp port) nil)) (defmethod request-selection ((port clx-port) requestor time) (xlib:convert-selection :primary :STRING requestor :bounce time)) @@ -1399,12 +1403,16 @@ ;; Incredibly crappy broken unportable Latin 1 encoder which should be ;; replaced by various implementation-specific versions. -(defun latin1-encode (string) - (delete-if (lambda (x) (or (< x 0) - (> x 255))) - (map 'vector #'char-code string))) +(flet ((latin1-code-p (x) + (not (or (< x 9) (< 10 x 32) (< #x7f x #xa0) (> x 255))))) + (defun string-encode (string) + (delete-if-not #'latin1-code-p (map 'vector #'char-code string))) + (defun exactly-encodable-as-string-p (string) + (every #'latin1-code-p (map 'vector #'char-code string)))) ;; TODO: INCR property? +;; +;; FIXME: per ICCCM we MUST support :MULTIPLE (defmethod send-selection ((port clx-port) (event clx-selection-request-event) string) (let ((requestor (selection-event-requestor event)) (property (selection-event-property event)) @@ -1421,28 +1429,55 @@ target property) (xlib:send-event requestor - :selection-notify nil - :window requestor - :selection :primary - :target target - :property property - :time time))) - (cond ((member target '(:UTF8_STRING :TEXT)) - (xlib:change-property requestor property - (utf-8-encode - (concatenate 'vector (map 'vector #'char-code string))) - :UTF8_STRING - 8) - (send-event :target :UTF8_STRING)) - ((member target '(:STRING :COMPOUND_TEXT)) - (xlib:change-property requestor property - (latin1-encode string) - :COMPOUND_TEXT - 8) - (send-event :target :COMPOUND_TEXT)) - (t - (format *trace-output* - "~&;; Warning, unhandled type \"~A\". Trying to send as UTF8_STRING.~%" - target) - (send-event :target :UTF8_STRING :property nil)))) ;; ... + :selection-notify nil + :window requestor + :event-window requestor + :selection :primary + :target target + :property property + :time time))) + (case target + ((:UTF8_STRING) + (xlib:change-property requestor property + (utf8-string-encode + (map 'vector #'char-code string)) + :UTF8_STRING 8) + (send-event :target :UTF8_STRING)) + ((:STRING :COMPOUND_TEXT) + (xlib:change-property requestor property + (string-encode string) + target 8) + (send-event :target target)) + ((:TEXT) + (cond + ((exactly-encodable-as-string-p string) + (xlib:change-property requestor property + (string-encode string) + :STRING 8) + (send-event :target :STRING)) + (t + (xlib:change-property requestor property + (utf8-string-encode + (map 'vector #'char-code string)) + :UTF8_STRING 8) + (send-event :target :UTF8_STRING)))) + ((:TARGETS) + (let* ((display (clx-port-display port)) + (targets (mapcar (lambda (x) (xlib:intern-atom display x)) + '(:TARGETS :STRING :TEXT :UTF8_STRING + :COMPOUND_TEXT :TIMESTAMP)))) + (xlib:change-property requestor property targets target 32)) + (send-event :target :TARGETS)) + ((:TIMESTAMP) + (when (null (selection-timestamp port)) + (format *trace-output* "~&;; selection-timestamp is null!~%")) + (xlib:change-property requestor property + (list (selection-timestamp port)) + target 32) + (send-event :target :TIMESTAMP)) + (t + (format *trace-output* + "~&;; Warning, unhandled type \"~A\". ~ + Sending property NIL to target.~%" target) + (send-event :target target :property nil)))) (xlib:display-force-output (xlib:window-display requestor))))