x11-screen/x11-screen-check.sh: Test read some X11 properties.

diff --git a/src/x11-screen/Makefile.am b/src/x11-screen/Makefile.am
index 42dce015116e9ec177650074cbe0655093a6e6d6..bacb3241c7ccad46b0ec53e1d823a99e7cc14fd6 100644 (file)
--- a/src/x11-screen/Makefile.am
+++ b/src/x11-screen/Makefile.am
@@ -61,7 +61,7 @@ ETAGS_ARGS = $(sources)
 TAGS_DEPENDENCIES = $(sources)
 
 EXTRA_DIST += $(sources) compile.sh x11-screen.pkg
-EXTRA_DIST += x11-screen-check.sh
+EXTRA_DIST += x11-screen-check.sh x11-screen-test.scm
 EXTRA_DIST += make.scm optiondb.scm
 
 install-data-hook:

diff --git a/src/x11-screen/x11-screen-check.sh b/src/x11-screen/x11-screen-check.sh
index e6f727c39d56ef14c61b6064c0957c62f643ee5f..00ec66b919bf8d2552223d48393327ef5efacb93 100755 (executable)
--- a/src/x11-screen/x11-screen-check.sh
+++ b/src/x11-screen/x11-screen-check.sh
@@ -1,16 +1,21 @@
 #!/bin/sh
+# -*-Scheme-*-
 #
 # Test the X11-SCREEN option.
 
 set -e
 ${MIT_SCHEME_EXE} --prepend-library . <<\EOF
 (begin
-  (load-option 'X11-SCREEN)
-
   (if (let ((display (get-environment-variable "DISPLAY")))
        (or (not (string? display))
            (string-null? display)))
       (warn "DISPLAY not set")
-      (edit))
+      (let ((edwin (->environment '(edwin))))
+       (load-option 'X11-SCREEN)
+       (set! (access os/init-file-name edwin)
+             (let ((pathname (merge-pathnames "x11-screen-test.scm")))
+               (named-lambda (os/init-file-name/x11-screen-test)
+                 pathname)))
+       (edit)))
   )
 EOF

diff --git a/src/x11-screen/x11-screen-test.scm b/src/x11-screen/x11-screen-test.scm
new file mode 100644 (file)
index 0000000..6c2c8ec
--- /dev/null
+++ b/src/x11-screen/x11-screen-test.scm
@@ -0,0 +1,40 @@
+#| -*-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-screen type.
+\f
+(let ((x11s (->environment '(edwin screen x11-screen))))
+  (let ((xterm ((access screen-xterm x11s) (selected-screen)))
+       (xd ((access screen-display x11s) (selected-screen)))
+       (get-xterm-property (access get-xterm-property x11s))
+       (x-atom->symbol (access x-atom->symbol x11s)))
+    (display "WM allowed actions:\n")
+    (pp (vector-map
+        (lambda (atom) (x-atom->symbol xd atom))
+        (get-xterm-property xterm '_NET_WM_ALLOWED_ACTIONS 'atom #f)))
+    (display "WM hints:\n")
+    (pp (get-xterm-property xterm 'WM_HINTS 'wm_hints #f))
+    (display "WM normal hints:\n")
+    (pp (get-xterm-property xterm 'WM_NORMAL_HINTS 'wm_size_hints #f))))
\ No newline at end of file