[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Low-level CLX tests

To: cl-windows@sail.stanford.edu
Subject: Low-level CLX tests
From: Timothy.Freeman@PROOF.ERGO.CS.CMU.EDU
Date: Tue, 26 Sep 89 17:17:33 EDT
Reply-to: Tim Freeman <tsf@CS.CMU.EDU>
Here's some simple CLX test cases I came up with while trying to
understand how CLX works and to check that my window manager and CLX
implementation behaved reasonably.  I haven't made a test case that
does anything with color correctly yet, I'd appreciate receiving one.

This code is in the public domain.

;;; -*- Mode: Lisp; Package: xlib -*-
;;;
;;; Trivial test file for clx.
;;;
;;; Author: Timothy Freeman.  Last Modified Sat Aug 26 02:55:58 1989

(in-package :xlib) (use-package :ergolisp)

(export '(clx-test))

(defun clx-test (host)
  "Do something, anything, to check that this software works at least a little bit."
  (let* ((display (open-display host))
	 (screen (display-default-screen display))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 0 :y 0 :width 100 :height 100
			     :event-mask
			     '(:exposure :key-press)))
	 (gcontext (create-gcontext :drawable root :function boole-c1
				    :foreground 1 :background 0)))
    (map-window win)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 (:exposure (window)
		  (draw-line win gcontext 0 0 100 100))
		 (:key-press ()
		  t))
	   (return (values))))
      (close-display display))))

(defun cursor-test (host &optional (cursornum 0))
  (let* ((display (open-display host))
	 (screen (display-default-screen display))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 0 :y 0 :width 100 :height 100
			     :event-mask
			     '(:exposure :key-press :button-press)
			     :background 1))
	 (letter-font (open-font display "vtsingle"))
	 (gcontext (create-gcontext :drawable root :function boole-c1
				    :foreground 1 :background 0
				    :font letter-font))
	 (cursor-font (open-font display "cursor")))
    (labels ((setf-cursornum (value)
	       (setq cursornum value)
	       (clear-area win)
	       (draw-glyphs win gcontext 0 40 (format nil "~s" cursornum))
	       (values)))
      (map-window win)
      (unwind-protect
	  (loop
	   (when (event-case (display :discard-p t)
		   (:key-press ()
			       t)
		   (:button-press
		    (code)
		    (cond
		     ((= code 1) (setq cursornum (+ cursornum 2)))
		     ((= code 3) (setq cursornum (- cursornum 2))))
		    (setf-cursornum (min 254 (max 0 cursornum)))
		    (let ((cursor
			   (create-glyph-cursor
			    :source-font cursor-font
			    :source-char cursornum
			    :mask-font cursor-font
			    :mask-char (1+ cursornum)
			    :foreground
			    (make-color :red 0.0 :green 0.0 :blue 0.0)
			    :background
			    (make-color :red 1.0 :green 1.0 :blue 1.0))))
		      (setf (window-cursor win) cursor)
		      (free-cursor cursor))
		    nil))
	     (return (values))))
	(close-display display)))))

(defun configure-notify-test (host)
  (let* ((display (open-display host))
	 (screen (display-default-screen display))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 0 :y 0 :width 100 :height 100
			     :event-mask
			     '(:exposure :key-press
					 :button-press
					 :structure-notify)))
	 (gcontext (create-gcontext :drawable root :function boole-c1
				    :foreground 1 :background 0)))
    (map-window win)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 (:key-press (window)
			     (with-state (window)
					 (setf (drawable-width window) 100)
					 (setf (drawable-height
						window) 100))
			     nil)
		 (:button-press (window)
				t)
		 (:exposure (x y width height count)
		  (format t "Exposure, x = ~s, y = ~s, width = ~s, ~
                             height = ~s, count = ~s.~%"
			  x y width height count)
		  nil)
		 (:configure-notify (x y width height window
				       override-redirect-p)
		  (format t "Configure-notify, x = ~s, y = ~s, width = ~s, ~
                             height = ~s, override = ~s, window = ~s.~%"
			  x y width height override-redirect-p window)
		  nil))
	   (return (values))))
      (close-display display))))

#|
(subwin-test "k.ergo.cs.cmu.edu")
|#

