Skip to content
Snippets Groups Projects
Commit 4095a1b9 authored by csr21's avatar csr21
Browse files

Fix the image test:

Fix the image test:
* don't abuse the "cursor hotspot" fields, which are defined to be
  CARD16 or NULL, for communicating the position of the (sub)image on
  the root window; instead, use the image plist (and adjust as necessary
  if a subimage is copied).
* rather than writing in very very dark red (or blue) on black,
  explicitly ask for white on black.

darcs-hash:20030607090943-ed5a3-65828f7e8c98f4dcaa3d9bdcdb23569a90a16f67.gz
parent 0002e828
No related branches found
No related tags found
No related merge requests found
...@@ -48,8 +48,10 @@ ...@@ -48,8 +48,10 @@
(let* ((screen (display-default-screen display)) (let* ((screen (display-default-screen display))
(window (screen-root screen)) (window (screen-root screen))
(gcontext (create-gcontext (gcontext (create-gcontext
:drawable window :foreground (screen-white-pixel screen)
:font (open-font display "fixed")))) :background (screen-black-pixel screen)
:drawable window
:font (open-font display "fixed"))))
(dotimes (i nimages) (dotimes (i nimages)
(let ((image (image-test-get-image (let ((image (image-test-get-image
window window
...@@ -92,10 +94,8 @@ ...@@ -92,10 +94,8 @@
(image-z :z-pixmap))) (image-z :z-pixmap)))
(image (get-image window :x x :y y :width width :height height (image (get-image window :x x :y y :width width :height height
:format format :result-type result-type))) :format format :result-type result-type)))
;; XCreatePixmapCursor(3X11) says that x,y for hotspot are (setf (getf (image-plist image) :root-x) x)
;; unsigned, so what we're doing here I don't know (setf (getf (image-plist image) :root-y) y)
;;(setf (image-x-hot image) (- x))
;;(setf (image-y-hot image) (- y))
image)) image))
(defun image-test-subimage-parameters (image random-subimage-p) (defun image-test-subimage-parameters (image random-subimage-p)
...@@ -120,6 +120,8 @@ ...@@ -120,6 +120,8 @@
((or image-xy image-z) 'image-x))))) ((or image-xy image-z) 'image-x)))))
(multiple-value-bind (x y width height) (multiple-value-bind (x y width height)
(image-test-subimage-parameters image random-subimage-p) (image-test-subimage-parameters image random-subimage-p)
(incf (getf (image-plist image) :root-x) x)
(incf (getf (image-plist image) :root-y) y)
(copy-image image :x x :y y :width width :height height (copy-image image :x x :y y :width width :height height
:result-type result-type)))) :result-type result-type))))
...@@ -127,8 +129,10 @@ ...@@ -127,8 +129,10 @@
(multiple-value-bind (src-x src-y width height) (multiple-value-bind (src-x src-y width height)
(image-test-subimage-parameters image random-subimage-p) (image-test-subimage-parameters image random-subimage-p)
(let* ((border-width 1) (let* ((border-width 1)
(x (- src-x #+nil (image-x-hot image) border-width)) (root-x (getf (image-plist image) :root-x))
(y (- src-y #+nil (image-y-hot image) border-width))) (root-y (getf (image-plist image) :root-y))
(x (+ src-x root-x (- border-width)))
(y (+ src-y root-y (- border-width))))
(unless (or (zerop width) (zerop height)) (unless (or (zerop width) (zerop height))
(let ((window (let ((window
(create-window (create-window
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment