Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

121 lines (112 sloc) 5.573 kB
;;; workarounds for bugs in clx
(in-package :xlib)
;;; SBCL workaround for a clx caching bug. This is taken from portable-clx's display.lisp.
;;; NOTE! The latest clx in Rhodes' repository has fixed this in a far
;;; better way by only caching XIDs created by the client.
;; Define functions to find the CLX data types given a display and resource-id
;; If the data type is being cached, look there first.
#+sbcl
(macrolet ((generate-lookup-functions (useless-name &body types)
`(within-definition (,useless-name generate-lookup-functions)
,@(mapcar
#'(lambda (type)
`(defun ,(xintern 'lookup- type)
(display id)
(declare (type display display)
(type resource-id id))
(declare (clx-values ,type))
,(if (member type +clx-cached-types+)
`(let ((,type (lookup-resource-id display id)))
(cond ((null ,type) ;; Not found, create and save it.
(setq ,type (,(xintern 'make- type)
:display display :id id))
(save-id display id ,type))
;; Found. Check the type
((type? ,type ',type) ,type)
(t
(restart-case
(x-error 'lookup-error
:id id
:display display
:type ',type
:object ,type)
(:one ()
:report "Invalidate this cache entry"
(save-id display id (,(xintern 'make- type) :display display :id id)))
(:all ()
:report "Invalidate all display cache"
(clrhash (display-resource-id-map display))
(save-id display id (,(xintern 'make- type) :display display :id id)))))))
;; Not being cached. Create a new one each time.
`(,(xintern 'make- type)
:display display :id id))))
types))))
(generate-lookup-functions ignore
drawable
window
pixmap
gcontext
cursor
colormap
font))
;;; Both clisp and SBCL can't handle incompliant (and in clisp's case,
;;; even compliant) wm-class strings. See test-wm-class in test-wm.lisp.
#+sbcl
(defun get-wm-class (window)
(declare (type window window))
(declare (clx-values (or null name-string) (or null class-string)))
(let ((value (get-property window :WM_CLASS :type :STRING :result-type '(vector card8))))
(declare (type (or null (vector card8)) value))
(when value
;; Buggy clients may not comply with the format, so deal with
;; the unexpected.
(let* ((first-zero (position 0 (the (vector card8) value)))
(second-zero (and first-zero
(position 0 (the (vector card8) value) :start (1+ first-zero))))
(name (subseq (the (vector card8) value) 0 first-zero))
(class (and first-zero
(subseq (the (vector card8) value) (1+ first-zero) second-zero))))
(values (and (plusp (length name)) (map 'string #'card8->char name))
(and (plusp (length class)) (map 'string #'card8->char class)))))))
#+clisp
(defun get-wm-class (window)
(let ((value (get-property window :WM_CLASS :type :STRING :result-type 'string :transform #'card8->char)))
(when value
;; Buggy clients may not comply with the format, so deal with
;; the unexpected.
(let* ((first-zero (position (load-time-value (card8->char 0)) (the string value)))
(second-zero (and first-zero
(position (load-time-value (card8->char 0)) (the string value) :start (1+ first-zero))))
(name (subseq (the string value) 0 first-zero))
(class (and first-zero
(subseq (the string value) (1+ first-zero) second-zero))))
(values (and (plusp (length name)) name)
(and (plusp (length class)) class))))))
#+clisp
(when (fboundp '%gcontext-key->mask)
(defmacro WITH-GCONTEXT ((gcontext &rest options) &body body)
(let ((saved (gensym)) (gcon (gensym)) (g0 (gensym)) (g1 (gensym))
(comps 0)
(setf-forms nil)
dashes? clip-mask?)
(do ((q options (cddr q)))
((null q))
(cond ((eq (car q) :dashes) (setf dashes? t))
((eq (car q) :clip-mask) (setf clip-mask? t)))
(setf comps (logior comps (%gcontext-key->mask (car q)))
setf-forms (nconc setf-forms
(list (list (find-symbol (ext:string-concat "GCONTEXT-" (symbol-name (car q))) :xlib)
gcon)
(cadr q)))))
`(LET* ((,gcon ,gcontext)
(,saved (%SAVE-GCONTEXT-COMPONENTS ,gcon ,comps))
,@(if dashes? (list `(,g0 (GCONTEXT-DASHES ,gcon))))
,@(if clip-mask? (list `(,g1 (GCONTEXT-CLIP-MASK ,gcon)))))
(UNWIND-PROTECT
(PROGN
(SETF ,@setf-forms)
,@body)
(PROGN
(%RESTORE-GCONTEXT-COMPONENTS ,gcon ,saved)
,@(if dashes? (list `(SETF (GCONTEXT-DASHES ,gcon) ,g0)))
,@(if clip-mask? (list `(SETF (GCONTEXT-CLIP-MASK ,gcon) ,g1)))))))))
Jump to Line
Something went wrong with that request. Please try again.