(defun subwin-test (host)
  "Test that if X is a subwindow of Y and the mouse is in X and Y is unmapped,
X gets a leave-window event.  This was a bug in X10.  You'll have to
interrupt to get out of this function.

This function shows the bug has been fixed in X11, our version at least."
  (let* ((display (open-display host))
	 (screen (display-default-screen display))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 0 :y 0 :width 100 :height 100
			     :event-mask
			     '(:leave-window :enter-window)))
	 (win2 (create-window :parent win :x 0 :y 0 :width 50 :height 50
			      :event-mask
			     '(:leave-window :enter-window :key-press
					     :button-press)))
	 (win3 (create-window :parent win2 :x 0 :y 0 :width 25 :height 25
			      :event-mask
			     '(:leave-window :enter-window :key-press
					     :button-press)))
	 (gcontext (create-gcontext :drawable root :function boole-c1
				    :foreground 1 :background 0)))
    (map-window win)
    (map-window win2)
    (map-window win3)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:enter-notify :leave-notify) (event-key x y window)
		  (format t "~s, x = ~s, y = ~s, win = ~s.~%"
			  event-key x y
			  (cond ((eq window win) "win")
				((eq window win2) "win2")
				(t window)))
		  nil)
		 ((:key-press) (window)
		  (unmap-window win)))
	   (return (values))))
      (close-display display))))

(defun resize-test (host)
  "Verify that lowly mortals like me can use ResizeRedirect."
  (let* ((display (open-display host))
	 (screen (display-default-screen display))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 0 :y 0 :width 100 :height 100
			     :border-width 1
			     :event-mask '(:resize-redirect
					   :key-press
					   :button-press
					   :structure-notify)))
	 (gcontext (create-gcontext :drawable root :function boole-c1
				    :foreground 1 :background 0)))
    (map-window win)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:button-press) ()
		  (setf (drawable-width win) 100)
		  (setf (drawable-height win) 100)
		  nil)
		 ((:resize-request) (window width height)
		  (format t "Resize-request, width is ~s, height is ~s.~%"
			  width height)
		  (format t "Real width is ~s, real height is ~s.~%"
			  (drawable-width window)
			  (drawable-height window))
		  (let ((wor (window-override-redirect window)))
		    (setf (window-override-redirect window) :on)
		    (setf (drawable-width window) width)
		    (setf (drawable-height window) height)
		    (setf (window-override-redirect window) wor))
		  (format t "Real width is ~s, real height is ~s.~%"
			  (drawable-width window)
			  (drawable-height window))
		  nil)
		 ((:configure-notify) (width height)
		  (format t "configure-notify, width is ~s, height is ~s.~%"
			  width height)
		  nil)
		 ((:key-press) ()
		  (unmap-window win)
		  t))
	   (return (values))))
      (close-display display))))

#|
(title-test "k.ergo.cs.cmu.edu")
|#
(defun title-test (host)
  (let* ((display (open-display host))
	 (screen (display-default-screen display))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 0 :y 0 :width 100 :height 100
			     :border-width 1
			     :event-mask '(:key-press
					   :button-press))))
    (setf (wm-name win) "Tim's window")
    (setf (wm-icon-name win) "Tim's icon")
    (map-window win)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:button-press :key-press) (window)
		  (destroy-window window)
		  t))
	   (return (values))))
      (close-display display))))

#|
(position-test "k.ergo.cs.cmu.edu")
|#
;;; Conclusion:  For twm, wm-normal-hints is useless.  The position
;;; and size are adjustable when the window is mapped iff the x and y
;;; are 0 and they aren't otherwise.
(defun position-test (host)
  (let* ((display (open-display host))
	 (screen (display-default-screen display))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 100 :y 0 :width 100 :height 100
			     :border-width 1
			     :event-mask '(:key-press
					   :button-press)))
	 (size-hints (make-wm-size-hints :user-specified-position-p nil
					 :user-specified-size-p nil
					 :width 300
					 :height 400
					 )))
    (setf (wm-normal-hints win) size-hints)
    (map-window win)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:button-press :key-press) (window)
		  (destroy-window window)
		  t))
	   (return (values))))
      (close-display display))))

;;; Does the size that TWM uses depend on the size when the window was
;;; created or the size when it's mapped?
;;; Conclusion: it uses the size when created.  It even ignores
;;; resizes to the window after it is mapped unless there is a sleep
;;; between mapping and resizing.
#|
(twm-size-test "k.ergo.cs.cmu.edu")
|#
(defun twm-size-test (host)
  (let* ((display (open-display host))
	 (screen (display-default-screen display))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 100 :y 0 :width 100 :height 100
			     :border-width 1
			     :event-mask '(:key-press
					   :button-press))))
    (setf (drawable-width win) 400)
    (setf (drawable-height win) 400)
    (format t "Width is ~s.~%" (drawable-width win))
    (map-window win)
    (display-finish-output display)
    (setf (drawable-width win) 400)
    (setf (drawable-height win) 400)
    (display-force-output display)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:button-press :key-press) (window)
		  (destroy-window window)
		  t))
	   (return (values))))
      (close-display display))))

