From e7c34139ecbade34ae4a5538619f764a86c826bd Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 8 Jun 2016 14:57:17 -0700 Subject: [PATCH] x11/x11-check.sh: Test read a 32bit X11 property. --- src/x11/Makefile.am | 2 +- src/x11/x11-check.sh | 24 ++--------- src/x11/x11-test.scm | 96 ++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 101 insertions(+), 21 deletions(-) create mode 100644 src/x11/x11-test.scm diff --git a/src/x11/Makefile.am b/src/x11/Makefile.am index e45dfd57f..b6eda2419 100644 --- a/src/x11/Makefile.am +++ b/src/x11/Makefile.am @@ -104,7 +104,7 @@ ETAGS_ARGS = $(all_sources) -r '/^([^iI].*/' $(cdecls) TAGS_DEPENDENCIES = $(all_sources) $(cdecls) EXTRA_DIST += $(all_sources) $(cdecls) compile.sh x11.pkg -EXTRA_DIST += x11-check.sh +EXTRA_DIST += x11-check.sh x11-test.scm EXTRA_DIST += make.scm optiondb.scm tags-fix.sh install-data-hook: diff --git a/src/x11/x11-check.sh b/src/x11/x11-check.sh index a0f1531f5..0ad83f3ce 100755 --- a/src/x11/x11-check.sh +++ b/src/x11/x11-check.sh @@ -1,33 +1,17 @@ #!/bin/sh +# -*-Scheme-*- # # Test the X11 option. set -e ${MIT_SCHEME_EXE} --prepend-library . <<\EOF (begin - (load-option 'X11) - (if (let ((display (get-environment-variable "DISPLAY"))) (or (not (string? display)) (string-null? display))) (warn "DISPLAY not set") - (let ((dev (make-graphics-device))) - (if (not (eq? 'X11 (graphics-type-name (graphics-type dev)))) - (error "The X11 graphics type is NOT the default.")) - (graphics-draw-point dev 0 .1) - (graphics-draw-point dev 0 .2) - (graphics-draw-point dev 0 .3) - (graphics-erase-point dev 0 .2) - (graphics-draw-text dev 0. .4 "Hello!") - (graphics-draw-line dev -.5 -.5 .5 .5) - (graphics-move-cursor dev -.5 .5) - (graphics-drag-cursor dev .5 -.5) - (display "Waiting for graphics window to close...\n") - (let wait () - (sleep-current-thread 1000) - (if ((access x-window/xw (->environment '(runtime x-graphics))) - (graphics-device/descriptor dev)) - (wait))) - (display "Graphics window closed.\n"))) + (begin + (load-option 'X11) + (load "x11-test.scm" (->environment '(x11))))) ) EOF diff --git a/src/x11/x11-test.scm b/src/x11/x11-test.scm new file mode 100644 index 000000000..d7b3213cc --- /dev/null +++ b/src/x11/x11-test.scm @@ -0,0 +1,96 @@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 + Massachusetts Institute of Technology + +This file is part of an x11 plugin for MIT/GNU Scheme. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; Test the x11 interface. +;;; package: (x11) + +(define (run-tests) + (let ((x11dev (->environment '(x11 device)))) + (let ((x-window/display (access x-window/display x11dev)) + (x-display/window-finalizer (access x-display/window-finalizer + x11dev)) + (x-display/xd (access x-display/xd x11dev)) + (x-window/xw (access x-window/xw x11dev))) + (let* ((dev (make-graphics-device)) + (x-window (graphics-device/descriptor dev)) + (x-display (x-window/display x-window))) + + (if (not (eq? 'X11 (graphics-type-name (graphics-type dev)))) + (error "The X11 graphics type is NOT the default.")) + + (test-graphics dev) + + (test-properties (x-display/xd x-display) + (x-window-id (x-window/xw x-window))) + + (display "Waiting for windows to close...\n") + (let wait () + (sleep-current-thread 1000) + (if (not (null? + (gc-finalizer-elements + (x-display/window-finalizer x-display)))) + (wait))))))) + +(define (test-graphics dev) + (display "Drawing...\n") + (graphics-draw-point dev 0 .1) + (graphics-draw-point dev 0 .2) + (graphics-draw-point dev 0 .3) + (graphics-erase-point dev 0 .2) + (graphics-draw-text dev 0. .4 "Hello!") + (graphics-draw-line dev -.5 -.5 .5 .5) + (graphics-move-cursor dev -.5 .5) + (graphics-drag-cursor dev .5 -.5)) + +(define (test-properties xd window-id) + (display "Getting/putting properties...\n") + + ;; An atom type property. + (let ((property (x-intern-atom xd "_NET_WM_ALLOWED_ACTIONS" #f)) + (type (x-intern-atom xd "ATOM" #f))) + (let ((v (x-get-window-property xd window-id + property 0 0 #f type))) + (let ((bytes-left (vector-ref v 2))) + (let ((v (x-get-window-property xd window-id + property 0 (quotient bytes-left 4) + #f type))) + (let ((bytes-left (vector-ref v 2))) + (if (not (zero? bytes-left)) + (error "Incomplete property read."))) + + (pp (vector-map (lambda (atom) (x-get-atom-name xd atom)) + (vector-ref v 3))))))) + + ;; A short type property should be read and written. + + ;; A char type property should be read and written. + + ;; Each type should be read and written using data larger than + ;; (property-quantum display). (Move the multi-quanta reading [and + ;; writing?] code, e.g. get-window-property, here from + ;; x11-screen.scm?) + ) + +(run-tests) \ No newline at end of file -- 2.25.1