;;; xlib-testing.el --- Testing suite for xlib.

;; Copyright (C) 2004,2005 by XWEM Org.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: Thu Nov 25 15:34:59 MSK 2004
;; Keywords: xlib
;; X-CVS: $Id: xlib-testing.el,v 1.4 2005-04-04 19:55:29 lg Exp $

;; This file is part of XEmacs.

;; XEmacs 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, or (at your option)
;; any later version.

;; XEmacs 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 XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; 

;;; Code:

(require 'itimer)
(require 'xlib-xlib)


(defvar xt-dpy-host "127.0.0.1:0")
(defvar xt-dpy nil)
(defvar xt-tmp-res nil)

(defvar xt-test-routines '(xt-XOpenDisplay
                           xt-XCreateWindow xt-XDestroyWindow
                           xt-XAllocNamedColor xt-XFreeColors
                           xt-XCreateGC xt-XMapWindow
                           xt-XDrawingStuff xt-XErrorHandling
                           xt-XCloseDisplay))


(defun xt-error-handler (xdpy xerr)
  (error "xtesting XError %d [%d(%S)/%d], os/ds=%d/%d"
         (X-Event-xerror-code xerr)
         (X-Event-xerror-maj-op xerr)
         (cdr (assq (X-Event-xerror-maj-op xerr) xlib-opcodes-alist))
         (X-Event-xerror-min-op xerr)
         (X-Event-seq xerr)
         (X-Dpy-rseq-id xt-dpy)))

(defun xt-XOpenDisplay ()
  (setq xt-dpy (XOpenDisplay xt-dpy-host))
  (when (X-Dpy-p xt-dpy)
    (pushnew 'xt-error-handler (X-Dpy-error-hooks xt-dpy)))
  (if (X-Dpy-p xt-dpy) 'ok 'fail))

(defun xt-XCloseDisplay ()
  (XCloseDisplay xt-dpy)
  (setq xt-dpy nil)
  'ok)

(defun xt-XCreateWindow ()
  (setq xt-tmp-res (XCreateWindow xt-dpy nil 0 0 200 200
                                  20 nil nil nil
                                  (make-X-Attr :override-redirect t
                                               :background-pixel (XWhitePixel xt-dpy)
                                               :border-pixel (XBlackPixel xt-dpy)
                                               :event-mask 0)))
  (if (X-Win-p xt-tmp-res)
      'ok
    'fail))

(defun xt-XDestroyWindow ()
  (XDestroyWindow xt-dpy xt-tmp-res)
  (XFlush xt-dpy)
  'ok)

(defun xt-XAllocNamedColor ()
  (setq xt-tmp-res (XAllocNamedColor xt-dpy (XDefaultColormap xt-dpy) "Red"
                                     (make-X-Color)))
  (if (X-Color-p xt-tmp-res)
      'ok
    'fail))

(defun xt-XFreeColors ()
  (XFreeColors xt-dpy (XDefaultColormap xt-dpy)
               (list xt-tmp-res) nil)
  (XFlush xt-dpy)
  'ok)

(defun xt-XCreateGC ()
  (xt-XAllocNamedColor)
  (setq xt-tmp-res
        (XCreateGC xt-dpy (XDefaultRootWindow xt-dpy)
                   (make-X-Gc :dpy xt-dpy
                              :id (X-Dpy-get-id xt-dpy)
                              :foreground xt-tmp-res
                              :background (XWhitePixel xt-dpy)
                              :line-style X-LineSolid
                              :line-width 1)))
  (if (X-Gc-p xt-tmp-res)
      'ok
    'fail))

(defun xt-XMapWindow ()
  (xt-XCreateWindow)
  (XMapWindow xt-dpy xt-tmp-res)
  (xt-XDestroyWindow)
  (XFlush xt-dpy)
  'ok)

(defun xt-XDrawingStuff ()
  (xt-XCreateGC)

  (XDrawLine xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 5 5 100 50)
  (XDrawPoint xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 20 5)
  (XFillRectangle xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 2 38 38 15)
  (XDrawRectangle xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 2 38 38 15)
  (XDrawString xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 5 50 "HELLO!")
  (XDrawSegments xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res (list (cons '(100 . 0) '(50 . 10))
				      (cons '(100 . 100) '(50 . 90))))
  (XDrawArc xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 50 50 20 20 0 360)
  (XFillArc xt-dpy (XDefaultRootWindow xt-dpy) xt-tmp-res 55 55 10 10 0 360)
  (XFlush xt-dpy)
  'ok)

(defun xt-XErrorHandling ()
  (XGetWMName xt-dpy (make-X-Win :id 77777.0))
  (XFlush xt-dpy)
  'ok)

;;;###autoload
(defun xt-check-xlib ()
  "Interactively check xlib."
  (interactive)

  (setq xt-dpy-host
        (read-string "XT Host [127.0.0.1:0]: "))
  (when (string= xt-dpy-host "")
    (setq xt-dpy-host "127.0.0.1:0"))
        
  (with-current-buffer (get-buffer-create "*xt-check-xlib*")
    (erase-buffer)
    (display-buffer (current-buffer))

    (insert "===> BEGIN at " (format-time-string "%R %S")
            "\n")
    (let ((X-default-timeout 2.5))        ; 2 seconds
      (mapc #'(lambda (r)
                (let (begtime endtime result)
                  (condition-case err
                      (setq begtime (current-time)
                            result (funcall r)
                            endtime (current-time))
                    (t (setq result (cons 'error err))))
                  (insert (format "%s ... %f %S" (substring (symbol-name r) 3)
                                  (itimer-time-difference (or endtime (current-time))
                                                          (or begtime (current-time)))
                                  result)
                          "\n")))
            xt-test-routines))
    (insert "<=== DONE at " (format-time-string "%R %S")
            "\n")))


(provide 'xlib-testing)

;;; xlib-testing.el ends here