;;; Try out the colormap stuff.  As a first attempt, I'll try doing
;;; the straightforward protocol requests instead of following the ICCCM.
;;; This doesn't work.
#|
(colormap-test "batcomputer.ergo.cs.cmu.edu" 1)
|#
(defun colormap-test (host &optional (screennum 0))
  (let* ((display (open-display host))
	 (screen (nth screennum (display-roots display)))
	 (root (screen-root screen))
	 (colormap (create-colormap (window-visual root) root nil))
	 (pixel (elt (alloc-color-cells colormap 1) 0))
	 (gcontext (create-gcontext :drawable root :function boole-c1
				    :foreground pixel :background 0))
	 (win (create-window :parent root :x 100 :y 0 :width 100 :height 100
			     :border-width 1
			     :colormap colormap
			     :event-mask '(:key-press
					   :button-press
					   :exposure))))
    (format t "Pixel is ~s.~%" pixel)
    (display-force-output display)
    (store-colors colormap `(,pixel "Green"))
    (map-window win)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:button-press :key-press) (window)
		  (destroy-window window)
		  t)
		 ((:exposure) (window)
		  (draw-line window gcontext 0 0 100 100)))
	   (return (values))))
      (close-display display))))

(defun colormap-test (host &optional (screennum 0))
  (let* ((display (open-display host))
	 (screen (nth screennum (display-roots display)))
	 (root (screen-root screen))
	 (colormap (create-colormap (window-visual root) root nil))
	 (pixel (elt (alloc-color-cells colormap 1) 0))
	 (gcontext (create-gcontext :drawable root :function boole-c1
				    :foreground pixel :background 0))
	 (win (create-window :parent root :x 100 :y 0 :width 100 :height 100
			     :border-width 1
			     :colormap colormap
			     :event-mask '(:key-press
					   :button-press
					   :exposure))))
    (format t "Pixel is ~s.~%" pixel)
    (display-force-output display)
    (store-colors colormap `(,pixel "Green"))
    (map-window win)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:button-press :key-press) (window)
		  (destroy-window window)
		  t)
		 ((:exposure) (window)
		  (draw-line window gcontext 0 0 100 100)))
	   (return (values))))
      (close-display display))))

;;; Or maybe I should modify the root's colormap?
#|
(colormap-test-2 "batcomputer.ergo.cs.cmu.edu" 1)
|#
(defun colormap-test-2 (host &optional (screennum 0))
  (let* ((display (open-display host))
	 (screen (nth screennum (display-roots display)))
	 (root (screen-root screen))
	 (colormap (prog1 (window-colormap root) (display-finish-output display)))
	 (foo (prog1 (lookup-color colormap "green") (display-finish-output display)))
	 (pixel (elt (alloc-color-cells colormap 1) 0))
	 (gcontext (create-gcontext :drawable root :function boole-c1
				    :foreground pixel :background 0))
	 (win (create-window :parent root :x 100 :y 0 :width 100 :height 100
			     :border-width 1
			     :colormap colormap
			     :event-mask '(:key-press
					   :button-press
					   :exposure))))
    (display-finish-output display)
    (store-colors colormap `(,pixel ,(make-color :red 0.0 :green 1.0 :blue 1.0)))
    (display-finish-output display)
    (map-window win)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:button-press :key-press) (window)
		  (destroy-window window)
		  t)
		 ((:exposure) (window)
		  (draw-line window gcontext 0 0 100 100)))
	   (return (values))))
      (close-display display))))


#|
(transient-test "k.ergo.cs.cmu.edu")
|#
;;; Does WM_TRANSIENT_FOR really work?  Yup.
(defun transient-test (host &optional (screennum 0))
  (let* ((display (open-display host))
	 (screen (nth screennum (display-roots display)))
	 (root (screen-root screen))
	 (win (create-window :parent root :x 100 :y 0 :width 100 :height 100
			     :border-width 1
			     :event-mask '(:key-press
					   :button-press
					   :button-release)))
	 (menu (create-window :parent root :x 10 :y 10 :width 50 :height 50
			      :border-width 1
			      :event-mask '(:button-release))))
    (map-window win)
;    (setf (transient-for menu) win)
    (setf (transient-for menu) root)
    (unwind-protect
	(loop
	 (when (event-case (display :discard-p t)
		 ((:button-press) (window)
		  (when (eq window win) (map-window menu)))
		 ((:button-release) (window)
		  (unmap-window menu))
		 ((:key-press) (window)
		  (destroy-window window)
		  (destroy-window menu)
		  t))
	   (return (values))))
      (close-display display))))
Prev by Date: Re: Questions about CLX?
Next by Date: Please add to mailing list
Previous by thread: Re: Questions about CLX?
Next by thread: Please add to mailing list
Index(es):
- Date
- Thread