cgit.sxemacs.org Git - packages/blob - xemacs-packages/xlib/lisp/xlib-testing.el

   1 ;;; xlib-testing.el --- Testing suite for xlib.
   2
   3 ;; Copyright (C) 2004,2005 by XWEM Org.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Created: Thu Nov 25 15:34:59 MSK 2004
   7 ;; Keywords: xlib
   8 ;; X-CVS: $Id: xlib-testing.el,v 1.4 2005-04-04 19:55:29 lg Exp $
   9
  10 ;; This file is part of XEmacs.
  11
  12 ;; XEmacs is free software; you can redistribute it and/or modify it
  13 ;; under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; XEmacs is distributed in the hope that it will be useful, but
  18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 ;; General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  25 ;; 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF
  28
  29 ;;; Commentary:
  30
  31 ;;
  32
  33 ;;; Code:
  34 \f
  35 (require 'itimer)
  36 (require 'xlib-xlib)
  37
  38 \f
  39 (defvar xt-dpy-host "127.0.0.1:0")
  40 (defvar xt-dpy nil)
  41 (defvar xt-tmp-res nil)
  42
  43 (defvar xt-test-routines '(xt-XOpenDisplay
  44                            xt-XCreateWindow xt-XDestroyWindow
  45                            xt-XAllocNamedColor xt-XFreeColors
  46                            xt-XCreateGC xt-XMapWindow
  47                            xt-XDrawingStuff xt-XErrorHandling
  48                            xt-XCloseDisplay))
  49
  50 \f
  51 (defun xt-error-handler (xdpy xerr)
  52   (error "xtesting XError %d [%d(%S)/%d], os/ds=%d/%d"
  53          (X-Event-xerror-code xerr)
  54          (X-Event-xerror-maj-op xerr)
  55          (cdr (assq (X-Event-xerror-maj-op xerr) xlib-opcodes-alist))
  56          (X-Event-xerror-min-op xerr)
  57          (X-Event-seq xerr)
  58          (X-Dpy-rseq-id xt-dpy)))
  59
  60 (defun xt-XOpenDisplay ()
  61   (setq xt-dpy (XOpenDisplay xt-dpy-host))
  62   (when (X-Dpy-p xt-dpy)
  63     (pushnew 'xt-error-handler (X-Dpy-error-hooks xt-dpy)))
  64   (if (X-Dpy-p xt-dpy) 'ok 'fail))
  65
  66 (defun xt-XCloseDisplay ()
  67   (XCloseDisplay xt-dpy)
  68   (setq xt-dpy nil)
  69   'ok)
  70
  71 (defun xt-XCreateWindow ()
  72   (setq xt-tmp-res (XCreateWindow xt-dpy nil 0 0 200 200
  73                                   20 nil nil nil
  74                                   (make-X-Attr :override-redirect t
  75                                                :background-pixel (XWhitePixel xt-dpy)
  76                                                :border-pixel (XBlackPixel xt-dpy)
  77                                                :event-mask 0)))
  78   (if (X-Win-p xt-tmp-res)
  79       'ok
  80     'fail))
  81
  82 (defun xt-XDestroyWindow ()
  83   (XDestroyWindow xt-dpy xt-tmp-res)
  84   (XFlush xt-dpy)
  85   'ok)
  86
  87 (defun xt-XAllocNamedColor ()
  88   (setq xt-tmp-res (XAllocNamedColor xt-dpy (XDefaultColormap xt-dpy) "Red"
  89                                      (make-X-Color)))
  90   (if (X-Color-p xt-tmp-res)
  91       'ok
  92     'fail))
  93
  94 (defun xt-XFreeColors ()
  95   (XFreeColors xt-dpy (XDefaultColormap xt-dpy)
  96                (list xt-tmp-res) nil)
  97   (XFlush xt-dpy)
  98   'ok)
  99
 100 (defun xt-XCreateGC ()
 101   (xt-XAllocNamedColor)
 102   (setq xt-tmp-res
 103         (XCreateGC xt-dpy (XDefaultRootWindow xt-dpy)
 104                    (make-X-Gc :dpy xt-dpy
 105                               :id (X-Dpy-get-id xt-dpy)
 106                               :foreground xt-tmp-res
 107                               :background (XWhitePixel xt-dpy)
 108                               :line-style X-LineSolid
 109                               :line-width 1)))
 110   (if (X-Gc-p xt-tmp-res)
 111       'ok
 112     'fail))
 113
 114 (defun xt-XMapWindow ()
 115   (xt-XCreateWindow)
 116   (XMapWindow xt-dpy xt-tmp-res)
 117   (xt-XDestroyWindow)
 118   (XFlush xt-dpy)
 119   'ok)
 120
 121 (defun xt-XDrawingStuff ()
 122   (xt-XCreateGC)
 123
 124   (XDrawLine xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 5 5 100 50)
 125   (XDrawPoint xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 20 5)
 126   (XFillRectangle xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 2 38 38 15)
 127   (XDrawRectangle xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 2 38 38 15)
 128   (XDrawString xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 5 50 "HELLO!")
 129   (XDrawSegments xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res (list (cons '(100 . 0) '(50 . 10))
 130                                       (cons '(100 . 100) '(50 . 90))))
 131   (XDrawArc xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 50 50 20 20 0 360)
 132   (XFillArc xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 55 55 10 10 0 360)
 133   (XFlush xt-dpy)
 134   'ok)
 135
 136 (defun xt-XErrorHandling ()
 137   (XGetWMName xt-dpy (make-X-Win :id 77777.0))
 138   (XFlush xt-dpy)
 139   'ok)
 140
 141 ;;;###autoload
 142 (defun xt-check-xlib ()
 143   "Interactively check xlib."
 144   (interactive)
 145
 146   (setq xt-dpy-host
 147         (read-string "XT Host [127.0.0.1:0]: "))
 148   (when (string= xt-dpy-host "")
 149     (setq xt-dpy-host "127.0.0.1:0"))
 150
 151   (with-current-buffer (get-buffer-create "*xt-check-xlib*")
 152     (erase-buffer)
 153     (display-buffer (current-buffer))
 154
 155     (insert "===> BEGIN at " (format-time-string "%R %S")
 156             "\n")
 157     (let ((X-default-timeout 2.5))        ; 2 seconds
 158       (mapc #'(lambda (r)
 159                 (let (begtime endtime result)
 160                   (condition-case err
 161                       (setq begtime (current-time)
 162                             result (funcall r)
 163                             endtime (current-time))
 164                     (t (setq result (cons 'error err))))
 165                   (insert (format "%s ... %f %S" (substring (symbol-name r) 3)
 166                                   (itimer-time-difference (or endtime (current-time))
 167                                                           (or begtime (current-time)))
 168                                   result)
 169                           "\n")))
 170             xt-test-routines))
 171     (insert "<=== DONE at " (format-time-string "%R %S")
 172             "\n")))
 173
 174 \f
 175 (provide 'xlib-testing)
 176
 177 ;;; xlib-testing.el ends here