[Small-cl-src] "simple" X11 clipboard client

[Christophe Rhodes]

#| 

Howdy,

I found myself wondering how hard it would be to make an X client
which plays nice with select-and-paste (as seen by all the other X
clients out there).  The answer seems to be "quite hard", but here's a
step along the road: a translation of some C test code, yielding a
proof-of-concept clipboard client.  Pastes both to and from the client
work: a paste of text to the client yields printed messages to the
lisp's standard output, and pastes while the client owns PRIMARY
(left-click in the window) cause a silly piece of text to be pasted.

Christophe

|#

-------------- next part --------------
;;; This is a pretty direct translation of the Xlib selection test
;;; program by Tor Andersson found at
;;; <http://ghostscript.com/~tor/repos/Klipp/x11clipboard.c>, with
;;; minor enhancements:
;;;
;;; * gdk requestors apparently unconditionally request UTF8_STRING
;;;   selections without checking the TARGETS list of the selection
;;;   owner -- and apparently even never request anything else.  This
;;;   seems to be in contradiction with the freedesktop.org draft
;;;   specification at
;;;   <http://www.pps.jussieu.fr/~jch/software/UTF8_STRING/UTF8_STRING.text>
;;;   (linked from <http://freedesktop.org/Standards>), but this is
;;;   the real world and we have to live in it.  It would be nice if
;;;   someone in the freedesktop community could resolve this.
;;;
;;; * the original C code, in the XSendEvent call, has an event mask
;;;   of SelectionNotify.  SelectionNotify is not an event mask at
;;;   all, however: but the code works "by accident" because
;;;   SelectionNotify happens to have value 31, which has enough bits
;;;   flipped on that most clients select on at least one of those
;;;   events.  This bug is fixed below.
;;;
;;; 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
;;; translator (Christophe Rhodes, csr21 [at] cam [dot] ac [dot] uk)
;;; are murky, probably depend on jurisdiction, and in addition for
;;; such a small work are essentially trivial.  To set peoples' minds
;;; at ease, Tor wishes this information to be disseminated as widely
;;; as possible.

;;; Copyright (c) 2004, Christophe Rhodes
;;;
;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use, copy,
;;; modify, merge, publish, distribute, sublicense, and/or sell copies
;;; of the Software, and to permit persons to whom the Software is
;;; furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.

(defpackage "CLIPBOARD"
  (:use "CL" "XLIB")
  (:export "MAIN"))

(in-package "CLIPBOARD")

;;; This is "traditional" XLIB style; I don't really know if it's the
;;; best way -- in developing this program, style of XLIB programming
;;; was secondary to achieving First Paste.
(defvar *window*)
(defvar *time*)
(defvar *display*)

(defun ownselect ()
  (format t "~&> set-selection-owner~%") (finish-output)
  (set-selection-owner *display* :primary *window* *time*)
  (unless (eq *window* (selection-owner *display* :primary))
    (write-string "failed to own primary")))

(defun deselect ()
  (format t "~&> unset-selection-owner~%") (finish-output)
  (set-selection-owner *display* :primary nil *time*)
  (unless (eq nil (selection-owner *display* :primary))
    (write-string "failed to disown primary")))

(defun ask-paste ()
  (format t "~&! deleting properties on window~%") (finish-output)
  (delete-property *window* :aeclip-target)
  (delete-property *window* :aeclip-string)
  (delete-property *window* :aeclip-utf8_string)
  (delete-property *window* :aeclip-text)
  (format t "~&> convert-selection TARGETS~%") (finish-output)
  (convert-selection :primary :targets *window* :aeclip-target)
  (format t "~&> convert-selection STRING~%")  (finish-output)
  (convert-selection :primary :string *window* :aeclip-string)
  (format t "~&> convert-selection UTF8_STRING~%") (finish-output)
  (convert-selection :primary :utf8_string *window* :aeclip-utf8_string)
  (format t "~&> convert-selection TEXT~%") (finish-output)
  (convert-selection :primary :text *window* :aeclip-text)
  nil)

(defun recv-paste (property)
  (multiple-value-bind (data name format)
      (get-property *window* property)
    (format t "~&< get-prop ~S " name)
    (case format
      (32 (format t "[~{~S~^,~}]"
                  (mapcar (lambda (x) (atom-name *display* x)) data)))
      (8 (format t "~S" (map 'string 'code-char data)))
      (t (format t "format=~S data=~S" format data)))
    (format t "~%") (finish-output)
    (delete-property *window* property)))

(defun send-copy (selection target property requestor time)
  (case target
    ;; we are being a little liberal in what we accept here: no
    ;; requestor should ask us for a UTF8_STRING selection because we
    ;; don't advertise the capability (see the TARGETS clause below).
    ;; However, Xt-based requestors appear not to query TARGETS,
    ;; instead trying UTF8_STRING, COMPOUND_TEXT and STRING in order;
    ;; Gdk-based requestors don't query TARGETS either, trying just
    ;; UTF8_STRING (and giving up if the selection owner returns a
    ;; null property).  So pretend that we can send UTF8_STRING
    ;; selections.
    ((:string :utf8_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 :button-press :property-change)
              :selection selection :target target :property property :time time
              :event-window requestor :window requestor))

(defun main ()
  (let* ((*display* (open-default-display))
         (screen (display-default-screen *display*))
         (*window*
          (create-window
           :parent (screen-root screen)
           :x 10 :y 10 :width 200 :height 200
           :event-mask (make-event-mask :button-press :property-change))))
    (map-window *window*)
    (display-finish-output *display*)
    (event-case (*display*)
      (:button-press (code time)
        (format t "~&ButtonPress~%") (finish-output)
        (case code
          (1 (setf *time* time) (ownselect))
          (2 (ask-paste))
          (3 (deselect))))
      (:client-message ()
        (format t "~&ClientMessage~%") (finish-output))
      (:selection-clear (selection)
        (format t "~&SelectionClear ~S~%" selection) (finish-output))
      (:selection-notify (selection target property)
        (format t "~&SelectionNotify ~S ~S ~S~%" selection target property)
        (finish-output)
        (unless (eq property nil)
          (recv-paste property))
        (display-finish-output *display*))
      (:selection-request (selection target property requestor time)
        (format t "~&SelectionRequest ~S ~S ~S~%" selection target property)
        (finish-output)
        (send-copy selection target property requestor time)
        (display-finish-output *display*))
      (:property-notify (atom state)
        (format t "~&PropertyNotify ~S ~S~%" atom state) (finish-output)))))