more clipboard hacking

--=-=-=

Hi,

I had occasion to flick through ICCCM, and discovered that the
clipboard handling demo program (in demo/clipboard.lisp) wasn't
compliant.  In particular, the code didn't handle the required
targets MULTIPLE and STRING.

The attached patch implements handling of those targets -- in
particular I'd like you to admire what's necessary to support MULTIPLE
-- but in the process of doing that I discovered to my horror that CLX
request functions are mutually non-re-entrant.

This means that code of the form
  (change-property requestor property target '(:targets :string)
                   :transform (lambda (x) (intern-atom *display* x)))
is broken, because if the intern-atom call needs to make a server
request, it will scribble over the buffer that change-property is
building to send to the server.

This was a nasty surprise to me; I thought others might wish to be
advised of this before it bit them too.  Is this documented anywhere?


--=-=-=
Content-Disposition: attachment; filename=clipboard.diff
Content-Description: fix clipboard demo

Index: demo/clipboard.lisp
===================================================================
RCS file: /usr/local/src/cvs/clx/demo/clipboard.lisp,v
retrieving revision 1.2
diff -u -r1.2 clipboard.lisp
--- demo/clipboard.lisp	29 Nov 2004 16:14:05 -0000	1.2
+++ demo/clipboard.lisp	11 Mar 2005 17:22:04 -0000
@@ -26,6 +26,8 @@
 ;;;   with an empty event mask ("2.2 Responsibilities of the Selection
 ;;;   Owner").
 ;;;
+;;; * implemented the ICCCM-required TIMESTAMP and MULTIPLE targets
+;;;
 ;;; As ever with these things, the divisions in intellectual property
 ;;; between the writer of the original C program, Tor Andersson
 ;;; (contactable at tor [dot] andersson [at] gmail [dot] com) and the
@@ -111,22 +113,56 @@
     (delete-property *window* property)))
 
 (defun send-copy (selection target property requestor time)
-  (case target
-    ((:string)
-     (format t "~&> sending text data~%") (finish-output)
-     (change-property requestor property
-                      "Hello, World (from the CLX clipboard)!" target 8
-                      :transform #'char-code))
-    (:targets
-     (format t "~&> sending targets list~%") (finish-output)
-     (change-property requestor property '(:targets :string) target 32
-                      :transform (lambda (x) (intern-atom *display* x))))
-    (t
-     (format t "~&> sending none~%") (finish-output)
-     (setf property nil)))
-  (send-event requestor :selection-notify (make-event-mask)
-              :selection selection :target target :property property :time time
-              :event-window requestor :window requestor))
+  (flet ((send (target property)
+	   (case target
+	     ((:string)
+	      (format t "~&> sending text data~%") (finish-output)
+	      (change-property requestor property
+			       "Hello, World (from the CLX clipboard)!"
+			       target 8
+			       :transform #'char-code)
+	      property)
+	     (:targets
+	      (format t "~&> sending targets list~%") (finish-output)
+	      ;; ARGH.  Can't use :TRANSFORM as we scribble over CLX's buffer.
+	      (let ((targets
+		     (mapcar (lambda (x) (intern-atom *display* x))
+			     '(:targets :timestamp :multiple :string))))
+		(change-property requestor property targets target 32))
+	      property)
+	     (:timestamp
+	      (format t "~&> sending timestamp~%") (finish-output)
+	      (change-property requestor property (list *time*) target 32)
+	      property)
+	     (t
+	      (format t "~&> sending none~%") (finish-output)
+	      nil))))
+    (case target
+      ;; WARNING: this is untested.  I don't know of any clients which
+      ;; use the :MULTIPLE target.
+      (:multiple
+       (let* ((list (get-property requestor property))
+	      (plist (mapcar (lambda (x) (atom-name *display* x)) list)))
+	 (loop for (ptarget pproperty) on plist by #'cddr
+	    with all-succeeded = t
+	    if (send ptarget pproperty)
+	    collect ptarget into result
+	    and collect pproperty into result
+	    else
+	    collect nil into result
+	    and collect pproperty into result
+	    and do (setf all-succeeded nil)
+	    finally (unless all-succeeded
+		      (let ((new-list
+			     (mapcar (lambda (x) (intern-atom *display* x))
+				     result)))
+			(change-property requestor property new-list
+					 target 32))))))
+      (t (setf property (send target property))))
+    (send-event requestor :selection-notify (make-event-mask)
+		:selection selection :target target
+		:property property :time time
+		:event-window requestor :window requestor)))
 
 (defun main ()
   (let* ((*display* (open-default-display))

--=-=-=


Cheers,

Christophe

--=-=-=--

_______________________________________________
Portable-clx mailing list
[email protected]
http://lists.metacircles.com/cgi-bin/mailman/listinfo/portable-clx
cvs -d :ext:cvs.telent.net:/usr/local/src/cvs co clx  # over ssh
cvs -d :pserver:[email protected]:/cvs co clx  # anonymous