CVS update by lg packages/xemacs-packages/xlib/lisp, xlib-const.el, xlib-keysymdb.el, xlib-tray.el, xlib-xc.el, xlib-xlib.el, xlib-xshape.el ...

User: lg Date: 05/04/04 21:55:33 Modified: packages/xemacs-packages/xlib/lisp xlib-composer.el xlib-const.el xlib-hello.el xlib-img.el xlib-keysymdb.el xlib-math.el xlib-testing.el xlib-tray.el xlib-version.el xlib-vidmode.el xlib-xc.el xlib-xdpms.el xlib-xinerama.el xlib-xlib.el xlib-xpm.el xlib-xr.el xlib-xrecord.el xlib-xshape.el xlib-xtest.el xlib-xwin.el Log: Sync with Xlib 2.1 Release Revision Changes Path 1.2 +288 -0 XEmacs/packages/xemacs-packages/xlib/ChangeLog.upstream Index: ChangeLog.upstream =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/ChangeLog.upstream,v retrieving revision 1.1 retrieving revision 1.2 diff -u -p -r1.1 -r1.2 --- ChangeLog.upstream 2005/01/01 04:40:11 1.1 +++ ChangeLog.upstream 2005/04/04 19:55:25 1.2 ＠＠ -1,4 +1,292 ＠＠ # do not edit -- automatically generated by arch changelog +# arch-tag: automatic-ChangeLog--lg(a)xwem.org--2005/xlib--main--2.1 +# + +2005-04-04 18:25:15 GMT Zajcev Evgeny <lg(a)xwem.org&gt; version-0 + + Summary: + Xlib 2.1 is released + Revision: + xlib--main--2.1--version-0 + + + +2005-03-30 22:24:01 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-12 + + Summary: + Support for COMPOUNT_TEXT properties. + Revision: + xlib--main--2.1--patch-12 + + * lisp/xlib-xlib.el (XDecodeCompoundText): [new] Function to extract text + from COMPOUND_TEXT text. + + * lisp/xlib-xlib.el (XGetPropertyString): [fix] Use `XDecodeCompoundText' + in case of property in COMPOUND_TEXT encoding. + + modified files: + lisp/xlib-xlib.el + + new patches: + dev(a)xwem.org--2004-w/xlib--dev--2.1--patch-7 + + +2005-02-26 17:48:25 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-11 + + Summary: + merge from ckent, compilation warnings elimination + Revision: + xlib--main--2.1--patch-11 + + * lisp/xlib-xrecord.el (predicateds): Some predicateds moved on top. + + * lisp/xlib-xwin.el (predicateds): Some predicateds moved on top. + + modified files: + lisp/xlib-xrecord.el lisp/xlib-xwin.el + + new patches: + dev(a)xwem.org--2004-w/xlib--dev--2.1--patch-6 + + +2005-02-25 10:55:05 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-10 + + Summary: + lambda fixes + Revision: + xlib--main--2.1--patch-10 + + + modified files: + lisp/xlib-img.el lisp/xlib-testing.el lisp/xlib-xc.el + lisp/xlib-xlib.el lisp/xlib-xpm.el lisp/xlib-xr.el + lisp/xlib-xrecord.el lisp/xlib-xwin.el + + +2005-02-13 23:02:44 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-9 + + Summary: + Useful addons + Revision: + xlib--main--2.1--patch-9 + + * lisp/xlib-xlib.el (XDeleteProperty): [new] X request to delete X + property. + + * lisp/xlib-xlib.el (XSetWindowBackgroundPixmap): [new] Set window + background pixmap. + + * lisp/xlib-xlib.el (XSetPropertyString): [new] To set textual X + properties. + + * lisp/xlib-xr.el (X-EventsList): [fix] sanitify creation. + + * lisp/xlib-const.el (errors): [addon] X error codes added. + + modified files: + lisp/xlib-const.el lisp/xlib-xlib.el lisp/xlib-xr.el + + +2005-02-10 00:18:24 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-8 + + Summary: + logging changed a little + Revision: + xlib--main--2.1--patch-8 + + * lisp/xlib-xr.el: Logging for inter events changed a little. to be used + in catching evil bug. + + modified files: + lisp/xlib-xr.el + + +2005-02-06 20:00:08 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-7 + + Summary: + Merge from ckent + Revision: + xlib--main--2.1--patch-7 + + Patches applied: + + * dev(a)xwem.org--2004-w/xlib--dev--2.1--patch-3 + Copyright string changes + + + modified files: + lisp/xlib-composer.el lisp/xlib-const.el lisp/xlib-hello.el + lisp/xlib-img.el lisp/xlib-keysymdb.el lisp/xlib-math.el + lisp/xlib-testing.el lisp/xlib-tray.el lisp/xlib-vidmode.el + lisp/xlib-xc.el lisp/xlib-xdpms.el lisp/xlib-xinerama.el + lisp/xlib-xlib.el lisp/xlib-xpm.el lisp/xlib-xr.el + lisp/xlib-xrecord.el lisp/xlib-xshape.el lisp/xlib-xtest.el + lisp/xlib-xwin.el + + new patches: + dev(a)xwem.org--2004-w/xlib--dev--2.1--patch-3 + + +2005-02-03 23:52:26 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-6 + + Summary: + merge from ckent, X Event define/declare addons + Revision: + xlib--main--2.1--patch-6 + + * lisp/xlib-xr.el (X-Event-define): [addon] DESCR splited to EV-NAME, + EV-MSG and WIN-IDX. New parameter EVENT-WIN-IDX added. + + * lisp/xlib-xr.el (X-Event-declare): [addon] Ditto. + + modified files: + lisp/xlib-xc.el lisp/xlib-xr.el + + new patches: + dev(a)xwem.org--2004-w/xlib--dev--2.1--patch-2 + + +2005-02-02 23:52:31 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-5 + + Summary: + XDestroy declaration fix|try + Revision: + xlib--main--2.1--patch-5 + + + modified files: + lisp/xlib-xr.el + + +2005-02-02 22:11:17 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-4 + + Summary: + 2 serious bug fixes + Revision: + xlib--main--2.1--patch-4 + + * lisp/xlib-xlib.el (xlib-opcodes-alist): [rem] moved to xlib-xr.el + + * lisp/xlib-xr.el (xlib-opcodes-alist): [new] moved from xlib-xlib.el + + * lisp/xlib-xr.el (X-Dpy-send-read): [BUG fix] Serious BUG fixed. Do + flushing under reading protection, because in some (pretty ofter) + circumstances flushing can execute deffered calls by side effect which + may lead to desyncronisation. + + * lisp/xlib-xr.el (X-Dpy-parse-message): [BUG fix] Serious BUG fixed. + Dispatch intermediate event or error only after all reply to request is + fetched. Executing intermediate event or error may cause unexpected + reading by side effect. + + * lisp/xlib-xr.el (code): [cleanup] Untabification. + + * lisp/xlib-xrecord.el (X-XRecord-parse-guess): [fix] fixes to make it + more resistable for errors. + + * lisp/xlib-xrecord.el (code): [cleanup] Untabification. + + modified files: + lisp/xlib-xlib.el lisp/xlib-xr.el lisp/xlib-xrecord.el + + new patches: + dev(a)xwem.org--2004-w/xlib--dev--2.1--base-0 + dev(a)xwem.org--2004-w/xlib--dev--2.1--patch-1 + + +2005-02-01 23:04:15 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-3 + + Summary: + Root of most of the X timeout problems founded at last + Revision: + xlib--main--2.1--patch-3 + + * lisp/xlib-xr.el (X-Dpy-send-read): [BUG fix] Root of most of X timeout + errors founded here. This is response parsing problem. In some + circumstances we can request X server for data, while processing data. + This eventually lead to desyncronization. This is caused by + xwem-misc-xerr-hook, which can be called from inside `X-Dpy-send-read' + and xwem-misc-xerr-hook can also do `X-Dpy-send-read', now we restrict + `X-Dpy-send-read' reentering to avoid desyncronization. This is quite + rarely situation when `X-Dpy-send-read' reenters, but when it happens + xlib hangs forever. + + Many thanks to all of you guys for pushing me about this stuff! + + * lisp/xlib-xr.el (xxx): [misc] Some tiny cleanups, and more some logs + added. Errors raising clarified, etc. + + + modified files: + lisp/xlib-xr.el + + +2005-01-08 01:51:45 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-2 + + Summary: + inhibit C-g while parsing message + Revision: + xlib--main--2.1--patch-2 + + * lisp/xlib-xr.el (X-Dpy-parse-message): [fix] inhibit C-g while parsing, + so pressing C-g will not desync xlib. + + modified files: + lisp/xlib-xr.el + + +2005-01-01 02:54:34 GMT Zajcev Evgeny <lg(a)xwem.org&gt; patch-1 + + Summary: + start of 2.1 + Revision: + xlib--main--2.1--patch-1 + + + new files: + ChangeLog.d/.arch-ids/=id + ChangeLog.d/.arch-ids/ChangeLog-2.0.id + ChangeLog.d/ChangeLog-2.0 + + modified files: + Makefile + + new directories: + ChangeLog.d ChangeLog.d/.arch-ids + + +2005-01-01 02:44:45 GMT Zajcev Evgeny <lg(a)xwem.org&gt; base-0 + + Summary: + tag of lg(a)xwem.org--2004/xlib--main--2.0--version-0 + Revision: + xlib--main--2.1--base-0 + + (automatically generated log message) + + new patches: + dev(a)xwem.org--2004-w/xlib--dev--2.0--patch-5 + dev(a)xwem.org--2004-w/xlib--dev--2.0--patch-6 + dev(a)xwem.org--2004-w/xlib--dev--2.0--patch-7 + dev(a)xwem.org--2004-w/xlib--dev--2.0--patch-8 + dev(a)xwem.org--2004-w/xlib--dev--2.0--patch-9 + lg(a)xwem.org--2004/xlib--main--2.0--base-0 + lg(a)xwem.org--2004/xlib--main--2.0--patch-1 + lg(a)xwem.org--2004/xlib--main--2.0--patch-2 + lg(a)xwem.org--2004/xlib--main--2.0--patch-3 + lg(a)xwem.org--2004/xlib--main--2.0--patch-4 + lg(a)xwem.org--2004/xlib--main--2.0--patch-5 + lg(a)xwem.org--2004/xlib--main--2.0--patch-6 + lg(a)xwem.org--2004/xlib--main--2.0--patch-7 + lg(a)xwem.org--2004/xlib--main--2.0--patch-8 + lg(a)xwem.org--2004/xlib--main--2.0--patch-9 + lg(a)xwem.org--2004/xlib--main--2.0--version-0 + steve(a)eicq.org--2004/xlib--steve--2.0--base-0 + steve(a)eicq.org--2004/xlib--steve--2.0--patch-1 + steve(a)eicq.org--2004/xlib--steve--2.0--patch-2 + + +# do not edit -- automatically generated by arch changelog # non-id: automatic-ChangeLog--lg(a)xwem.org--2004/xlib--main--2.0 # 1.23 +1 -1 XEmacs/packages/xemacs-packages/xlib/Makefile Index: Makefile =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/Makefile,v retrieving revision 1.22 retrieving revision 1.23 diff -u -p -r1.22 -r1.23 --- Makefile 2005/01/04 11:07:13 1.22 +++ Makefile 2005/04/04 19:55:26 1.23 ＠＠ -18,7 +18,7 ＠＠ # Boston, MA 02111-1307, USA. VERSION = 1.13 -AUTHOR_VERSION = lg(a)xwem.org--2004/xlib--main--2.0--version-0 +AUTHOR_VERSION = lg(a)xwem.org--2005/xlib--main--2.1--version-0 MAINTAINER = Zajcev Evgeny <zevlg(a)yandex.ru&gt; PACKAGE = xlib PKG_TYPE = regular 1.2 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-composer.el Index: xlib-composer.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-composer.el,v retrieving revision 1.1 retrieving revision 1.2 diff -u -p -r1.1 -r1.2 --- xlib-composer.el 2005/01/01 04:40:14 1.1 +++ xlib-composer.el 2005/04/04 19:55:28 1.2 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-composer.el --- -;; Copyright (C) 2004 by Free Software Foundation, Inc. +;; Copyright (C) 2004,2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Fri Jun 4 18:46:04 MSD 2004 ;; Keywords: xlib -;; X-CVS: $Id: xlib-composer.el,v 1.1 2005/01/01 04:40:14 youngs Exp $ +;; X-CVS: $Id: xlib-composer.el,v 1.2 2005/04/04 19:55:28 lg Exp $ ;; This file is part of XWEM. 1.8 +22 -0 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-const.el Index: xlib-const.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-const.el,v retrieving revision 1.7 retrieving revision 1.8 diff -u -p -r1.7 -r1.8 --- xlib-const.el 2005/01/01 04:40:15 1.7 +++ xlib-const.el 2005/04/04 19:55:28 1.8 ＠＠ -1,11 +1,12 ＠＠ ;;; xlib-const.el --- Constants used in Xlib for masks and the like. ;; Copyright (C) 1996, 1997, 1998 Eric M. Ludlam +;; Copyright (C) 2003-2005 XWEM Org. ;; ;; Author: Eric M. Ludlam <zappo(a)gnu.ai.mit.edu&gt; ;; Modified: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Keywords: xlib, xwem -;; X-RCS: $Id: xlib-const.el,v 1.7 2005/01/01 04:40:15 youngs Exp $ +;; X-RCS: $Id: xlib-const.el,v 1.8 2005/04/04 19:55:28 lg Exp $ ;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ＠＠ -573,6 +574,27 ＠＠ ;; Byte order (defconst X-LSBFirst 0) (defconst X-MSBFirst 1) + +;; X errors +(defconst X-BadRequest 1) +(defconst X-BadValue 2) +(defconst X-BadWindow 3) +(defconst X-BadPixmap 4) +(defconst X-BadAtom 5) +(defconst X-BadCursor 6) +(defconst X-BadFont 7) +(defconst X-BadMatch 8) +(defconst X-BadDrawable 9) +(defconst X-BadAccess 10) +(defconst X-BadAlloc 11) +(defconst X-BadColor 12) +(defconst X-BadGC 13) +(defconst X-BadIDChoice 14) +(defconst X-BadName 15) +(defconst X-BadLength 16) +(defconst X-BadImplementation 17) +(defconst X-BadFirstExtension 128) +(defconst X-BadLastExtension 255)  (provide 'xlib-const) 1.8 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-hello.el Index: xlib-hello.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-hello.el,v retrieving revision 1.7 retrieving revision 1.8 diff -u -p -r1.7 -r1.8 --- xlib-hello.el 2005/01/01 04:40:15 1.7 +++ xlib-hello.el 2005/04/04 19:55:28 1.8 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-hello.el --- Hello world example using new xlib. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Eric M. Ludlam <zappo(a)gnu.ai.mit.edu&gt; ;; Modified: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Keywords: xlib -;; X-CVS: $Id: xlib-hello.el,v 1.7 2005/01/01 04:40:15 youngs Exp $ +;; X-CVS: $Id: xlib-hello.el,v 1.8 2005/04/04 19:55:28 lg Exp $ ;; This file is part of XWEM. 1.5 +3 -3 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-img.el Index: xlib-img.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-img.el,v retrieving revision 1.4 retrieving revision 1.5 diff -u -p -r1.4 -r1.5 --- xlib-img.el 2005/01/01 04:40:15 1.4 +++ xlib-img.el 2005/04/04 19:55:28 1.5 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-img.el --- Imaging for Xlib. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Fri Dec 12 11:22:19 MSK 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-img.el,v 1.4 2005/01/01 04:40:15 youngs Exp $ +;; X-CVS: $Id: xlib-img.el,v 1.5 2005/04/04 19:55:28 lg Exp $ ;; This file is part of XWEM. ＠＠ -235,8 +235,8 ＠＠ (setq ex-mcc (cons (nreverse tline) ex-mcc) tline nil))) (setq ex-mcc (nreverse ex-mcc)) - (setq xdata (mapcar (lambda (l) - (mapconcat 'identity (mapcar 'int->string2 l) "")) + (setq xdata (mapcar #'(lambda (l) + (apply 'concat (mapcar 'int->string2 l))) ex-mcc)) (setq ximg (XCreateImage xdpy nil (XDefaultDepth xdpy) 1.4 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-keysymdb.el Index: xlib-keysymdb.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-keysymdb.el,v retrieving revision 1.3 retrieving revision 1.4 diff -u -p -r1.3 -r1.4 --- xlib-keysymdb.el 2005/01/01 04:40:15 1.3 +++ xlib-keysymdb.el 2005/04/04 19:55:28 1.4 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-keysymdb.el --- XKeysymDB for xlib. -;; Copyright (C) 2004 by Free Software Foundation, Inc. +;; Copyright (C) 2004,2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Tue Dec 7 20:23:10 MSK 2004 ;; Keywords: xlib -;; X-CVS: $Id: xlib-keysymdb.el,v 1.3 2005/01/01 04:40:15 youngs Exp $ +;; X-CVS: $Id: xlib-keysymdb.el,v 1.4 2005/04/04 19:55:28 lg Exp $ ;; This file is part of XEmacs. 1.8 +1 -0 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-math.el Index: xlib-math.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-math.el,v retrieving revision 1.7 retrieving revision 1.8 diff -u -p -r1.7 -r1.8 --- xlib-math.el 2005/01/01 04:40:16 1.7 +++ xlib-math.el 2005/04/04 19:55:28 1.8 ＠＠ -1,11 +1,12 ＠＠ ;;; xlib-math.el --- icky math things such as 4 byte ints, and int->string stuff. ;; Copyright (C) 1996, 1997, 1998 Eric M. Ludlam +;; Copyright (C) 2003-2005 XWEM Org. ;; ;; Author: Eric M. Ludlam <zappo(a)gnu.ai.mit.edu&gt; ;; Modified: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Keywords: xlib, xwem -;; X-RCS: $Id: xlib-math.el,v 1.7 2005/01/01 04:40:16 youngs Exp $ +;; X-RCS: $Id: xlib-math.el,v 1.8 2005/04/04 19:55:28 lg Exp $ ;; This file is part of XWEM. 1.4 +13 -13 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-testing.el Index: xlib-testing.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-testing.el,v retrieving revision 1.3 retrieving revision 1.4 diff -u -p -r1.3 -r1.4 --- xlib-testing.el 2005/01/01 04:40:16 1.3 +++ xlib-testing.el 2005/04/04 19:55:29 1.4 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-testing.el --- Testing suite for xlib. -;; Copyright (C) 2004 by Free Software Foundation, Inc. +;; Copyright (C) 2004,2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Thu Nov 25 15:34:59 MSK 2004 ;; Keywords: xlib -;; X-CVS: $Id: xlib-testing.el,v 1.3 2005/01/01 04:40:16 youngs Exp $ +;; X-CVS: $Id: xlib-testing.el,v 1.4 2005/04/04 19:55:29 lg Exp $ ;; This file is part of XEmacs. ＠＠ -155,18 +155,18 ＠＠ (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"))) + (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"))) 1.8 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-tray.el Index: xlib-tray.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-tray.el,v retrieving revision 1.7 retrieving revision 1.8 diff -u -p -r1.7 -r1.8 --- xlib-tray.el 2005/01/01 04:40:16 1.7 +++ xlib-tray.el 2005/04/04 19:55:29 1.8 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-tray.el --- XEMBED support. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Tue Dec 9 14:14:07 MSK 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-tray.el,v 1.7 2005/01/01 04:40:16 youngs Exp $ +;; X-CVS: $Id: xlib-tray.el,v 1.8 2005/04/04 19:55:29 lg Exp $ ;; This file is part of XWEM. 1.2 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-version.el Index: xlib-version.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-version.el,v retrieving revision 1.1 retrieving revision 1.2 diff -u -p -r1.1 -r1.2 --- xlib-version.el 2005/01/01 04:40:16 1.1 +++ xlib-version.el 2005/04/04 19:55:29 1.2 ＠＠ -1,5 +1,5 ＠＠ ;;; Automatically generated file -- DO NOT EDIT OR DELETE ;;;###autoload (defconst xlib-version - &quot;lg(a)xwem.org--2004/xlib--main--2.0--version-0&quot;) + &quot;lg(a)xwem.org--2005/xlib--main--2.1--version-0&quot;) (provide 'xlib-version) 1.5 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-vidmode.el Index: xlib-vidmode.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-vidmode.el,v retrieving revision 1.4 retrieving revision 1.5 diff -u -p -r1.4 -r1.5 --- xlib-vidmode.el 2005/01/01 04:40:16 1.4 +++ xlib-vidmode.el 2005/04/04 19:55:29 1.5 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-vidmode.el --- XF86VidMode extension support. -;; Copyright (C) 2004 by Free Software Foundation, Inc. +;; Copyright (C) 2004,2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Fri Jan 16 18:39:44 MSK 2004 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-vidmode.el,v 1.4 2005/01/01 04:40:16 youngs Exp $ +;; X-CVS: $Id: xlib-vidmode.el,v 1.5 2005/04/04 19:55:29 lg Exp $ ;; This file is part of XWEM. 1.7 +12 -27 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xc.el Index: xlib-xc.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xc.el,v retrieving revision 1.6 retrieving revision 1.7 diff -u -p -r1.6 -r1.7 --- xlib-xc.el 2005/01/01 04:40:16 1.6 +++ xlib-xc.el 2005/04/04 19:55:29 1.7 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xc.el --- X Connection. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: 18 October 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xc.el,v 1.6 2005/01/01 04:40:16 youngs Exp $ +;; X-CVS: $Id: xlib-xc.el,v 1.7 2005/04/04 19:55:29 lg Exp $ ;; X-URL: http://lgarc.narod.ru/xwem/index.html ;; This file is part of XWEM. ＠＠ -323,7 +323,7 ＠＠ If XDPY is nil, then put into current bu (save-excursion (goto-char (point-min)) (insert (format "%d %S: " (nth 1 (current-time)) routine)) - (insert (apply 'format (mapcar (lambda (arg) (eval arg)) args))) + (insert (apply 'format (mapcar 'eval args))) (insert "\n"))))) (defun X-Dpy-log-verbatim (xdpy arg) ＠＠ -351,23 +351,6 ＠＠ There is special mode when we are collec ;; increase request sequence number (incf (X-Dpy-rseq-id xdpy))) -;;; Event dispatcher -(defun X-Dpy-default-events-dispatcher (xdpy win xev) - "Default events dispatcher." - (X-Dpy-log xdpy 'x-event "Get event: %S, for win: %S" '(X-Event-name xev) - '(if (X-Win-p win) (X-Win-id win) win)) - - (when (X-Win-p win) - ;; First run display handlers - (when (X-Dpy-event-handlers xdpy) - (X-Dpy-EventHandler-runall xdpy xev)) - - ;; Then run WIN specific handlers - (when (X-Win-event-handlers win) - ;; WIN has its own event handlers - (X-Win-EventHandler-runall win xev)) - )) - ;;; Sending section (defmacro X-Force-char-num (maybechar) "Force MAYBECHAR to be a number for XEmacs platform." ＠＠ -522,9 +505,9 ＠＠ TYPE-DESCRIPTION is list where car of it (X-type-pack dpy (cadr xtd) val)) ((eq xt 'listof) - (mapconcat (lambda (el) - (X-type-pack dpy (cadr xtd) el)) - val "")) + (apply 'concat (mapcar #'(lambda (el) + (X-type-pack dpy (cadr xtd) el)) + val))) ((eq xt 'setof) (funcall (cond ((= (cadr xtd) 1) 'int->string1) ＠＠ -533,9 +516,10 ＠＠ TYPE-DESCRIPTION is list where car of it (apply 'Xmask-or val))) ((eq xt 'struct) - (mapconcat (lambda (tt) - (X-type-pack dpy (cdr tt) (funcall (car tt) val))) - (cddr xt) "")) + (apply 'concat (mapcar #'(lambda (tt) + (X-type-pack dpy (cdr tt) + (funcall (car tt) val))) + (cddr xt)))) ((eq xt 'or) (setq xt (cdr xt)) ＠＠ -588,8 +572,9 ＠＠ TYPE-DESCRIPTION is list where car of it ((eq xt 'struct) (let ((rval (funcall (cadr xtd)))) - (mapc (lambda (tt) - (eval `(setf (,(car tt) rval) (X-type-extract dpy ,(cdr tt))))) + (mapc #'(lambda (tt) + (eval `(setf (,(car tt) rval) + (X-type-extract dpy ,(cdr tt))))) (cdr xtd)) rval))))) 1.2 +2 -2 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xdpms.el Index: xlib-xdpms.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xdpms.el,v retrieving revision 1.1 retrieving revision 1.2 diff -u -p -r1.1 -r1.2 --- xlib-xdpms.el 2004/03/22 17:36:25 1.1 +++ xlib-xdpms.el 2005/04/04 19:55:29 1.2 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xdpms.el --- DPMS extension support. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Tue Nov 18 03:19:16 MSK 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xdpms.el,v 1.1 2004/03/22 17:36:25 lg Exp $ +;; X-CVS: $Id: xlib-xdpms.el,v 1.2 2005/04/04 19:55:29 lg Exp $ ;; This file is part of XWEM. 1.7 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xinerama.el Index: xlib-xinerama.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xinerama.el,v retrieving revision 1.6 retrieving revision 1.7 diff -u -p -r1.6 -r1.7 --- xlib-xinerama.el 2005/01/01 04:40:16 1.6 +++ xlib-xinerama.el 2005/04/04 19:55:29 1.7 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xinerama.el --- Xinerama support. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Mon Nov 17 19:23:03 MSK 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xinerama.el,v 1.6 2005/01/01 04:40:16 youngs Exp $ +;; X-CVS: $Id: xlib-xinerama.el,v 1.7 2005/04/04 19:55:29 lg Exp $ ;; This file is part of XWEM. 1.9 +112 -147 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xlib.el Index: xlib-xlib.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xlib.el,v retrieving revision 1.8 retrieving revision 1.9 diff -u -p -r1.8 -r1.9 --- xlib-xlib.el 2005/01/01 04:40:17 1.8 +++ xlib-xlib.el 2005/04/04 19:55:30 1.9 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xlib.el --- X library part of new xlib. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Eric M. Ludlam <zappo(a)gnu.ai.mit.edu&gt; ;; Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xlib.el,v 1.8 2005/01/01 04:40:17 youngs Exp $ +;; X-CVS: $Id: xlib-xlib.el,v 1.9 2005/04/04 19:55:30 lg Exp $ ;; This file is part of XWEM. ＠＠ -32,92 +32,6 ＠＠  (require 'xlib-xr) -(defvar xlib-opcodes-alist - '((104 . XBell) - (1 . XCreateWindow) - (2 . XChangeWindowAttributes) - (3 . XGetWindowAttributes) - (12 . XConfigureWindow) - (8 . XMapWindow) - (10 . XUnmapWindow) - (4 . XDestroyWindow) - (5 . XDestroySubwindows) - (15 . XQueryTree) - (16 . XInternAtom) - (17 . XGetAtomName) - (18 . XChangeProperty) - (20 . XGetWindowProperty) - (78 . XCreateColormap) - (79 . XFreeColormap) - (84 . XAllocColor) - (85 . XAllocNamedColor) - (86 . XAllocColorCells) - (89 . XStoreColors) - (88 . XFreeColors) - (91 . XQueryColors) - (55 . XCreateGC) - (56 . XChangeGC) - (58 . XSetDashes) - (59 . XSetClipRectangles) - (60 . XFreeGC) - (61 . XClearArea) - (62 . XCopyArea) - (63 . XCopyPlane) - (64 . XDrawPoints) - (65 . XDrawLines) - (69 . XFillPoly) - (66 . XDrawSegments) - (67 . XDrawRectangles) - (70 . XDrawRectangles) - (68 . XDrawArcs) - (71 . XDrawArcs) - (74 . XDrawString) - (76 . XImageString) - (72 . XPutImage) - (73 . XGetImage) - (22 . XSetSelectionOwner) - (23 . XGetSelectionOwner) - (24 . XConvertSelection) - (41 . XWarpPointer) - (36 . XGrabServer) - (37 . XUngrabServer) - (38 . XQueryPointer) - (31 . XGrabKeyboard) - (32 . XUngrabKeyboard) - (26 . XGrabPointer) - (27 . XUngrabPointer) - (28 . XGrabButton) - (29 . XUngrabButton) - (33 . XGrabKey) - (34 . XUngrabKey) - (43 . XGetInputFocus) - (42 . XSetInputFocus) - (7 . XReparentWindow) - (14 . XGetGeometry) - (40 . XTranslateCoordinates) - (6 . XChangeSaveSet) - (25 . XSendEvent) - (44 . XQueryKeymap) - (101 . XGetKeyboardMapping) - (119 . XGetModifierMapping) - (45 . XOpenFont) - (47 . XQueryFont) - (48 . XQueryTextExtents) - (53 . XCreatePixmap) - (54 . XFreePixmap) - (93 . XCreateCursor) - (94 . XCreateGlyphCursor) - (95 . XFreeCursor) - (96 . XRecolorCursor) - (30 . XChangeActivePointerGrab) - (98 . XQueryExtension) - (107 . XSetScreenSaver) - (108 . XGetScreenSaver) - (113 . XKillClient) - (115 . XForceScreenSaver)) - "Alist of X opcodes in form (OPCODE . FUNCTION). -This is only informative variable.") - (defun XOpenDisplay (name &optional dispnum screen) "Open an X connection to the display named NAME such as host:0.1. Optionally you may pass DISPNUM - display number and SCREEN - screen number." ＠＠ -158,53 +72,55 ＠＠ Optionally you may pass DISPNUM - displa ;; Fill formats list (setf (X-Dpy-formats xdpy) - (mapcar (lambda (fmt) - (make-X-ScreenFormat :depth (nth 0 fmt) - :bits-per-pixel (nth 1 fmt) - :scanline-pad (nth 2 fmt))) + (mapcar #'(lambda (fmt) + (make-X-ScreenFormat :depth (nth 0 fmt) + :bits-per-pixel (nth 1 fmt) + :scanline-pad (nth 2 fmt))) (nth 15 X-info))) ;; Fill screens list (setf (X-Dpy-screens xdpy) - (mapcar (lambda (scr) - (let (nscreen) - (setq nscreen (make-X-Screen :root (X-Win-find-or-make xdpy (nth 0 scr)) - :colormap (make-X-Colormap :dpy xdpy :id (nth 1 scr)) - :white-pixel (make-X-Color :dpy xdpy :id (nth 2 scr)) - :black-pixel (make-X-Color :dpy xdpy :id (nth 3 scr)) - :root-event-mask (nth 4 scr) - :width (nth 5 scr) - :height (nth 6 scr) - :mwidth (nth 7 scr) - :mheight (nth 8 scr) - :min-maps (nth 9 scr) - :max-maps (nth 10 scr) - :visualid (nth 11 scr) - :backingstores (nth 12 scr) - :save-unders (nth 13 scr) - :root-depth (nth 14 scr))) - - (setf (X-Screen-depths nscreen) - (mapcar (lambda (dpth) - (make-X-Depth :depth (nth 0 dpth) - :visuals (mapcar (lambda (vis) - (make-X-Visual :id (nth 0 vis) - :class (nth 1 vis) - :bits-per-rgb (nth 2 vis) - :cmap-entries (nth 3 vis) - :red-mask (nth 4 vis) - :green-mask (nth 6 vis) - :blue-mask (nth 5 vis))) - (nth 1 dpth)))) - (nth 15 scr))) - - ;; Create default GC - (setf (X-Screen-default-gc nscreen) - (XCreateGC xdpy (X-Screen-root nscreen) - (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy) - :foreground (X-Screen-white-pixel nscreen) - :background (X-Screen-black-pixel nscreen)))) - nscreen)) + (mapcar #'(lambda (scr) + (let (nscreen) + (setq nscreen + (make-X-Screen + :root (X-Win-find-or-make xdpy (nth 0 scr)) + :colormap (make-X-Colormap :dpy xdpy :id (nth 1 scr)) + :white-pixel (make-X-Color :dpy xdpy :id (nth 2 scr)) + :black-pixel (make-X-Color :dpy xdpy :id (nth 3 scr)) + :root-event-mask (nth 4 scr) + :width (nth 5 scr) + :height (nth 6 scr) + :mwidth (nth 7 scr) + :mheight (nth 8 scr) + :min-maps (nth 9 scr) + :max-maps (nth 10 scr) + :visualid (nth 11 scr) + :backingstores (nth 12 scr) + :save-unders (nth 13 scr) + :root-depth (nth 14 scr))) + + (setf (X-Screen-depths nscreen) + (mapcar #'(lambda (dpth) + (make-X-Depth :depth (nth 0 dpth) + :visuals (mapcar #'(lambda (vis) + (make-X-Visual :id (nth 0 vis) + :class (nth 1 vis) + :bits-per-rgb (nth 2 vis) + :cmap-entries (nth 3 vis) + :red-mask (nth 4 vis) + :green-mask (nth 6 vis) + :blue-mask (nth 5 vis))) + (nth 1 dpth)))) + (nth 15 scr))) + + ;; Create default GC + (setf (X-Screen-default-gc nscreen) + (XCreateGC xdpy (X-Screen-root nscreen) + (make-X-Gc :dpy xdpy :id (X-Dpy-get-id xdpy) + :foreground (X-Screen-white-pixel nscreen) + :background (X-Screen-black-pixel nscreen)))) + nscreen)) (nth 16 X-info))) ;; Alert user ＠＠ -350,9 +266,9 ＠＠ Optionally you may pass DISPNUM - displa "On display XDPY for window WIN, set the background to PIXEL." (XChangeWindowAttributes xdpy win (make-X-Attr :background-pixel pixel))) -;(defun X-SetWindowForeground (xdpy win pixel) -; "On display XDPY for window WIN, set the foreground to PIXEL." -; (XChangeWindowAttributes xdpy win (make-X-Attr :foreground-pixel pixel))) +(defun XSetWindowBackgroundPixmap (xdpy win pixmap) + "On display XDPY for window WIN, set the background pixmap to PIXMAP." + (XChangeWindowAttributes xdpy win (make-X-Attr :background-pixmap pixmap))) (defun XSetWindowBorder (xdpy win pixel) "On display XDPY for window WIN, set the border color to PIXEL." ＠＠ -645,8 +561,25 ＠＠ There are NElements." data (cdr data))))) (X-Dpy-send xdpy (X-Create-message ListOfFields)))) +(defun XDeleteProperty (xdpy win atom) + "On display XDPY for window WIN delete property denoted by ATOM." + (X-Win-p win 'XDeleteProperty) + (X-Atom-p atom 'XDeleteProperty) + + (let ((ListOfFields + (list [1 19] ;opcode + [1 nil] ;unused + [2 3] ;length + [4 (X-Win-id win)] ;window + [4 (X-Atom-id atom)]))) ;atom + (X-Dpy-send xdpy (X-Create-message ListOfFields)))) + ;; These are Xlib convenience routines -;; +(defun XSetPropertyString (xdpy win atom string &optional mode) + "On display XDPY and window WIN set ATOM property to STRING." + (XChangeProperty xdpy win atom XA-string X-format-8 (or mode X-PropModeReplace) + string)) + (defun XSetWMProtocols (xdpy win protocol_atoms) "On display XDPY, set window's WIN protocols to PROTOCOL_ATOMS. Convenience routine which calls `XChangeProperty'" ＠＠ -825,17 +758,45 ＠＠ BYTES_AFTER contains the exact amount of :base-height (Xtruncate (nth 16 wmnh)) :gravity (Xtruncate (nth 17 wmnh)))))) +(defun XDecodeCompoundText (text) + "Decode compound TEXT, to native string. +Evil hack, invent something better." + (if (string-match "\x1b\x25\x2f\x31\\(.\\)\\(.\\)\\(.*?\\)\x02" text) + (let ((len (+ (* (- (char-to-int (string-to-char (match-string 1 text))) 128) 128) + (- (char-to-int (string-to-char (match-string 2 text))) 128)))) + (let ((seq-beg (match-beginning 0)) + (data-beg (match-end 0)) + (data-end (+ len (match-beginning 3))) + (cs (intern (match-string 3 text)))) + (concat (substring text 0 seq-beg) + (if (fboundp 'decode-coding-string) + (decode-coding-string (substring text data-beg data-end) cs) + (substring text data-beg data-end)) + (XDecodeCompoundText (substring text data-end))))) + text)) + (defun XGetPropertyString (xdpy win atom) "On display XDPY, and window XWIN, get string property of type ATOM." - (let ((propdata (XGetWindowProperty xdpy win atom 0 1024 nil XA-string)) + (let ((propdata (XGetWindowProperty xdpy win atom 0 1024)) + (tdata nil) (retstring "")) - (when propdata - (setq retstring (nth 2 propdata)) + (when (and propdata (setq tdata (nth 2 propdata))) + (setq retstring tdata) + (when (= (car propdata) + (X-Atom-id (XInternAtom xdpy "COMPOUND_TEXT"))) + ;; Adjust RETSTRING in case of COMPOUND_TEXT + (setq retstring (XDecodeCompoundText retstring))) + (when (> (nth 1 propdata) 0.0) - (setq propdata (XGetWindowProperty xdpy win atom - 1024 (nth 0 propdata) nil XA-string)) - (when propdata - (setq retstring (concat retstring (nth 2 propdata)))))) + (setq propdata + (XGetWindowProperty xdpy win atom + 1024 (nth 0 propdata))) + (when (and propdata (setq tdata (nth 2 propdata))) + (if (= (car propdata) + (X-Atom-id (XInternAtom xdpy "COMPOUND_TEXT"))) + (setq retstring + (concat retstring (XDecodeCompoundText tdata))) + (setq retstring (concat retstring tdata)))))) retstring)) (defun XGetWMName (xdpy win) ＠＠ -1167,8 +1128,9 ＠＠ PLANES if you don't know what it's for." [4 (X-Colormap-id cmap)] ;Colormap [4 planes])) ;plane mask (msg (concat (X-Create-message ListOfFields) - (X-Generate-message-for-list colors - (lambda (col) (int->string4 (X-Color-id col))))))) + (X-Generate-message-for-list + colors + #'(lambda (col) (int->string4 (X-Color-id col))))))) (X-Dpy-send xdpy msg) ;; NOTE: ＠＠ -1191,7 +1153,9 ＠＠ PLANES if you don't know what it's for." [4 (X-Colormap-id cmap)] ;COLORMAP )) (msg (concat (X-Create-message ListOfFields) - (X-Generate-message-for-list color-ids (lambda (colid) (int->string4 colid))))) + (X-Generate-message-for-list + color-ids + #'(lambda (colid) (int->string4 colid))))) (ReceiveFields (list [1 success] nil ＠＠ -1254,7 +1218,7 ＠＠ I.e. update GC's info on server." (X-Dpy-p xdpy 'XSetDashes) (X-Gc-p gc 'XSetDashes) - (let* ((dstr (mapconcat (lambda (d) (int->string1 d)) dashes "")) + (let* ((dstr (apply 'concat (mapcar 'int->string1 dashes))) (ListOfFields (list [1 58] ;opcode [1 nil] ;unused ＠＠ -1534,7 +1498,7 ＠＠ args (DISPLAY D GC X Y WIDTH HEIGHT ANGL ;; Check len, must be < 255 (when (or (and len (>= len 255)) (>= (length str) 255)) - (signal 'overflow-error (list str (or len (length str))))) + (setq str (substring str 0 254))) (let* ((slen (if len len (length str))) ;make len optional (ListOfFields ＠＠ -2279,7 +2243,8 ＠＠ Evil hack, do not use this function." [2 (+ 2 (X-padlen (concat string string)))] ;length [4 (X-Font-id font)])) (msg (concat (X-Create-message ListOfFields) - (mapconcat (lambda (c) (string ?\0 c)) string "") + (apply 'concat + (mapcar #'(lambda (c) (string ?\0 c)) string)) (when (> (% (length string) 2) 0) (make-string 2 ?\0)) )) (ReceiveFields 1.7 +7 -6 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xpm.el Index: xlib-xpm.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xpm.el,v retrieving revision 1.6 retrieving revision 1.7 diff -u -p -r1.6 -r1.7 --- xlib-xpm.el 2005/01/01 04:40:17 1.6 +++ xlib-xpm.el 2005/04/04 19:55:30 1.7 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xpm.el --- XPM library for Xlib. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Fri Nov 28 01:28:18 MSK 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xpm.el,v 1.6 2005/01/01 04:40:17 youngs Exp $ +;; X-CVS: $Id: xlib-xpm.el,v 1.7 2005/04/04 19:55:30 lg Exp $ ;; This file is part of XWEM. ＠＠ -278,11 +278,12 ＠＠ Return data for `X-XYPixmap' format." (setq xpm-index (1+ xpm-index))) - (setq data (mapvector (lambda (row) - (X-formatpad xdpy depth - (mapconcat (lambda (col) - (X-formatint xdpy depth col)) - row ""))) + (setq data (mapvector #'(lambda (row) + (X-formatpad xdpy depth + (apply 'concat + (mapcar #'(lambda (col) + (X-formatint xdpy depth col)) + row)))) xpm)) ;; XXX (setq ximg (XCreateImage xdpy nil depth X-ZPixmap 0 data 1.10 +844 -740 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xr.el Index: xlib-xr.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xr.el,v retrieving revision 1.9 retrieving revision 1.10 diff -u -p -r1.9 -r1.10 --- xlib-xr.el 2005/01/01 04:40:17 1.9 +++ xlib-xr.el 2005/04/04 19:55:30 1.10 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xr.el --- X receive part. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Eric M. Ludlam <zappo(a)gnu.ai.mit.edu&gt; -;; Zajcev Evgeny <zevlg(a)yandex.ru&gt; +;; Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xr.el,v 1.9 2005/01/01 04:40:17 youngs Exp $ +;; X-CVS: $Id: xlib-xr.el,v 1.10 2005/04/04 19:55:30 lg Exp $ ;; This file is part of XWEM. ＠＠ -58,11 +58,11 ＠＠ "Take list LST and turn it into a vector. This makes random access of its fields much faster." (let ((nv (make-vector (length lst) nil)) - (cnt 0)) + (cnt 0)) (while lst (aset nv cnt (if (and (car lst) (listp (car lst))) - (XVectorizeList (car lst)) - (car lst))) + (XVectorizeList (car lst)) + (car lst))) (setq cnt (1+ cnt)) (setq lst (cdr lst))) nv)) ＠＠ -72,24 +72,24 ＠＠ This makes random access of its fields m NOTE: * Core event are less than 35, but extensions may generate greater. * Eight bit is syntetic bit.") -(defvar X-EventsList (make-vector X-Event-LASTEvent nil) +(defvar X-EventsList (make-vector X-Event-LASTEvent ["Unknown" nil 0 0]) "List of event descriptions.") (defstruct (X-Event (:predicate X-Event-isevent-p)) - dpy ; display - type ; type of event - synth-p ; non-nil if event came from SendEvent request - evdata ; binary event represetation - evinfo ; parsed variant of evdata + dpy ; display + type ; type of event + synth-p ; non-nil if event came from SendEvent request + evdata ; binary event represetation + evinfo ; parsed variant of evdata - list ;for use in X-Generate-message - properties ; User defined plist + list ;for use in X-Generate-message + properties ; User defined plist ) (defsubst X-Event-put-property (xev prop val) "Put property PROP with value VAL in XEV's properties list." (setf (X-Event-properties xev) - (plist-put (X-Event-properties xev) prop val))) + (plist-put (X-Event-properties xev) prop val))) (defsubst X-Event-get-property (xev prop) "Get property PROP from XEV's properties list." ＠＠ -103,7 +103,7 ＠＠ NOTE: * Core event are less than 35, but "Return non-nil if EV is X-Event." (let ((isev (X-Event-isevent-p ev))) (if (and (not isev) sig) - (signal 'wrong-type-argument (list sig 'X-Event-p ev)) + (signal 'wrong-type-argument (list sig 'X-Event-p ev)) isev))) (defsubst X-Event-detail (xev) ＠＠ -115,11 +115,17 ＠＠ NOTE: * Core event are less than 35, but (nth 1 (X-Event-evinfo xev))) (defsubst X-Event-win (xev) - "Return window for which EV generated. -Return nil if there no window for which event XEV is generated." + "Return window which is the subject of the XEV. +Return nil if there no such window." (let ((evd (aref (aref X-EventsList (X-Event-type xev)) 2))) (and (numberp evd) (nth evd (X-Event-evinfo xev))))) +(defsubst X-Event-win-event (xev) + "Return window for which XEV is generated. +Return nil if there is no such window." + (let ((evd (aref (aref X-EventsList (X-Event-type xev)) 3))) + (and (numberp evd) (nth evd (X-Event-evinfo xev))))) + (defsubst X-Event-name (xev) "Return symbolic XEV name." (aref (aref X-EventsList (X-Event-type xev)) 0)) ＠＠ -127,23 +133,26 ＠＠ Return nil if there no window for which (defun X-Event-make (&rest args) "Like `make-X-Event', but also fills list field automatically." (let* ((xev (apply 'make-X-Event args)) - (evspec (aref (X-Event-type xev) X-EventsList))) + (evspec (aref (X-Event-type xev) X-EventsList))) ;; TODO: write me .. )) -(defmacro X-Event-declare (type descr) +(defmacro X-Event-declare (type ev-name ev-msg &optional win-idx event-win-idx) "Only declare event of TYPE with DESCR in `X-EventsList'." - `(aset X-EventsList ,type ,descr)) + `(aset X-EventsList ,type + (vector ,ev-name (quote ,ev-msg) ,win-idx (or ,event-win-idx ,win-idx)))) -(defmacro X-Event-define (type name dnames descr) +(defmacro X-Event-define (type name dnames ev-name ev-msg &optional win-idx event-win-idx) "Define new event of TYPE, NAME and description of event DESCR." (let ((offs 0) - fsym forms) - (push `(aset X-EventsList ,type ,descr) forms) + fsym forms) + (push `(aset X-EventsList ,type + (vector ,ev-name (quote ,ev-msg) ,win-idx (or ,event-win-idx ,win-idx))) + forms) (while dnames (when (car dnames) - (setq fsym (intern (concat "X-Event-" name "-" (symbol-name (car dnames))))) - (push `(defsubst* ,fsym (ev) + (setq fsym (intern (concat "X-Event-" name "-" (symbol-name (car dnames))))) + (push `(defsubst* ,fsym (ev) (nth ,offs (X-Event-evinfo ev))) forms)) (setq offs (1+ offs)) ＠＠ -154,40 +163,40 ＠＠ Return nil if there no window for which "Convert XEV type to symbolic name, return keyword." (let ((evt (X-Event-type xev))) (cond ((= evt X-KeyPress) :X-KeyPress) - ((= evt X-KeyRelease) :X-KeyRelease) - ((= evt X-ButtonPress) :X-ButtonPress) - ((= evt X-ButtonRelease) :X-ButtonRelease) - ((= evt X-MotionNotify) :X-MotionNotify) - ((= evt X-EnterNotify) :X-EnterNotify) - ((= evt X-LeaveNotify) :X-LeaveNotify) - ((= evt X-FocusIn) :X-FocusIn) - ((= evt X-FocusOut) :X-FocusOut) - ((= evt X-KeymapNotify) :X-KeymapNotify) - ((= evt X-Expose) :X-Expose) - ((= evt X-GraphicsExpose) :X-GraphicsExpose) - ((= evt X-NoExpose) :X-NoExpose) - ((= evt X-VisibilityNotify) :X-VisibilityNotify) - ((= evt X-CreateNotify) :X-CreateNotify) - ((= evt X-DestroyNotify) :X-DestroyNotify) - ((= evt X-UnmapNotify) :X-UnmapNotify) - ((= evt X-MapNotify) :X-MapNotify) - ((= evt X-MapRequest) :X-MapRequest) - ((= evt X-ReparentNotify) :X-ReparentNotify) - ((= evt X-ConfigureRequest) :X-ConfigureRequest) - ((= evt X-ConfigureNotify) :X-ConfigureNotify) - ((= evt X-GravityNotify) :X-GravityNotify) - ((= evt X-ResizeRequest) :X-ResizeRequest) - ((= evt X-CirculateNotify) :X-CirculateNotify) - ((= evt X-CirculateRequest) :X-CirculateRequest) - ((= evt X-PropertyNotify) :X-PropertyNotify) - ((= evt X-SelectionClear) :X-SelectionClear) - ((= evt X-SelectionRequest) :X-SelectionRequest) - ((= evt X-SelectionNotify) :X-SelectionNotify) - ((= evt X-ColormapNotify) :X-ColormapNotify) - ((= evt X-ClientMessage) :X-ClientMessage) - ((= evt X-MappingNotify) :X-MappingNotify) + ((= evt X-KeyRelease) :X-KeyRelease) + ((= evt X-ButtonPress) :X-ButtonPress) + ((= evt X-ButtonRelease) :X-ButtonRelease) + ((= evt X-MotionNotify) :X-MotionNotify) + ((= evt X-EnterNotify) :X-EnterNotify) + ((= evt X-LeaveNotify) :X-LeaveNotify) + ((= evt X-FocusIn) :X-FocusIn) + ((= evt X-FocusOut) :X-FocusOut) + ((= evt X-KeymapNotify) :X-KeymapNotify) + ((= evt X-Expose) :X-Expose) + ((= evt X-GraphicsExpose) :X-GraphicsExpose) + ((= evt X-NoExpose) :X-NoExpose) + ((= evt X-VisibilityNotify) :X-VisibilityNotify) + ((= evt X-CreateNotify) :X-CreateNotify) + ((= evt X-DestroyNotify) :X-DestroyNotify) + ((= evt X-UnmapNotify) :X-UnmapNotify) + ((= evt X-MapNotify) :X-MapNotify) + ((= evt X-MapRequest) :X-MapRequest) + ((= evt X-ReparentNotify) :X-ReparentNotify) + ((= evt X-ConfigureRequest) :X-ConfigureRequest) + ((= evt X-ConfigureNotify) :X-ConfigureNotify) + ((= evt X-GravityNotify) :X-GravityNotify) + ((= evt X-ResizeRequest) :X-ResizeRequest) + ((= evt X-CirculateNotify) :X-CirculateNotify) + ((= evt X-CirculateRequest) :X-CirculateRequest) + ((= evt X-PropertyNotify) :X-PropertyNotify) + ((= evt X-SelectionClear) :X-SelectionClear) + ((= evt X-SelectionRequest) :X-SelectionRequest) + ((= evt X-SelectionNotify) :X-SelectionNotify) + ((= evt X-ColormapNotify) :X-ColormapNotify) + ((= evt X-ClientMessage) :X-ClientMessage) + ((= evt X-MappingNotify) :X-MappingNotify) - (t :X-Unknown)))) + (t :X-Unknown)))) (defmacro X-Event-CASE (xev &rest body) "Run event case. BODY in form (EVTYPE FORMS) (EVTYPE FORMS) .. ＠＠ -199,11 +208,11 ＠＠ EVTYPE is one of :X-KeyPress, :X-KeyRele (defstruct X-EventHandler priority - evtypes-list ; list of event types - handler ; function to call - (active t) ; Non-nil mean event handler activated + evtypes-list ; list of event types + handler ; function to call + (active t) ; Non-nil mean event handler activated - plist) ; user defined plist + plist) ; user defined plist ;;;###autoload (defun X-EventHandler-add (evhlist handler &optional priority evtypes-list) ＠＠ -220,14 +229,14 ＠＠ Return new list, use it like `(setq lst (setq priority 0)) (let ((xeh (make-X-EventHandler :priority priority - :evtypes-list evtypes-list - :handler handler))) + :evtypes-list evtypes-list + :handler handler))) ;; Insert new event handler and sort event handlers by priority. (sort (cons xeh evhlist) - (lambda (xeh1 xeh2) - (> (X-EventHandler-priority xeh1) - (X-EventHandler-priority xeh2)))))) + #'(lambda (xeh1 xeh2) + (> (X-EventHandler-priority xeh1) + (X-EventHandler-priority xeh2)))))) ;;;###autoload (defun X-EventHandler-isset (evhlist handler &optional prioritiy evtypes-list) ＠＠ -237,9 +246,9 ＠＠ If event handler not found - nil will be (let ((evhs evhlist)) ;; Find appopriate handler (while (and evhs - (not (and (eq (X-EventHandler-handler (car evhs)) handler) - (if prioritiy (equal prioritiy (X-EventHandler-priority (car evhs))) t) - (if evtypes-list (equal evtypes-list (X-EventHandler-evtypes-list (car evhs))) t)))) + (not (and (eq (X-EventHandler-handler (car evhs)) handler) + (if prioritiy (equal prioritiy (X-EventHandler-priority (car evhs))) t) + (if evtypes-list (equal evtypes-list (X-EventHandler-evtypes-list (car evhs))) t)))) (setq evhs (cdr evhs))) (car evhs))) ＠＠ -272,15 +281,15 ＠＠ Return new list, use it like `(setq lst (defun X-EventHandler-runall (evhlist xev) "Run all event handlers in EVHLIST on XEV. Signal `X-Events-stop' to stop events processing." - (let ((evhs evhlist)) ; EVHS should be already sorted by priority + (let ((evhs evhlist)) ; EVHS should be already sorted by priority (condition-case nil - (while evhs - ;; Check is there appopriate event handler to handle XEV event. - (when (and (X-EventHandler-active (car evhs)) - (or (null (X-EventHandler-evtypes-list (car evhs))) - (memq (X-Event-type xev) (X-EventHandler-evtypes-list (car evhs))))) + (while evhs + ;; Check is there appopriate event handler to handle XEV event. + (when (and (X-EventHandler-active (car evhs)) + (or (null (X-EventHandler-evtypes-list (car evhs))) + (memq (X-Event-type xev) (X-EventHandler-evtypes-list (car evhs))))) (funcall (X-EventHandler-handler (car evhs)) (X-Event-dpy xev) (X-Event-win xev) xev)) - (setq evhs (cdr evhs))) + (setq evhs (cdr evhs))) (X-Events-stop nil)))) ;;; X Events description. ＠＠ -288,393 +297,392 ＠＠ Signal `X-Events-stop' to stop events pr ;; TODO: ;; - Should be X-Dpy depended to support extensions derived events (X-Event-define X-KeyPress "xkey" (keycode nil time root event child root-x root-y event-x event-y state same-screen) - [ "KeyPress" - ( [1 integerp] ; keycode - [2 integerp] ; sequence - [4 integerp] ; time - [4 :X-Win] ; root - [4 :X-Win] ; event - [4 :X-Win] ; child - [2 integerp] ; root_x - [2 integerp] ; root_y - [2 integerp] ; event_x - [2 integerp] ; event_y - [2 integerp] ; state - [1 booleanp] ; same_screen - [1 nil] ) - 4 ]) + "KeyPress" + ([1 integerp] ; keycode + [2 integerp] ; sequence + [4 integerp] ; time + [4 :X-Win] ; root + [4 :X-Win] ; event (WIN-EVENT) + [4 :X-Win] ; child + [2 integerp] ; root_x + [2 integerp] ; root_y + [2 integerp] ; event_x + [2 integerp] ; event_y + [2 integerp] ; state + [1 booleanp] ; same_screen + [1 nil]) + 4) (X-Event-declare X-KeyRelease - [ "KeyRelease" - ( [1 integerp] ; keycode - [2 integerp] ; sequence - [4 integerp] ; time - [4 :X-Win] ; root - [4 :X-Win] ; event - [4 :X-Win] ; child - [2 integerp] ; root_x - [2 integerp] ; root_y - [2 integerp] ; event_x - [2 integerp] ; event_y - [2 integerp] ; state - [1 booleanp] ; same_screen - [1 nil] ) - 4 ]) + "KeyRelease" + ([1 integerp] ; keycode + [2 integerp] ; sequence + [4 integerp] ; time + [4 :X-Win] ; root + [4 :X-Win] ; event + [4 :X-Win] ; child + [2 integerp] ; root_x + [2 integerp] ; root_y + [2 integerp] ; event_x + [2 integerp] ; event_y + [2 integerp] ; state + [1 booleanp] ; same_screen + [1 nil]) + 4) (X-Event-define X-ButtonPress "xbutton" (button nil time root event child root-x root-y event-x event-y state same-screen) - [ "ButtonPress" - ( [1 integerp] ; button - [2 integerp] ; sequence - [4 integerp] ; time - [4 :X-Win] ; root - [4 :X-Win] ; event - [4 :X-Win] ; child - [2 integerp] ; root_x - [2 integerp] ; root_y - [2 integerp] ; event_x - [2 integerp] ; event_y - [2 integerp] ; state - [1 booleanp] ; same_screen - [1 nil] ) - 4 ]) + "ButtonPress" + ( [1 integerp] ; button + [2 integerp] ; sequence + [4 integerp] ; time + [4 :X-Win] ; root + [4 :X-Win] ; event + [4 :X-Win] ; child + [2 integerp] ; root_x + [2 integerp] ; root_y + [2 integerp] ; event_x + [2 integerp] ; event_y + [2 integerp] ; state + [1 booleanp] ; same_screen + [1 nil] ) + 4) (X-Event-declare X-ButtonRelease - [ "ButtonRelease" - ( [1 integerp] ; button - [2 integerp] ; sequence - [4 integerp] ; time - [4 :X-Win] ; root - [4 :X-Win] ; event - [4 :X-Win] ; child - [2 integerp] ; root_x - [2 integerp] ; root_y - [2 integerp] ; event_x - [2 integerp] ; event_y - [2 integerp] ; state - [1 booleanp] ; same_screen - [1 nil] ) - 4 ]) + "ButtonRelease" + ( [1 integerp] ; button + [2 integerp] ; sequence + [4 integerp] ; time + [4 :X-Win] ; root + [4 :X-Win] ; event + [4 :X-Win] ; child + [2 integerp] ; root_x + [2 integerp] ; root_y + [2 integerp] ; event_x + [2 integerp] ; event_y + [2 integerp] ; state + [1 booleanp] ; same_screen + [1 nil] ) + 4) (X-Event-define X-MotionNotify "xmotion" (nil nil time root event child root-x root-y event-x event-y state same-screen) - [ "MotionNotify" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 integerp] ; time - [4 :X-Win] ; root - [4 :X-Win] ; event - [4 :X-Win] ; child - [2 integerp] ; root_x - [2 integerp] ; root_y - [2 integerp] ; event_x - [2 integerp] ; event_y - [2 integerp] ; state - [1 booleanp] ; same_screen - [1 nil] ) - 4 ]) + "MotionNotify" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 integerp] ; time + [4 :X-Win] ; root + [4 :X-Win] ; event + [4 :X-Win] ; child + [2 integerp] ; root_x + [2 integerp] ; root_y + [2 integerp] ; event_x + [2 integerp] ; event_y + [2 integerp] ; state + [1 booleanp] ; same_screen + [1 nil] ) + 4) (X-Event-define X-EnterNotify "xcrossing" (nil nil time root event child root-x root-y event-x event-y state mode same-screen-focus) - [ "EnterNotify" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 integerp] ; time - [4 :X-Win] ; root - [4 :X-Win] ; event - [4 :X-Win] ; child - [2 integerp] ; root_x - [2 integerp] ; root_y - [2 integerp] ; event_x - [2 integerp] ; event_y - [2 integerp] ; state - [1 integerp] ; mode - [1 integerp]) ; same-screen, focus - 4 ]) + "EnterNotify" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 integerp] ; time + [4 :X-Win] ; root + [4 :X-Win] ; event + [4 :X-Win] ; child + [2 integerp] ; root_x + [2 integerp] ; root_y + [2 integerp] ; event_x + [2 integerp] ; event_y + [2 integerp] ; state + [1 integerp] ; mode + [1 integerp]) ; same-screen, focus + 4) (X-Event-declare X-LeaveNotify - [ "LeaveNotify" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 integerp] ; time - [4 :X-Win] ; root - [4 :X-Win] ; event - [4 :X-Win] ; child - [2 integerp] ; root_x - [2 integerp] ; root_y - [2 integerp] ; event_x - [2 integerp] ; event_y - [2 integerp] ; state - [1 integerp] ; mode - [1 integerp] ) ; same-screen, focus - 4 ]) + "LeaveNotify" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 integerp] ; time + [4 :X-Win] ; root + [4 :X-Win] ; event + [4 :X-Win] ; child + [2 integerp] ; root_x + [2 integerp] ; root_y + [2 integerp] ; event_x + [2 integerp] ; event_y + [2 integerp] ; state + [1 integerp] ; mode + [1 integerp] ) ; same-screen, focus + 4) (X-Event-define X-FocusIn "xfocus" (nil nil event mode) - [ "FocusIn" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; event - [1 integerp] ; mode - [23 nil] ) - 2 ]) + "FocusIn" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; event + [1 integerp] ; mode + [23 nil] ) + 2) (X-Event-declare X-FocusOut - [ "FocusOut" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; event - [1 integerp] ; mode - [23 nil] ) - 2 ]) + "FocusOut" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; event + [1 integerp] ; mode + [23 nil] ) + 2) ;; TODO: X-KeymapNotify (X-Event-define X-Expose "xexpose" (nil nil window x y width height count) - [ "Expose" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; window - [2 integerp] ; x - [2 integerp] ; y - [2 integerp] ; width - [2 integerp] ; height - [2 integerp] ; count - [14 nil] ) - 2 ]) + "Expose" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; window + [2 integerp] ; x + [2 integerp] ; y + [2 integerp] ; width + [2 integerp] ; height + [2 integerp] ; count + [14 nil] ) + 2) (X-Event-define X-GraphicsExpose "xgraphicsexpose" (nil nil drawable x y width height minor-event count major-event) - [ "GraphicsExpose" - ([1 integerp] - [2 integerp] - [4 integerp] ; drawable - [2 integerp] ; x - [2 integerp] ; y - [2 integerp] ; width - [2 integerp] ; height - [2 integerp] ; minorEvent - [2 integerp] ; count - [1 integerp] ; majorEvent - [11 nil]) - 2 ]) + "GraphicsExpose" + ([1 integerp] + [2 integerp] + [4 integerp] ; drawable + [2 integerp] ; x + [2 integerp] ; y + [2 integerp] ; width + [2 integerp] ; height + [2 integerp] ; minorEvent + [2 integerp] ; count + [1 integerp] ; majorEvent + [11 nil]) + 2) (X-Event-define X-NoExpose "xnoexpose" (nil nil drawable minor-event major-event) - [ "NoExpose" - ([1 integerp] - [2 integerp] - [4 integerp] ; drawable - [2 integerp] ; minorEvent - [1 integerp] ; majorEvent - [21 nil]) - 2 ]) + "NoExpose" + ([1 integerp] + [2 integerp] + [4 integerp] ; drawable + [2 integerp] ; minorEvent + [1 integerp] ; majorEvent + [21 nil]) + 2) (X-Event-define X-VisibilityNotify "xvisibility" (nil nil window state) - [ "VisibilityNotify" - ([1 integerp] - [2 integerp] - [4 :X-Win] ; window - [1 integerp] ; state - [23 nil]) - 2 ]) + "VisibilityNotify" + ([1 integerp] + [2 integerp] + [4 :X-Win] ; window + [1 integerp] ; state + [23 nil]) + 2) (X-Event-define X-CreateNotify "xcreatewindow" (nil nil parent window x y width height border-width override) - [ "CreateNotify" - ([1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; parent window - [4 :X-Win] ; window - [2 integerp] ; x - [2 integerp] ; y - [2 integerp] ; width - [2 integerp] ; height - [2 integerp] ; border width - [1 booleanp] ; override-redirect - [9 nil]) - 2 ]) + "CreateNotify" + ([1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; parent window + [4 :X-Win] ; window + [2 integerp] ; x + [2 integerp] ; y + [2 integerp] ; width + [2 integerp] ; height + [2 integerp] ; border width + [1 booleanp] ; override-redirect + [9 nil]) + 2) (X-Event-define X-DestroyNotify "xdestroywindow" (nil nil event window) - [ "DestroyNotify" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; event window - [4 :X-Win] ; window - [20 nil]) - 3 ]) + "DestroyNotify" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; event window + [4 :X-Win] ; window + [20 nil]) + 3 2) (X-Event-define X-UnmapNotify "xunmap" (nil nil event window from-configure) - [ "UnmapNotify" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; event - [4 :X-Win] ; window - [1 booleanp] ; fromconfigure - [19 nil]) - 2 ]) + "UnmapNotify" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; event + [4 :X-Win] ; window + [1 booleanp] ; fromconfigure + [19 nil]) + 3 2) (X-Event-define X-MapNotify "xmap" (nil nil event window override) - [ "MapNotify" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; event window - [4 :X-Win] ; window - [1 booleanp] ; override-redirect - [19 nil]) - 2 ]) + "MapNotify" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; event window + [4 :X-Win] ; window + [1 booleanp] ; override-redirect + [19 nil]) + 3 2) (X-Event-define X-MapRequest "xmaprequest" (nil nil parent window) - [ "MapRequest" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; parent window - [4 :X-Win] ; window - [20 nil]) - 2 ]) + "MapRequest" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; parent window + [4 :X-Win] ; window + [20 nil]) + 3 2) (X-Event-define X-ReparentNotify "xreparent" (nil nil event window parent x y override) - [ "ReparentNotify" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; event - [4 :X-Win] ; window - [4 :X-Win] ; parent - [2 integerp] ; x - [2 integerp] ; y - [1 integerp] ; override - [11 nil]) - 2 ]) + "ReparentNotify" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; event + [4 :X-Win] ; window + [4 :X-Win] ; parent + [2 integerp] ; x + [2 integerp] ; y + [1 integerp] ; override + [11 nil]) + 3 2) (X-Event-define X-ConfigureNotify "xconfigure" (nil nil event window above-sibling x y width height border-width override-redirect) - [ "ConfigureNotify" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; event - [4 :X-Win] ; window - [4 :X-Win] ; above-sibling - [2 integerp] ; x - [2 integerp] ; y - [2 integerp] ; width - [2 integerp] ; height - [2 integerp] ; border-width - [1 booleanp] ; override-redirect - [5 nil] ) - 2 ]) + "ConfigureNotify" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; event + [4 :X-Win] ; window + [4 :X-Win] ; above-sibling + [2 integerp] ; x + [2 integerp] ; y + [2 integerp] ; width + [2 integerp] ; height + [2 integerp] ; border-width + [1 booleanp] ; override-redirect + [5 nil] ) + 3 2) (X-Event-define X-ConfigureRequest "xconfigurerequest" (stackmode nil parent window sibling x y width height border-width value-mask) - [ "ConfigureRequest" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; parent window - [4 :X-Win] ; window - [4 :X-Win] ; sibling - [2 integerp] ; x - [2 integerp] ; y - [2 integerp] ; width - [2 integerp] ; height - [2 integerp] ; border width - [2 integerp] ; value mask - [4 nil]) - 2 ]) + "ConfigureRequest" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; parent window + [4 :X-Win] ; window + [4 :X-Win] ; sibling + [2 integerp] ; x + [2 integerp] ; y + [2 integerp] ; width + [2 integerp] ; height + [2 integerp] ; border width + [2 integerp] ; value mask + [4 nil]) + 3 2) (X-Event-define X-GravityNotify "xgravity" (nil nil event window x y) - [ "GravityNotify" - ([1 integerp] - [2 integerp] - [4 :X-Win] ; event window - [4 :X-Win] ; window - [2 integerp] ; x - [2 integerp] ; y - [16 nil]) - 2 ]) + "GravityNotify" + ([1 integerp] + [2 integerp] + [4 :X-Win] ; event window + [4 :X-Win] ; window + [2 integerp] ; x + [2 integerp] ; y + [16 nil]) + 3 2) (X-Event-define X-ResizeRequest "xresizerequest" (nil nil window width height) - [ "ResizeRequest" - ( [1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; window - [2 integerp] ; width - [2 integerp] ; height - [20 nil] ) - 2 ]) + "ResizeRequest" + ( [1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; window + [2 integerp] ; width + [2 integerp] ; height + [20 nil] ) + 2) (X-Event-define X-CirculateNotify "xcirculate" (nil nil event window parent place) - [ "CirculateNotify" - ([1 integerp] - [2 integerp] - [4 :X-Win] ; event window - [4 :X-Win] ; window - [4 :X-Win] ; parent - [1 integerp] ; place - [15 nil]) - 2 ]) + "CirculateNotify" + ([1 integerp] + [2 integerp] + [4 :X-Win] ; event window + [4 :X-Win] ; window + [4 :X-Win] ; parent + [1 integerp] ; place + [15 nil]) + 3 2) ;; The event field in the xcirculate record is really the parent when this ;; is used as a CirculateRequest instead of a CircluateNotify (X-Event-declare X-CirculateRequest - [ "CirculateRequest" - ([1 integerp] - [2 integerp] - [4 :X-Win] ; event window - [4 :X-Win] ; window - [4 :X-Win] ; parent - [1 integerp] ; place - [15 nil]) - 2 ]) + "CirculateRequest" + ([1 integerp] + [2 integerp] + [4 :X-Win] ; event window + [4 :X-Win] ; window + [4 :X-Win] ; parent + [1 integerp] ; place + [15 nil]) + 3 2) (X-Event-define X-PropertyNotify "xproperty" (nil nil window atom time state) - [ "PropertyNotify" - ( [1 integerp] - [2 integerp] - [4 :X-Win] ; window - [4 :X-Atom] ; atom - [4 integerp] ; time - [1 integerp] ; state - [15 nil] - ) 2 ]) + "PropertyNotify" + ( [1 integerp] + [2 integerp] + [4 :X-Win] ; window + [4 :X-Atom] ; atom + [4 integerp] ; time + [1 integerp] ; state + [15 nil]) + 2) (X-Event-define X-SelectionClear "xselectionclear" (nil nil time window atom) - [ "SelectionClear" - ([1 integerp] - [2 integerp] - [4 integerp] ; time - [4 :X-Win] ; window - [4 :X-Atom] ; atom - [16 nil]) - 3 ]) + "SelectionClear" + ([1 integerp] + [2 integerp] + [4 integerp] ; time + [4 :X-Win] ; window + [4 :X-Atom] ; atom + [16 nil]) + 3) (X-Event-define X-SelectionRequest "xselectionrequest" (nil nil time owner requestor selection target property) - [ "SelectionRequest" - ([1 integerp] - [2 integerp] - [4 integerp] ; time - [4 :X-Win] ; owner - [4 :X-Win] ; requestor - [4 :X-Atom] ; selection atom - [4 :X-Atom] ; target atom - [4 :X-Atom] ; property atom - [4 nil]) - 4 ]) + "SelectionRequest" + ([1 integerp] + [2 integerp] + [4 integerp] ; time + [4 :X-Win] ; owner + [4 :X-Win] ; requestor + [4 :X-Atom] ; selection atom + [4 :X-Atom] ; target atom + [4 :X-Atom] ; property atom + [4 nil]) + 4) (X-Event-define X-SelectionNotify "xselection" (nil nil time requestor selection target property) - [ "SelectionNotify" - ([1 integerp] - [2 integerp] - [4 integerp] ; time - [4 :X-Win] ; requestor - [4 :X-Atom] ; selection atom - [4 :X-Atom] ; target atom - [4 :X-Atom] ; property atom - [8 nil]) - 3 ]) + "SelectionNotify" + ([1 integerp] + [2 integerp] + [4 integerp] ; time + [4 :X-Win] ; requestor + [4 :X-Atom] ; selection atom + [4 :X-Atom] ; target atom + [4 :X-Atom] ; property atom + [8 nil]) + 3) (X-Event-define X-ColormapNotify "xcolormap" (nil nil window colormap new state) - [ "ColormapNotify" - ([1 integerp] ; detail - [2 integerp] ; sequence - [4 :X-Win] ; window - [4 integerp] ; colormap - [1 booleanp] ; new - [1 booleanp] ; state - [18 nil]) - 2 ]) + "ColormapNotify" + ([1 integerp] ; detail + [2 integerp] ; sequence + [4 :X-Win] ; window + [4 integerp] ; colormap + [1 booleanp] ; new + [1 booleanp] ; state + [18 nil]) + 2) (X-Event-define X-ClientMessage "xclient" (nil window atom msg) - [ "ClientMessage" - ([1 length-1] ; format - [2 integerp] ; sequence number - [4 :X-Win] ; window - [4 :X-Atom] ; atom - ;; This reads in the correct number of integers of a type - ;; specified by the format which is 8, 16, or 32. - [(/ 20 (/ length-1 8)) ( [ (/ length-1 8) integerp ] ) ] ) - 1 ]) + "ClientMessage" + ([1 length-1] ; format + [2 integerp] ; sequence number + [4 :X-Win] ; window + [4 :X-Atom] ; atom + ;; This reads in the correct number of integers of a type + ;; specified by the format which is 8, 16, or 32. + [(/ 20 (/ length-1 8)) ( [ (/ length-1 8) integerp ] ) ] ) + 1) (X-Event-define X-MappingNotify "xmapping" (nil nil request first-keycode count) - [ "MappingNotify" - ([1 integerp] - [2 integerp] - [1 integerp] ; request - [1 integerp] ; firstKeyCode - [1 integerp] ; count - [25 nil]) - nil ]) + "MappingNotify" + ([1 integerp] + [2 integerp] + [1 integerp] ; request + [1 integerp] ; firstKeyCode + [1 integerp] ; count + [25 nil])) ;; error event (X-Event-define 0 "xerror" (code nil resourceid min-op maj-op) - ["XError" - ([1 integerp] ; err code - [2 integerp] ; sequence - [4 integerp] ; id - [2 integerp] ; minor opcode - [1 integerp] ; major opcode - [21 nil])]) - + "XError" + ([1 integerp] ; err code + [2 integerp] ; sequence + [4 integerp] ; id + [2 integerp] ; minor opcode + [1 integerp] ; major opcode + [21 nil])) + ;;; All receive message types will exclude the first byte which IDs it. ;; ;; a symbol gets 'set, functions such as integerp mean turn it into that, ＠＠ -685,74 +693,74 ＠＠ Signal `X-Events-stop' to stop events pr (defconst X-connect-response (list [1 success] - (list [1 length-1] ; fail message len - [2 integerp] ; major version - [2 integerp] ; minor version - [2 length-2] ; pad length - [length-1 stringp] ; error conditions - [(X-mod-4 length-1) nil] ; padding - ) - (list [1 nil] ; successful list (this is unused) - [2 integerp] ; major version - [2 integerp] ; minor version - [2 length-1] ; len additional data (pad) - [4 integerp] ; release number - [4 integerp] ; resource id base - [4 integerp] ; resource id mask - [4 integerp] ; motion buffer size - [2 length-2] ; vendor length - [2 integerp] ; max request len - [1 length-4] ; number of screens - [1 length-3] ; number of formats in pix list - [1 integerp] ; image byte order - [1 integerp] ; bitmap byte order - [1 integerp] ; bitmap format scanline thingy - [1 integerp] ; bitmap format scanline pad - [1 integerp] ; min keycode - [1 integerp] ; max keycode - [4 nil] ; unused - [length-2 stringp] ; the vendor - [(X-mod-4 length-2) nil] ; padding - [length-3 ; sublist of formats - ( [1 integerp] ; depth - [1 integerp] ; bits/pixel - [1 integerp] ; scanline-pad - [5 nil] ) ] ; padding - [length-4 - ( [4 integerp] ; root window - [4 integerp] ; colormap - [4 integerp] ; white-pixel - [4 integerp] ; black-pixel - [4 integerp] ; event-flags - [2 integerp] ; screen-width - [2 integerp] ; screen-height - [2 integerp] ; milimeters width - [2 integerp] ; milimeters height - [2 integerp] ; min-installed-maps - [2 integerp] ; max installed maps - [4 integerp] ; visualid - [1 integerp] ; backingstores - [1 booleanp] ; save-unders - [1 integerp] ; root depth - [1 length-1] ; # depths in depth - [length-1 ; list of depths - ( [1 integerp] ; depth - [1 nil] - [2 length-1] ; # visual types - [4 nil] - [length-1 ; the visuals - ( [4 integerp] ; visual id - [1 integerp] ; class - [1 integerp] ; bits/rgb value - [2 integerp] ; colormap entities - [4 integerp] ; red mask - [4 integerp] ; green mask - [4 integerp] ; blue mask - [4 nil]) - ] ) - ] ) - ] ) - ) + (list [1 length-1] ; fail message len + [2 integerp] ; major version + [2 integerp] ; minor version + [2 length-2] ; pad length + [length-1 stringp] ; error conditions + [(X-mod-4 length-1) nil] ; padding + ) + (list [1 nil] ; successful list (this is unused) + [2 integerp] ; major version + [2 integerp] ; minor version + [2 length-1] ; len additional data (pad) + [4 integerp] ; release number + [4 integerp] ; resource id base + [4 integerp] ; resource id mask + [4 integerp] ; motion buffer size + [2 length-2] ; vendor length + [2 integerp] ; max request len + [1 length-4] ; number of screens + [1 length-3] ; number of formats in pix list + [1 integerp] ; image byte order + [1 integerp] ; bitmap byte order + [1 integerp] ; bitmap format scanline thingy + [1 integerp] ; bitmap format scanline pad + [1 integerp] ; min keycode + [1 integerp] ; max keycode + [4 nil] ; unused + [length-2 stringp] ; the vendor + [(X-mod-4 length-2) nil] ; padding + [length-3 ; sublist of formats + ( [1 integerp] ; depth + [1 integerp] ; bits/pixel + [1 integerp] ; scanline-pad + [5 nil] ) ] ; padding + [length-4 + ( [4 integerp] ; root window + [4 integerp] ; colormap + [4 integerp] ; white-pixel + [4 integerp] ; black-pixel + [4 integerp] ; event-flags + [2 integerp] ; screen-width + [2 integerp] ; screen-height + [2 integerp] ; milimeters width + [2 integerp] ; milimeters height + [2 integerp] ; min-installed-maps + [2 integerp] ; max installed maps + [4 integerp] ; visualid + [1 integerp] ; backingstores + [1 booleanp] ; save-unders + [1 integerp] ; root depth + [1 length-1] ; # depths in depth + [length-1 ; list of depths + ( [1 integerp] ; depth + [1 nil] + [2 length-1] ; # visual types + [4 nil] + [length-1 ; the visuals + ( [4 integerp] ; visual id + [1 integerp] ; class + [1 integerp] ; bits/rgb value + [2 integerp] ; colormap entities + [4 integerp] ; red mask + [4 integerp] ; green mask + [4 integerp] ; blue mask + [4 nil]) + ] ) + ] ) + ] ) + ) "Connection response structure.") (defun X-invalidate-cl-struct (cl-x) ＠＠ -767,7 +775,7 ＠＠ NOTE: works only if CL-X is vector." ;;; Protecting macros (defmacro X-Dpy-read-excursion (xdpy &rest forms) "Execute FORMS in reading mode." - `(let ((gc-cons-threshold most-positive-fixnum)) ; inhibit GC'ing + `(let ((gc-cons-threshold most-positive-fixnum)) ; inhibit GC'ing (incf (X-Dpy-readings ,xdpy)) (prog1 (condition-case err ＠＠ -779,17 +787,12 ＠＠ NOTE: works only if CL-X is vector." (defun X-Dpy-send-read (xdpy s rf) "Send S to display XDPY and receive answer according to receive fields RF." - (let (reqid) - ;; Remember request id - (setq reqid (X-Dpy-rseq-id xdpy)) - - ;; Flush output buffer - (X-Dpy-send xdpy s) - (X-Dpy-send-flush xdpy) - + (let ((reqid (X-Dpy-rseq-id xdpy))) ; Remember request id (X-Dpy-read-excursion xdpy - (X-Dpy-parse-message rf reqid xdpy) - ))) + ;; Flush output buffer + (X-Dpy-send xdpy s) + (X-Dpy-send-flush xdpy) + (X-Dpy-parse-message rf reqid xdpy)))) ;;;###autoload (defvar X-default-timeout 60 ＠＠ -804,14 +807,14 ＠＠ NOTE: works only if CL-X is vector." (while (< (length (X-Dpy-message-buffer xdpy)) num) (when (null (accept-process-output (X-Dpy-proc xdpy) (or to-secs X-default-timeout) (or to-msecs 0))) - ;; Timeouted - (error "X: Timeout while reading from server."))) + ;; Timeouted + (error "X: Timeout while reading from server."))) (setq rstr (substring (X-Dpy-message-buffer xdpy) 0 num)) ; save bytes to string ;; Update message-buffer (setf (X-Dpy-message-buffer xdpy) - (substring (X-Dpy-message-buffer xdpy) num)) + (substring (X-Dpy-message-buffer xdpy) num)) rstr)) ;; These are defined so we can use them recursivly below ＠＠ -855,227 +858,320 ＠＠ A variable-length string can occur like (X-Dpy-p xdpy 'X-Dpy-parse-message) - (let ((rlist nil) - (reverse-me t) - (length-1 (if (boundp 'length-1) length-1 nil)) - (length-2 (if (boundp 'length-2) length-2 nil)) - (length-3 (if (boundp 'length-3) length-3 nil)) - (length-4 (if (boundp 'length-4) length-4 nil)) ) + (let ((inhibit-quit t) ; so C-g will not desync + (rlist nil) + (reverse-me t) + (length-1 (if (boundp 'length-1) length-1 nil)) + (length-2 (if (boundp 'length-2) length-2 nil)) + (length-3 (if (boundp 'length-3) length-3 nil)) + (length-4 (if (boundp 'length-4) length-4 nil)) ) (while (and message-s (listp message-s)) (let* ((tvec (car message-s)) - (tlen (aref tvec 0)) - (tval1 (aref tvec 1)) - (tval (if (and (listp tval1) - (member (car tval1) '(or if cond))) ;XXX - (eval tval1) - tval1)) - (result (unless (and tval (listp tval)) - ;; Do not grab bytes for sub-lists - (if (or (symbolp tlen) (listp tlen)) - (X-Dpy-grab-bytes xdpy (eval tlen)) - (X-Dpy-grab-bytes xdpy tlen))))) - - ;; We need to put in code to represent sizes sometimes, - ;; this will get that size. - (when (or (listp tlen) (symbolp tlen)) - (setq tlen (eval tlen))) - - ;; Check for use of an argument. - (when (equal tval 'arg) - (setq tval (car arglist)) - (setq arglist (cdr arglist))) - - ;; If the val is a list, and it is an if statement, then - ;; we want to evaluate it to get the real tval type. - (when (and (listp tval) - (member (car tval) '(if or make-list))) - (setq tval (eval tval))) - - (cond - ;; boolean success stories. - ((equal tval 'success) - (let ((sublst - (cond ((= (aref result 0) 1) - ;; success condition - (setq result t) - (X-Dpy-parse-message (car (cdr (cdr message-s))) req-id xdpy arglist)) - - (t - ;; Here is event or error arrived, process - ;; errors in time or store event in events - ;; queue. - (catch 'processed - - (condition-case xerr - (X-Dpy-parse-event xdpy (Xforcenum (aref result 0))) - (X-Error - ;; Here is if error's sequence numbers matches - ;; with last request sequence, then end response - ;; evaluating. - (X-Dpy-log xdpy 'x-error "Get ERROR seq: %d, rseq-id: %d" - '(X-Event-seq (cadr xerr)) 'req-id) - (when (= (X-Event-seq (cadr xerr)) (logand req-id 65535)) - (throw 'processed (setq result nil))))) - - ;; Repeat processing XXX excluding t or nil - (let ((pmsg (X-Dpy-parse-message message-s req-id xdpy arglist))) - (setq result (car pmsg)) - (cdr pmsg)))) - ))) - (setq rlist (cons result sublst))) - - (setq message-s nil) - (setq reverse-me nil)) - - ;; numberp means natural number, not safe! - ((eq tval 'numberp) - (setq rlist (cons (funcall (if (<= tlen 2) - 'string2->number - 'string4->number) result) - rlist))) - - ;; integerp means tac onto end of list as an int - ((eq tval 'integerp) - (if (<= tlen 2) - (setq rlist (cons (string->int result) rlist)) - (setq rlist (cons (string4->int result) rlist)))) - - ;; stringp means tac onto end of list as string (verbatim) - ((eq tval 'stringp) - (setq rlist (cons result rlist))) - - ;; booleans don't really exist, but turn a 0 into nil, and 1 into t - ((eq tval 'booleanp) - (setq rlist (cons (if (= 0 (string->int result)) nil t) rlist))) - - ;; TODO: maybe add card8, card16, card32, int8, int16, int32, - ;; string8, string16, etc? - - ;; Special forms - ((eq tval :X-Rect) - (setq tlen (/ tlen 8)) - (while (> tlen 0) - (setq rlist (cons (make-X-Rect :x (string->int (substring result 0 2)) - :y (string->int (substring result 2 4)) - :width (string->int (substring result 4 6)) - :height (string->int (substring result 6 8))) - rlist)) - (setq result (substring result 8)) - (setq tlen (1- tlen)))) - - ((eq tval :X-Win) - (setq tlen (/ tlen 4)) - (while (> tlen 0) - (setq rlist (cons (X-Win-find-or-make xdpy (string4->int result)) - rlist)) - (setq result (substring result 4)) - (setq tlen (1- tlen)))) - - ((eq tval :X-Atom) - (setq tlen (/ tlen 4)) - (while (> tlen 0) - (setq rlist (cons (X-Atom-find-or-make xdpy (string4->int result)) - rlist)) - (setq result (substring result 4)) - (setq tlen (1- tlen)))) - - ;; if it is a list, then we need to recursivly call ourselvs X - ;; times on it. - ((and tval (listp tval)) - ;; WARNING: subparts cannot use args. ;( - (let ((sublst nil)) - (while (> tlen 0) - (setq sublst (cons (X-Dpy-parse-message tval req-id xdpy arglist) sublst)) - (setq tlen (1- tlen))) - ;; The sub-list of items is backwards: fix - (setq rlist (cons (nreverse sublst) rlist)))) - - ;; not a type, but some other symbol, then put it there! - ;; if it is one of the lengththings, intify it. - ((and tval (symbolp tval) (not (keywordp tval))) - (if (string-match "length" (symbol-name tval)) - (set tval (string->int result)) - (set tval result))) - - ;; do nothing - ((equal tval nil)) - - ;; error case. - (t - (error "Error parsing X response!!!")))) + (tlen (aref tvec 0)) + (tval1 (aref tvec 1)) + (tval (if (and (listp tval1) + (member (car tval1) '(or if cond))) ;XXX + (eval tval1) + tval1)) + (result (unless (and tval (listp tval)) + ;; Do not grab bytes for sub-lists + (if (or (symbolp tlen) (listp tlen)) + (X-Dpy-grab-bytes xdpy (eval tlen)) + (X-Dpy-grab-bytes xdpy tlen))))) + + ;; We need to put in code to represent sizes sometimes, + ;; this will get that size. + (when (or (listp tlen) (symbolp tlen)) + (setq tlen (eval tlen))) + + ;; Check for use of an argument. + (when (equal tval 'arg) + (setq tval (car arglist)) + (setq arglist (cdr arglist))) + + ;; If the val is a list, and it is an if statement, then + ;; we want to evaluate it to get the real tval type. + (when (and (listp tval) + (member (car tval) '(if or make-list))) + (setq tval (eval tval))) + + (cond + ;; boolean success stories. + ((equal tval 'success) + (let ((sublst + (cond ((= (aref result 0) 1) + ;; success condition + (setq result t) + (X-Dpy-parse-message (car (cdr (cdr message-s))) + req-id xdpy arglist)) + + (t + ;; Here is event or error arrived, process + ;; errors in time or store event in events + ;; queue. + (X-Dpy-log xdpy 'x-event "!!: Inter Evaluating event ..") + (let ((xev (X-Dpy-parse-event + xdpy (Xforcenum (aref result 0)))) + pmsg) + (prog1 + (if (and (= (X-Event-type xev) 0) + (= (X-Event-seq xev) + (logand req-id 65535))) + ;; Error of current request + (setq result nil) + + ;; Repeat processing XXX excluding t or nil + (X-Dpy-log xdpy 'x-event "!!: Reprocessing: %d bytes pending, msg=%S" + '(length (X-Dpy-message-buffer xdpy)) 'message-s) + (setq pmsg (X-Dpy-parse-message + message-s req-id xdpy arglist) + result (car pmsg)) + (X-Dpy-log xdpy 'x-event "!!: Reprocessing done %d bytes pending." + '(length (X-Dpy-message-buffer xdpy))) + (cdr pmsg)) + (X-Dpy-dispatch-event xev))))))) + (setq rlist (cons result sublst))) + + (setq message-s nil) + (setq reverse-me nil)) + + ;; numberp means natural number, not safe! + ((eq tval 'numberp) + (setq rlist (cons (funcall (if (<= tlen 2) + 'string2->number + 'string4->number) result) + rlist))) + + ;; integerp means tac onto end of list as an int + ((eq tval 'integerp) + (if (<= tlen 2) + (setq rlist (cons (string->int result) rlist)) + (setq rlist (cons (string4->int result) rlist)))) + + ;; stringp means tac onto end of list as string (verbatim) + ((eq tval 'stringp) + (setq rlist (cons result rlist))) + + ;; booleans don't really exist, but turn a 0 into nil, and 1 into t + ((eq tval 'booleanp) + (setq rlist (cons (if (= 0 (string->int result)) nil t) rlist))) + + ;; TODO: maybe add card8, card16, card32, int8, int16, int32, + ;; string8, string16, etc? + + ;; Special forms + ((eq tval :X-Rect) + (setq tlen (/ tlen 8)) + (while (> tlen 0) + (setq rlist (cons (make-X-Rect :x (string->int (substring result 0 2)) + :y (string->int (substring result 2 4)) + :width (string->int (substring result 4 6)) + :height (string->int (substring result 6 8))) + rlist)) + (setq result (substring result 8)) + (setq tlen (1- tlen)))) + + ((eq tval :X-Win) + (setq tlen (/ tlen 4)) + (while (> tlen 0) + (setq rlist (cons (X-Win-find-or-make xdpy (string4->int result)) + rlist)) + (setq result (substring result 4)) + (setq tlen (1- tlen)))) + + ((eq tval :X-Atom) + (setq tlen (/ tlen 4)) + (while (> tlen 0) + (setq rlist (cons (X-Atom-find-or-make xdpy (string4->int result)) + rlist)) + (setq result (substring result 4)) + (setq tlen (1- tlen)))) + + ;; if it is a list, then we need to recursivly call ourselvs X + ;; times on it. + ((and tval (listp tval)) + ;; WARNING: subparts cannot use args. ;( + (let ((sublst nil)) + (while (> tlen 0) + (setq sublst (cons (X-Dpy-parse-message tval req-id xdpy arglist) sublst)) + (setq tlen (1- tlen))) + ;; The sub-list of items is backwards: fix + (setq rlist (cons (nreverse sublst) rlist)))) + + ;; not a type, but some other symbol, then put it there! + ;; if it is one of the lengththings, intify it. + ((and tval (symbolp tval) (not (keywordp tval))) + (if (string-match "length" (symbol-name tval)) + (set tval (string->int result)) + (set tval result))) + + ;; do nothing + ((equal tval nil)) + + ;; error case. + (t + (error "Error parsing X response!!!")))) (setq message-s (cdr message-s))) ;; Now that that is over, conditionally reverse the list. (if reverse-me - (nreverse rlist) + (nreverse rlist) rlist))) (defun X-Dpy-eval-error-or-event (xdpy) "There data on XDPY, it is error or event." (X-Dpy-read-excursion xdpy (let* ((result (X-Dpy-grab-bytes xdpy 1)) - (evetype (Xforcenum (aref result 0)))) + (evetype (Xforcenum (aref result 0)))) - (cond ((= evetype 1) ; reply, should not happen - (X-Dpy-log xdpy 'x-error "Got unknown reply") - nil) - - (t (X-Dpy-parse-event xdpy evetype))) ; error or event + (cond ((= evetype 1) ; reply, should not happen + (X-Dpy-log xdpy 'x-error "Got unknown reply, while expecting XEvent! CRITICAL!") + (error "Got unknown reply, while expecting XEvent!")) + ;; Below code is not quite correct. Because X exntensions + ;; that generates events may use values greater then + ;; X-MaxEvent. +; ((>= evetype X-MaxEvent) +; (X-Dpy-log xdpy 'x-error "Got XEvent id(%d) greater than X-MaxEvent! CRITICAL!" +; 'evetype) +; (error (format "Got X Event id(%d) greater than X-MaxEvent!" evetype))) + (t (X-Dpy-dispatch-event + (X-Dpy-parse-event xdpy evetype)))) ; error or event ))) ;; Events/Errors dispatchers +(defvar xlib-opcodes-alist + '((104 . XBell) + (1 . XCreateWindow) + (2 . XChangeWindowAttributes) + (3 . XGetWindowAttributes) + (12 . XConfigureWindow) + (8 . XMapWindow) + (10 . XUnmapWindow) + (4 . XDestroyWindow) + (5 . XDestroySubwindows) + (15 . XQueryTree) + (16 . XInternAtom) + (17 . XGetAtomName) + (18 . XChangeProperty) + (20 . XGetWindowProperty) + (78 . XCreateColormap) + (79 . XFreeColormap) + (84 . XAllocColor) + (85 . XAllocNamedColor) + (86 . XAllocColorCells) + (89 . XStoreColors) + (88 . XFreeColors) + (91 . XQueryColors) + (55 . XCreateGC) + (56 . XChangeGC) + (58 . XSetDashes) + (59 . XSetClipRectangles) + (60 . XFreeGC) + (61 . XClearArea) + (62 . XCopyArea) + (63 . XCopyPlane) + (64 . XDrawPoints) + (65 . XDrawLines) + (69 . XFillPoly) + (66 . XDrawSegments) + (67 . XDrawRectangles) + (70 . XDrawRectangles) + (68 . XDrawArcs) + (71 . XDrawArcs) + (74 . XDrawString) + (76 . XImageString) + (72 . XPutImage) + (73 . XGetImage) + (22 . XSetSelectionOwner) + (23 . XGetSelectionOwner) + (24 . XConvertSelection) + (41 . XWarpPointer) + (36 . XGrabServer) + (37 . XUngrabServer) + (38 . XQueryPointer) + (31 . XGrabKeyboard) + (32 . XUngrabKeyboard) + (26 . XGrabPointer) + (27 . XUngrabPointer) + (28 . XGrabButton) + (29 . XUngrabButton) + (33 . XGrabKey) + (34 . XUngrabKey) + (43 . XGetInputFocus) + (42 . XSetInputFocus) + (7 . XReparentWindow) + (14 . XGetGeometry) + (40 . XTranslateCoordinates) + (6 . XChangeSaveSet) + (25 . XSendEvent) + (44 . XQueryKeymap) + (101 . XGetKeyboardMapping) + (119 . XGetModifierMapping) + (45 . XOpenFont) + (47 . XQueryFont) + (48 . XQueryTextExtents) + (53 . XCreatePixmap) + (54 . XFreePixmap) + (93 . XCreateCursor) + (94 . XCreateGlyphCursor) + (95 . XFreeCursor) + (96 . XRecolorCursor) + (30 . XChangeActivePointerGrab) + (98 . XQueryExtension) + (107 . XSetScreenSaver) + (108 . XGetScreenSaver) + (113 . XKillClient) + (115 . XForceScreenSaver)) + "Alist of X opcodes in form (OPCODE . FUNCTION). +This is only informative variable.") + +(defun X-Dpy-run-error-hooks (xdpy xev) + "Run XDPY's error hooks." + (when (X-Dpy-error-hooks xdpy) + (mapcar #'(lambda (fun) + (funcall fun xdpy xev)) + (X-Dpy-error-hooks xdpy)))) + (defun X-Dpy-error-dispatch (xev) "Dispatch error event XEV." - (let ((xdpy (X-Event-dpy xev))) - (cond ((= (X-Event-xerror-code xev) 2) - (X-Dpy-log xdpy 'x-error "Bad value %s sequence %d ops %d %d" - '(Xmask-string (X-Event-xerror-resourceid xev)) - '(X-Event-seq xev) - '(X-Event-xerror-maj-op xev) - '(X-Event-xerror-min-op xev))) - - ((= (X-Event-xerror-code xev) 3) - (X-Dpy-log xdpy 'x-error "Bad window %.0f sequence %d ops %d %d" - '(X-Event-xerror-resourceid xev) - '(X-Event-seq xev) - '(X-Event-xerror-maj-op xev) - '(X-Event-xerror-min-op xev))) - ((= (X-Event-xerror-code xev) 9) - (X-Dpy-log xdpy 'x-error "Bad Drawable %.0f sequence %d ops %d %d" - '(X-Event-xerror-resourceid xev) - '(X-Event-seq xev) - '(X-Event-xerror-maj-op xev) - '(X-Event-xerror-min-op xev))) - - ((= (X-Event-xerror-code xev) 11) - (X-Dpy-log xdpy 'x-error "Alloc failure id=%.0f" '(X-Event-xerror-resourceid xev))) - - ((= (X-Event-xerror-code xev) 14) - (X-Dpy-log xdpy 'x-error "Bad id %s sequence %d ops %d %d" - '(Xmask-string (X-Event-xerror-resourceid xev)) - '(X-Event-seq xev) - '(X-Event-xerror-maj-op xev) - '(X-Event-xerror-min-op xev))) - - ((= (X-Event-xerror-code xev) 16) - (X-Dpy-log xdpy 'x-error "Length error! sequence %d ops %d %d" - '(X-Event-seq xev) - '(X-Event-xerror-maj-op xev) - '(X-Event-xerror-min-op xev))) - - (t - (X-Dpy-log xdpy 'x-error "Got error event %d!!!" '(X-Event-xerror-code xev)))) + (let* ((xdpy (X-Event-dpy xev)) + (err (X-Event-xerror-code xev)) + (badth (X-Event-xerror-resourceid xev)) + (seq (X-Event-seq xev)) + (maj (X-Event-xerror-maj-op xev)) + (opfun (cdr (assq maj xlib-opcodes-alist))) + (min (X-Event-xerror-min-op xev)) + (bstr (cond ((= err 1) "Request") + ((= err 2) "Value") + ((= err 3) "Window") + ((= err 4) "Pixmap") + ((= err 5) "Atom") + ((= err 6) "Cursor") + ((= err 7) "Font") + ((= err 8) "Match") + ((= err 9) "Drawable") + ((= err 10) "Access") + ((= err 11) "Alloc") + ((= err 12) "Color") + ((= err 13) "GC") + ((= err 14) "IDChoice") + ((= err 15) "Name") + ((= err 16) "Length") + ((= err 17) "Implementation") + ((= err 128) "FirstExtension") + ((= err 255) "LastExtension") + (t "Unknown")))) + (declare (special bstr)) + (declare (special min)) + (declare (special opfun)) + (declare (special seq)) + (declare (special badth)) + (X-Dpy-log xdpy 'x-error "X-Error: Bad %s %f seq=%f:%d ops=%d:%d/%S" + 'bstr 'badth 'seq '(X-Dpy-rseq-id xdpy) 'maj 'min 'opfun) ;; Now run hooks if any - (when (X-Dpy-error-hooks xdpy) - (mapcar (lambda (fun) - (funcall fun xdpy xev)) - (X-Dpy-error-hooks xdpy))) + (X-Dpy-run-error-hooks xdpy xev))) - ;; Finnally signal an error. - (error 'X-Error xev) - )) - ;;; Some usefull macroses (NOT USED) (defmacro X-Generic-enqueue (obj queue) "Enqueue object QBJ into setf'able QUEUE." ＠＠ -1094,55 +1190,63 ＠＠ A variable-length string can occur like obj)) ;;; Events queue support +(defun X-Dpy-default-events-dispatcher (xdpy xev) + "Default events dispatcher." + (let ((win-ev (X-Event-win-event xev))) + (when (X-Win-p win-ev) + ;; First run display handlers + (when (X-Dpy-event-handlers xdpy) + (X-Dpy-EventHandler-runall xdpy xev)) + + ;; Then run WIN specific handlers + (when (X-Win-event-handlers win-ev) + ;; WIN has its own event handlers + (X-Win-EventHandler-runall win-ev xev))))) + (defun X-Dpy-event-dispatch (xev) "Dispatch event XEV." - (let ((win (X-Event-win xev)) - (xdpy (X-Event-dpy xev))) - - (X-Dpy-log xdpy 'x-event "Ready to dispatch event: %S for win %S" - '(X-Event-name xev) '(if (X-Win-p (X-Event-win xev)) - (X-Win-id (X-Event-win xev)) - (X-Event-win xev))) + (let ((xdpy (X-Event-dpy xev))) + (X-Dpy-log xdpy 'x-event "Got X event: %S for win %S / %S" + '(X-Event-name xev) + '(if (X-Win-p (X-Event-win-event xev)) + (X-Win-id (X-Event-win-event xev)) + (X-Event-win-event xev)) + '(if (X-Win-p (X-Event-win xev)) + (X-Win-id (X-Event-win xev)) + (X-Event-win xev))) (when (X-Dpy-events-dispatcher xdpy) - (funcall (X-Dpy-events-dispatcher xdpy) xdpy win xev)) - )) + (funcall (X-Dpy-events-dispatcher xdpy) xdpy xev)))) -(defsubst X-Dpy-event-enqueue (xdpy event) +(defsubst X-Dpy-event-enqueue (event) "Enqueue EVENT in XDPY's events queue." (enqueue-eval-event 'X-Dpy-event-dispatch event)) +(defun X-Dpy-dispatch-event (xev) + "Dispatch X Event or error XEV." + (if (= (X-Event-type xev) 0) + (X-Dpy-error-dispatch xev) + (X-Dpy-event-enqueue xev))) + (defun X-Dpy-parse-event (xdpy evtype) "On XDPY construct and enqueue event of EVTYPE type." - (X-Dpy-log xdpy 'x-event "XLIB: Getting event ....") - ;; TODO: what about X-Event-evdata? ;; (evdata (substring (X-Dpy-message-buffer xdpy) 0 31)) ;; :evdata (concat (char-to-string (XCharacter type)) evdata) (X-Dpy-read-excursion xdpy (let* ((type evtype) - (synth (= (logand X-SyntheticMask type) X-SyntheticMask)) - (type (if synth (- type X-SyntheticMask) type)) - (xev (make-X-Event :dpy xdpy :type type :synth-p synth)) - (evspec (aref X-EventsList type)) - (evin (X-Dpy-parse-message (or (and evspec (aref evspec 1)) (list [31 nil])) 0 xdpy))) + (synth (= (logand X-SyntheticMask type) X-SyntheticMask)) + (type (if synth (- type X-SyntheticMask) type)) + (xev (make-X-Event :dpy xdpy :type type :synth-p synth)) + (evspec (aref X-EventsList type)) + (evin (X-Dpy-parse-message (or (and evspec (aref evspec 1)) (list [31 nil])) 0 xdpy))) (setf (X-Event-evinfo xev) evin) -;;; Commented out, because causes some problems -;; ;; Here is special case of DestroyNotify event. We dont want to -;; ;; keep X-Win structure in xdpy's windows list, because there -;; ;; will be no other way remove it, and someday XDPY's windows -;; ;; list will became huge. -;; (when (= (X-Event-type xev) X-DestroyNotify) -;; (X-Dpy-log xdpy 'x-event "XDPY Removing window from XDPY: %S" -;; '(X-Win-id (X-Event-xdestroywindow-window xev))) -;; (X-Win-invalidate xdpy (X-Event-xdestroywindow-window xev))) - - (if (= (X-Event-type xev) 0) - ;; Dispatch this error - (X-Dpy-error-dispatch xev) + (X-Dpy-log xdpy 'x-event "XLIB: Get new event %d(%s) win=%S ...." + '(X-Event-type xev) '(X-Event-name xev) + '(and (X-Win-p (X-Event-win xev)) + (X-Win-id (X-Event-win xev)))) - (X-Dpy-event-enqueue xdpy xev)) xev))) ;;; Function to call when there data in XDPY, but noone reading it. ＠＠ -1152,9 +1256,9 ＠＠ Try to guess what it is." (X-Dpy-p xdpy 'X-Dpy-parse-message-guess) ;; If no-one reading now, mean than error or event arrived. - (when (zerop (X-Dpy-readings xdpy)) - (while (> (length (X-Dpy-message-buffer xdpy)) 0) - (X-Dpy-eval-error-or-event xdpy)))) + (while (and (zerop (X-Dpy-readings xdpy)) + (> (length (X-Dpy-message-buffer xdpy)) 0)) + (X-Dpy-eval-error-or-event xdpy)))  (provide 'xlib-xr) 1.8 +277 -262 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xrecord.el Index: xlib-xrecord.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xrecord.el,v retrieving revision 1.7 retrieving revision 1.8 diff -u -p -r1.7 -r1.8 --- xlib-xrecord.el 2005/01/01 04:40:17 1.7 +++ xlib-xrecord.el 2005/04/04 19:55:30 1.8 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xrecord.el --- RECORD extension for xlib. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: 18 October 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xrecord.el,v 1.7 2005/01/01 04:40:17 youngs Exp $ +;; X-CVS: $Id: xlib-xrecord.el,v 1.8 2005/04/04 19:55:30 lg Exp $ ;; This file is part of XWEM. ＠＠ -72,56 +72,91 ＠＠ (defconst X-XRecordEndOfData 5)  +;; Message generators +(defsubst X-RecordRange8-message (xrr8) + "Return a string representing the record range8 XRR8." + (if (null xrr8) + (make-string 2 ?\x00) + (concat (int->string1 (car xrr8)) (int->string1 (cdr xrr8))))) + +(defsubst X-RecordRange16-message (xrr16) + "Return a string representing the record range16 XRR16." + (if (null xrr16) + (make-string 4 ?\x00) + (concat (int->string2 (car xrr16)) (int->string2 (cdr xrr16))))) + +(defsubst X-RecordExtrange-message (xer) + "Return a string representing the extrange XER." + (if (null xer) + (make-string 12 ?\x00) + (concat (X-RecordRange8-message (car xer)) (X-RecordRange16-message (cdr xer))))) + +(defsubst X-RecordRange-message (xrr) + "Return a string representing the record range XRR." + (X-Generate-simple-message 'X-RecordRange xrr)) + +(defsubst X-RecordClientSpec-message (xrcs) + "Return a string representing the client spec XRCS." + (int->string4 xrcs)) + (defstruct (X-RecordContext (:predicate X-RecordContext-isrc-p)) dpy id - props) ; User defined plist + props) ; User defined plist (defstruct (X-RecordExtrange (:predicate X-RecordExtrange-isrer-p)) - major ; X-RecordRange8 - minor ; X-RecordRange16 + major ; X-RecordRange8 + minor ; X-RecordRange16 ;; List of extractors (list '(((lambda (re) - (X-RecordRange8-message (X-RecordExtrange-major re))) . 2) - ((lambda (re) - (X-RecordRange16-message (X-RecordExtrange-minor re))) . 4))) + (X-RecordRange8-message (X-RecordExtrange-major re))) . 2) + ((lambda (re) + (X-RecordRange16-message (X-RecordExtrange-minor re))) . 4))) ) (defstruct (X-RecordRange (:predicate X-RecordRange-isrr-p)) - core-requests ; X-RecordRange8 - core-replies ; X-RecordRange8 - ext-requests ; X-RecordExtrange - ext-replies ; X-RecordExtrange - delivered-events ; X-RecordRange8 - device-events ; X-RecordRange8 - errors ; X-RecordRange8 - client-started ; BOOL - client-died ; BOOL + core-requests ; X-RecordRange8 + core-replies ; X-RecordRange8 + ext-requests ; X-RecordExtrange + ext-replies ; X-RecordExtrange + delivered-events ; X-RecordRange8 + device-events ; X-RecordRange8 + errors ; X-RecordRange8 + client-started ; BOOL + client-died ; BOOL ;; List of extractors - (list '(((lambda (rr) - (X-RecordRange8-message (X-RecordRange-core-requests rr))) . 2) - ((lambda (rr) - (X-RecordRange8-message (X-RecordRange-core-replies rr))) . 2) - ((lambda (rr) - (X-RecordExtrange-message (X-RecordRange-ext-requests rr))) . 6) - ((lambda (rr) - (X-RecordExtrange-message (X-RecordRange-ext-replies rr))) . 6) - ((lambda (rr) - (X-RecordRange8-message (X-RecordRange-delivered-events rr))) . 2) - ((lambda (rr) - (X-RecordRange8-message (X-RecordRange-device-events rr))) . 2) - ((lambda (rr) - (X-RecordRange8-message (X-RecordRange-errors rr))) . 2) - (X-RecordRange-client-started . 1) - (X-RecordRange-client-died . 1)))) + (list (list + (cons #'(lambda (rr) + (X-RecordRange8-message (X-RecordRange-core-requests rr))) + 2) + (cons #'(lambda (rr) + (X-RecordRange8-message (X-RecordRange-core-replies rr))) + 2) + (cons #'(lambda (rr) + (X-RecordExtrange-message (X-RecordRange-ext-requests rr))) + 6) + (cons #'(lambda (rr) + (X-RecordExtrange-message (X-RecordRange-ext-replies rr))) + 6) + (cons #'(lambda (rr) + (X-RecordRange8-message (X-RecordRange-delivered-events rr))) + 2) + (cons #'(lambda (rr) + (X-RecordRange8-message (X-RecordRange-device-events rr))) + 2) + (cons #'(lambda (rr) + (X-RecordRange8-message (X-RecordRange-errors rr))) + 2) + (cons 'X-RecordRange-client-started 1) + (cons 'X-RecordRange-client-died 1)))) (defstruct (X-RecordClientInfo (:predicate X-RecordClientInfo-isrci-p)) - client-spec ; X-RecordClientSpec - ranges) ; list of X-RecordRange + client-spec ; X-RecordClientSpec + ranges) ; list of X-RecordRange (defstruct X-RecordState - enabled ; BOOL - datum-flags ; int - client-infos ; list of X-RecordClientInfo + enabled ; BOOL + datum-flags ; int + client-infos ; list of X-RecordClientInfo )  ＠＠ -147,33 +182,6 ＠＠ (defsubst X-RecordClientInfo-p (xrci &optional sig) (X-Generic-p 'X-RecordClientInfo 'X-RecordClientInfo-isrci-p xrci sig)) -;; Message generators -(defsubst X-RecordRange8-message (xrr8) - "Return a string representing the record range8 XRR8." - (if (null xrr8) - (make-string 2 ?\x00) - (concat (int->string1 (car xrr8)) (int->string1 (cdr xrr8))))) - -(defsubst X-RecordRange16-message (xrr16) - "Return a string representing the record range16 XRR16." - (if (null xrr16) - (make-string 4 ?\x00) - (concat (int->string2 (car xrr16)) (int->string2 (cdr xrr16))))) - -(defsubst X-RecordExtrange-message (xer) - "Return a string representing the extrange XER." - (if (null xer) - (make-string 12 ?\x00) - (concat (X-RecordRange8-message (car xer)) (X-RecordRange16-message (cdr xer))))) - -(defsubst X-RecordRange-message (xrr) - "Return a string representing the record range XRR." - (X-Generate-simple-message 'X-RecordRange xrr)) - -(defsubst X-RecordClientSpec-message (xrcs) - "Return a string representing the client spec XRCS." - (int->string4 xrcs)) -  ;;; Functions (defun X-XRecordQueryVersion (xdpy &optional major minor) ＠＠ -181,23 +189,23 ＠＠ (X-Dpy-p xdpy 'X-XRecordQueryVersion) (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD")) - (ListOfFields - (list (vector 1 (nth 4 xrec-ext)) ; opcode - [1 X-XRecord-op-QueryVersion] - [2 2] ;length - - [2 (or major X-XRecord-major)] - [2 (or minor X-XRecord-minor)])) - (msg (X-Create-message ListOfFields)) - (ReceiveFields - (list [1 success] ;success field - nil - (list [1 nil] ;not used - [2 integerp] ;sequence number - [4 nil] ;length - [2 integerp] ;major version - [2 integerp] ;minor version - [20 nil])))) ;pad + (ListOfFields + (list (vector 1 (nth 4 xrec-ext)) ; opcode + [1 X-XRecord-op-QueryVersion] + [2 2] ;length + + [2 (or major X-XRecord-major)] + [2 (or minor X-XRecord-minor)])) + (msg (X-Create-message ListOfFields)) + (ReceiveFields + (list [1 success] ;success field + nil + (list [1 nil] ;not used + [2 integerp] ;sequence number + [4 nil] ;length + [2 integerp] ;major version + [2 integerp] ;minor version + [20 nil])))) ;pad (and (car xrec-ext) (X-Dpy-send-read xdpy msg ReceiveFields)))) ＠＠ -211,19 +219,19 ＠＠ RANGES is list of X-RecordRange." (X-Dpy-p xdpy 'X-XRecordCreateContext) (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordCreateContext)) - (ListOfFields - (list (vector 1 (nth 4 xrec-ext)) ;opcode - [1 X-XRecord-op-CreateContext] - [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ;length - - [4 (X-RecordContext-id rc)] ; context - [1 elhead] - [3 nil] ; not used - [4 (length clspecs)] - [4 (length ranges)])) - (msg (concat (X-Create-message ListOfFields) - (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message) - (X-Generate-message-for-list ranges 'X-RecordRange-message)))) + (ListOfFields + (list (vector 1 (nth 4 xrec-ext)) ;opcode + [1 X-XRecord-op-CreateContext] + [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ;length + + [4 (X-RecordContext-id rc)] ; context + [1 elhead] + [3 nil] ; not used + [4 (length clspecs)] + [4 (length ranges)])) + (msg (concat (X-Create-message ListOfFields) + (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message) + (X-Generate-message-for-list ranges 'X-RecordRange-message)))) (X-Dpy-send xdpy msg) rc)) ＠＠ -233,18 +241,18 ＠＠ RANGES is list of X-RecordRange." (X-RecordContext-p rc 'X-XRecordRegisterClients) (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordRegisterClients)) - (ListOfFields - (list (vector 1 (nth 4 xrec-ext)) ; opcode - [1 X-XRecord-op-RegisterClients] - [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ; length - [4 (X-RecordContext-id rc)] - [1 elhead] - [3 nil] ; not used - [4 (length clspecs)] - [4 (length ranges)])) - (msg (concat (X-Create-message ListOfFields) - (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message) - (X-Generate-message-for-list ranges 'X-RecordRange-message)))) + (ListOfFields + (list (vector 1 (nth 4 xrec-ext)) ; opcode + [1 X-XRecord-op-RegisterClients] + [2 (+ 5 (length clspecs) (* 6 (length ranges)))] ; length + [4 (X-RecordContext-id rc)] + [1 elhead] + [3 nil] ; not used + [4 (length clspecs)] + [4 (length ranges)])) + (msg (concat (X-Create-message ListOfFields) + (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message) + (X-Generate-message-for-list ranges 'X-RecordRange-message)))) (X-Dpy-send xdpy msg))) (defun X-XRecordUnregisterClients (xdpy rc clspecs) ＠＠ -253,14 +261,14 ＠＠ RANGES is list of X-RecordRange." (X-RecordContext-p rc 'X-XRecordRegisterClients) (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordRegisterClients)) - (ListOfFields - (list (vector 1 (nth 4 xrec-ext)) ; opcode - [1 X-XRecord-op-UnregisterClients] - [2 (+ 3 (length clspecs))] ; length - [4 (X-RecordContext-id rc)] - [4 (length clspecs)])) - (msg (concat (X-Create-message ListOfFields) - (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message)))) + (ListOfFields + (list (vector 1 (nth 4 xrec-ext)) ; opcode + [1 X-XRecord-op-UnregisterClients] + [2 (+ 3 (length clspecs))] ; length + [4 (X-RecordContext-id rc)] + [4 (length clspecs)])) + (msg (concat (X-Create-message ListOfFields) + (X-Generate-message-for-list clspecs 'X-RecordClientSpec-message)))) (X-Dpy-send xdpy msg))) (defun X-XRecordGetContext (xdpy rc) ＠＠ -269,52 +277,52 ＠＠ RANGES is list of X-RecordRange." (X-RecordContext-p rc 'X-XRecordRegisterClients) (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext)) - (ListOfFields - (list (vector 1 (nth 4 xrec-ext)) ; opcode - [1 X-XRecord-op-GetContext] - [2 2] ; length - [4 (X-RecordContext-id rc)])) ; context - (msg (concat (X-Create-message ListOfFields))) - (ReceiveFields - (list [1 success] ;success field - nil - (list [1 integerp] ;enabled - [2 integerp] ;sequence number - [4 length-1] ;length - [1 integerp] ;elhead - [3 nil] ;not used - [4 length-2] ;n, number of intercepted-clients - [16 nil] ;not used - [length-2 ([4 integerp] - [4 length-3] - [length-3 - ([1 integerp] - [1 integerp] - - [1 integerp] - [1 integerp] - - [1 integerp] - [1 integerp] - [2 integerp] - [2 integerp] - - [1 integerp] - [1 integerp] - [2 integerp] - [2 integerp] - - [1 integerp] - [1 integerp] - - [1 integerp] - [1 integerp] - - [1 integerp] - [1 integerp] - - [1 booleanp] - [1 booleanp])])])))) + (ListOfFields + (list (vector 1 (nth 4 xrec-ext)) ; opcode + [1 X-XRecord-op-GetContext] + [2 2] ; length + [4 (X-RecordContext-id rc)])) ; context + (msg (concat (X-Create-message ListOfFields))) + (ReceiveFields + (list [1 success] ;success field + nil + (list [1 integerp] ;enabled + [2 integerp] ;sequence number + [4 length-1] ;length + [1 integerp] ;elhead + [3 nil] ;not used + [4 length-2] ;n, number of intercepted-clients + [16 nil] ;not used + [length-2 ([4 integerp] + [4 length-3] + [length-3 + ([1 integerp] + [1 integerp] + + [1 integerp] + [1 integerp] + + [1 integerp] + [1 integerp] + [2 integerp] + [2 integerp] + + [1 integerp] + [1 integerp] + [2 integerp] + [2 integerp] + + [1 integerp] + [1 integerp] + + [1 integerp] + [1 integerp] + + [1 integerp] + [1 integerp] + + [1 booleanp] + [1 booleanp])])])))) (X-Dpy-send-read xdpy msg ReceiveFields))) ; (X-log dpy "Get X-XRecordGetContext replay: %s\n" 'resp) ＠＠ -330,31 +338,31 ＠＠ by the recording client over the data co (X-Dpy-p xdpy 'X-XRecordEnableContext) (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordEnableContext)) - (ListOfFields - (list (vector 1 (nth 4 xrec-ext)) ;opcode - [1 X-XRecord-op-EnableContext] - [2 2] ;length - [4 (X-RecordContext-id rc)])) - (msg (concat (X-Create-message ListOfFields))) - (ReceiveFields - (list [1 success] ;success field - nil - (list [1 integerp] ;category - [2 integerp] ;sequence number - [4 length-1] ;length - [1 integerp] ;elhead - [1 integerp] ;client-swapped - [2 nil] ;not used - [4 integerp] ;id-baes - [4 integerp] ;server-time - [4 integerp] ;recorded sequence number - [8 nil] ;not used - [(* length-1 4) stringp]))) - (rep (X-Dpy-send-read xdpy msg ReceiveFields))) + (ListOfFields + (list (vector 1 (nth 4 xrec-ext)) ;opcode + [1 X-XRecord-op-EnableContext] + [2 2] ;length + [4 (X-RecordContext-id rc)])) + (msg (concat (X-Create-message ListOfFields))) + (ReceiveFields + (list [1 success] ;success field + nil + (list [1 integerp] ;category + [2 integerp] ;sequence number + [4 length-1] ;length + [1 integerp] ;elhead + [1 integerp] ;client-swapped + [2 nil] ;not used + [4 integerp] ;id-baes + [4 integerp] ;server-time + [4 integerp] ;recorded sequence number + [8 nil] ;not used + [(* length-1 4) stringp]))) + (rep (X-Dpy-send-read xdpy msg ReceiveFields))) (X-Dpy-log xdpy 'x-record "X-XRecordEnableContext: rep=%S" 'rep) (when (and (car rep) - (= (nth 1 rep) X-XRecordStartOfData)) + (= (nth 1 rep) X-XRecordStartOfData)) ;; Set events guess parser and events dispatcher (setf (X-Dpy-parse-guess-dispatcher xdpy) 'X-XRecord-parse-guess) (setf (X-Dpy-events-dispatcher xdpy) 'X-XRecord-event-dispatcher)) ＠＠ -366,13 +374,14 ＠＠ by the recording client over the data co (X-RecordContext-p rc 'X-XRecordRegisterClients) (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext)) - (ListOfFields - (list (vector 1 (nth 4 xrec-ext)) ; opcode - [1 X-XRecord-op-DisplayContext] - [2 2] ; length - [4 (X-RecordContext-id rc)])) ; context - (msg (X-Create-message ListOfFields))) - (X-Dpy-send xdpy msg))) + (ListOfFields + (list (vector 1 (nth 4 xrec-ext)) ; opcode + [1 X-XRecord-op-DisplayContext] + [2 2] ; length + [4 (X-RecordContext-id rc)])) ; context + (msg (X-Create-message ListOfFields))) + (X-Dpy-send xdpy msg)) + (X-Dpy-log xdpy 'x-record "X-XRecordDisableContext: rc=%S" '(X-RecordContext-id rc))) (defun X-XRecordFreeContext (xdpy rc) "On display XDPY free record context RC." ＠＠ -380,12 +389,12 ＠＠ by the recording client over the data co (X-RecordContext-p rc 'X-XRecordRegisterClients) (let* ((xrec-ext (X-Dpy-get-extension xdpy "RECORD" 'X-XRecordGetContext)) - (ListOfFields - (list (vector 1 (nth 4 xrec-ext)) ; opcode - [1 X-XRecord-op-FreeContext] - [2 2] ; length - [4 (X-RecordContext-id rc)])) ; context - (msg (X-Create-message ListOfFields))) + (ListOfFields + (list (vector 1 (nth 4 xrec-ext)) ; opcode + [1 X-XRecord-op-FreeContext] + [2 2] ; length + [4 (X-RecordContext-id rc)])) ; context + (msg (X-Create-message ListOfFields))) (X-Dpy-send xdpy msg))) ＠＠ -398,73 +407,79 ＠＠ by the recording client over the data co "Parse message received in data connection." (X-Dpy-p xdpy 'X-XRecord-parse-guess) - (when (zerop (X-Dpy-readings xdpy)) - (X-Dpy-read-excursion - xdpy - (while (> (length (X-Dpy-message-buffer xdpy)) 0) - (let* ((msg (X-Dpy-parse-message (list [1 integerp] ; reply - [1 integerp] ;category - [2 integerp] ;sequence number - [4 integerp] ;length - [1 integerp] ;elhead - [1 integerp] ;client-swapped - [2 nil] ;not used - [4 integerp] ;id-baes - [4 integerp] ;server-time - [4 integerp] ;recorded sequence number - [8 nil]) ;not used - 0 xdpy)) - (mcategory (nth 1 msg)) ; message categery - (len (nth 3 msg)) - (elh (nth 4 msg)) - elh-value - result) - - (while (> len 0) - ;; There data - (setq elh-value nil) - (when (> elh 0) - ;; there elhead - (setq elh-value (X-Dpy-grab-bytes xdpy 4)) - (setq len (- len 4))) - - (setq result (Xforcenum (aref (X-Dpy-grab-bytes xdpy 1) 0))) - (setq len (- len 1)) - - (cond ((= mcategory X-XRecordFromServer) - ;; Error, Event or Reply - (cond ((= result 0) - ;; Error, TODO - (setq len 0) - ) - ((= result 1) - ;; Reply, TODO - (setq len 0) - ) - - ;; Event - (t ;(< result X-MaxEvent) - ;; Valid event - (let ((xev (X-Dpy-parse-event xdpy result))) - ;; Put some interception info - (X-Event-put-property xev 'XRecord-Category (nth 1 msg)) - (X-Event-put-property xev 'XRecord-Sequence (nth 2 msg)) - (X-Event-put-property xev 'XRecord-Elhead (nth 4 msg)) - (X-Event-put-property xev 'XRecord-Elhead-value elh-value) - (X-Event-put-property xev 'XRecord-Swaped (nth 5 msg)) - (X-Event-put-property xev 'XRecord-Idbase (nth 6 msg)) - (X-Event-put-property xev 'XRecord-Servertime (nth 7 msg)) - (X-Event-put-property xev 'XRecord-RecSeq (nth 8 msg)) - - (X-Dpy-log (X-Event-dpy xev) 'x-record "XRECORD EXTENSION: Get Event: %S, win=%S" - '(X-Event-name xev) '(X-Win-id (X-Event-win xev))) - - (setq len (- len 31)))))) - - ;; TODO: what about other categeries? - )) - ))) - )) + (while (and (zerop (X-Dpy-readings xdpy)) + (> (length (X-Dpy-message-buffer xdpy)) 31)) + (X-Dpy-read-excursion xdpy + (let* ((msg (X-Dpy-parse-message + (list [1 integerp] ; reply + [1 integerp] ;category + [2 integerp] ;sequence number + [4 integerp] ;length + [1 integerp] ;elhead + [1 integerp] ;client-swapped + [2 nil] ;not used + [4 integerp] ;id-baes + [4 integerp] ;server-time + [4 integerp] ;recorded sequence number + [8 nil]) ;not used + 0 xdpy)) + (mcategory (nth 1 msg)) ; message categery + (len (* 4 (nth 3 msg))) + (elh (nth 4 msg)) + elh-value + result) + + (while (> len 0) + ;; There data + (setq elh-value nil) + (when (> elh 0) + ;; there elhead + (setq elh-value + (X-Dpy-parse-message (list [4 integerp]) 0 xdpy)) + (setq len (- len 4))) + + (setq result (Xforcenum (aref (X-Dpy-grab-bytes xdpy 1) 0))) + (setq len (- len 1)) + + (cond ((= mcategory X-XRecordFromServer) + ;; Error, Event or Reply + (cond ((or (= result 0) + (= result 1)) + ;; Error or Reply .. just flush the data + (X-Dpy-grab-bytes xdpy len) + (setq len 0)) + + ;; Event + (t ;(< result X-MaxEvent) + ;; Valid event + (let ((xev (X-Dpy-parse-event xdpy result))) + (setq len (- len 31)) + + ;; Put some interception info + (X-Event-put-property xev 'XRecord-Category (nth 1 msg)) + (X-Event-put-property xev 'XRecord-Sequence (nth 2 msg)) + (X-Event-put-property xev 'XRecord-Elhead (nth 4 msg)) + (X-Event-put-property xev 'XRecord-Elhead-value elh-value) + (X-Event-put-property xev 'XRecord-Swaped (nth 5 msg)) + (X-Event-put-property xev 'XRecord-Idbase (nth 6 msg)) + (X-Event-put-property xev 'XRecord-Servertime (nth 7 msg)) + (X-Event-put-property xev 'XRecord-RecSeq (nth 8 msg)) + + (X-Dpy-log (X-Event-dpy xev) 'x-record "XRECORD EXTENSION: Get Event: %S(%S[%S]), win=%S" + '(X-Event-name xev) '(X-Event-detail xev) + '(int-to-char (truncate (car (xwem-kbd-xkcode->xksym (X-Event-detail xev))))) + '(X-Win-id (X-Event-win xev))) + + ;; Add event to event queue + (setf (X-Dpy-evq xdpy) + (append (X-Dpy-evq xdpy) (list xev))))))) + + (t + ;; Unsupported category + (X-Dpy-grab-bytes xdpy len) + (setq len 0))) + ))) + ))  ;;; Testing section: 1.6 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xshape.el Index: xlib-xshape.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xshape.el,v retrieving revision 1.5 retrieving revision 1.6 diff -u -p -r1.5 -r1.6 --- xlib-xshape.el 2005/01/01 04:40:17 1.5 +++ xlib-xshape.el 2005/04/04 19:55:30 1.6 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xshape.el --- Shape extension support. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: Mon Nov 17 19:23:03 MSK 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xshape.el,v 1.5 2005/01/01 04:40:17 youngs Exp $ +;; X-CVS: $Id: xlib-xshape.el,v 1.6 2005/04/04 19:55:30 lg Exp $ ;; This file is part of XWEM. 1.5 +1 -1 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xtest.el Index: xlib-xtest.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xtest.el,v retrieving revision 1.4 retrieving revision 1.5 diff -u -p -r1.4 -r1.5 --- xlib-xtest.el 2005/01/01 04:40:17 1.4 +++ xlib-xtest.el 2005/04/04 19:55:31 1.5 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xtest.el --- XTEST extension for xlib. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: 18 October 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xtest.el,v 1.4 2005/01/01 04:40:17 youngs Exp $ +;; X-CVS: $Id: xlib-xtest.el,v 1.5 2005/04/04 19:55:31 lg Exp $ ;; X-URL: http://lgarc.narod.ru/xwem/index.html ;; This file is part of XWEM. 1.9 +149 -130 XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xwin.el Index: xlib-xwin.el =================================================================== RCS file: /pack/xemacscvs/XEmacs/packages/xemacs-packages/xlib/lisp/xlib-xwin.el,v retrieving revision 1.8 retrieving revision 1.9 diff -u -p -r1.8 -r1.9 --- xlib-xwin.el 2005/01/01 04:40:17 1.8 +++ xlib-xwin.el 2005/04/04 19:55:31 1.9 ＠＠ -1,11 +1,11 ＠＠ ;;; xlib-xwin.el --- Core X structures. -;; Copyright (C) 2003 by Free Software Foundation, Inc. +;; Copyright (C) 2003-2005 by XWEM Org. ;; Author: Zajcev Evgeny <zevlg(a)yandex.ru&gt; ;; Created: 18 October 2003 ;; Keywords: xlib, xwem -;; X-CVS: $Id: xlib-xwin.el,v 1.8 2005/01/01 04:40:17 youngs Exp $ +;; X-CVS: $Id: xlib-xwin.el,v 1.9 2005/04/04 19:55:31 lg Exp $ ;; X-URL: http://lgarc.narod.ru/xwem/index.html ;; This file is part of XWEM. ＠＠ -111,8 +111,8 ＠＠ (defun X-Rect-intersect-p (&rest xrects) "Return non-nil if rectangles in XRECTS are intersects." (while (and xrects - (not (member t (mapcar (lambda (r) - (X-Rect-internal-intersect-p (car xrects) r)) + (not (member t (mapcar #'(lambda (r) + (X-Rect-internal-intersect-p (car xrects) r)) (cdr xrects))))) (setq xrects (cdr xrects))) ＠＠ -209,8 +209,8 ＠＠ If SIG is given and ATOM is not atom str (defsubst X-Atom-insert (xdpy atom) "Insert ATOM in XDPY's atoms list, if not already there." (pushnew atom (X-Dpy-atoms xdpy) - :test (lambda (a1 a2) - (= (X-Atom-id a1) (X-Atom-id a2))))) + :test #'(lambda (a1 a2) + (= (X-Atom-id a1) (X-Atom-id a2))))) (defsubst X-Atom-find (xdpy aid) "Find atom with id AID on X display XDPY." ＠＠ -312,7 +312,29 ＠＠ If SIG is given and ATOM is not atom str (defconst XA-wm-class (make-X-Atom :id 67.0 :name "WM_CLASS") "Atom wm-class eoncoding.") (defconst XA-wm-transient-for (make-X-Atom :id 68.0 :name "WM_TRANSIENT_FOR") "Atom wm-transient-for eoncoding.") -;; Attributes operations + +;;; Common predicates +(defsubst X-Win-p (win &optional sig) + "Return non-nil if WIN is X-Win structure. +If SIG is given and WIN is not X-Win structure, SIG will +be signaled." + (X-Generic-p 'X-Win 'X-Win-iswin-p win sig)) + +(defsubst X-Pixmap-p (pixmap &optional sig) + "Return non-nil if PIXMAP is X-Pixmap structure. +If SIG is given and PIXMAP is not X-Pixmap structure, SIG will be signaled." + (X-Generic-p 'X-Pixmap 'X-Pixmap-ispixmap-p pixmap sig)) + +(defsubst X-Colormap-p (cmap &optional sig) + "Return non-nil if CMAP is X-Colormap structure. +If SIG is given and CMAP is not X-Colormap structure, SIG will be signaled." + (X-Generic-p 'X-Colormap 'X-Colormap-iscmap-p cmap sig)) + +(defsubst X-Cursor-p (cursor &optional sig) + (X-Generic-p 'X-Cursor 'X-Cursor-iscursor-p cursor sig)) + + +;;; Attributes operations (defstruct (X-Attr (:predicate X-Attr-isattr-p)) ;; any *-pixel is X-Color structure dpy id ＠＠ -329,43 +351,50 ＠＠ If SIG is given and ATOM is not atom str visualid mapstate ;; List of extractors - (list '(((lambda (attr) - (if (X-Pixmap-p (X-Attr-background-pixmap attr)) - (X-Pixmap-id (X-Attr-background-pixmap attr)) - (X-Attr-background-pixmap attr))) . 4) - ((lambda (attr) - (if (X-Color-p (X-Attr-background-pixel attr)) - (X-Color-id (X-Attr-background-pixel attr)) - (X-Attr-background-pixel attr))) . 4) - ((lambda (attr) - (if (X-Pixmap-p (X-Attr-border-pixmap attr)) - (X-Pixmap-id (X-Attr-border-pixmap attr)) - (X-Attr-border-pixmap attr))) . 4) - ((lambda (attr) - (if (X-Color-p (X-Attr-border-pixel attr)) - (X-Color-id (X-Attr-border-pixel attr)) - (X-Attr-border-pixel attr))) . 4) - (X-Attr-bit-gravity . 1) - (X-Attr-win-gravity . 1) - (X-Attr-backing-store . 1) - (X-Attr-backing-planes . 4) - ((lambda (attr) - (if (X-Color-p (X-Attr-backing-pixel attr)) - (X-Color-id (X-Attr-backing-pixel attr)) - (X-Attr-backing-pixel attr))) . 4) - (X-Attr-override-redirect . 1) - (X-Attr-save-under . 1) - (X-Attr-event-mask . 4) - (X-Attr-do-not-propagate-mask . 4) - ((lambda (attr) - (if (X-Colormap-p (X-Attr-colormap attr)) - (X-Colormap-id (X-Attr-colormap attr)) - (X-Attr-colormap attr))) . 4) - ((lambda (attr) - (if (X-Cursor-p (X-Attr-cursor attr)) - (X-Cursor-id (X-Attr-cursor attr)) - (X-Attr-cursor attr))) . 4) - ))) + (list (list + (cons #'(lambda (attr) + (if (X-Pixmap-p (X-Attr-background-pixmap attr)) + (X-Pixmap-id (X-Attr-background-pixmap attr)) + (X-Attr-background-pixmap attr))) + 4) + (cons #'(lambda (attr) + (if (X-Color-p (X-Attr-background-pixel attr)) + (X-Color-id (X-Attr-background-pixel attr)) + (X-Attr-background-pixel attr))) + 4) + (cons #'(lambda (attr) + (if (X-Pixmap-p (X-Attr-border-pixmap attr)) + (X-Pixmap-id (X-Attr-border-pixmap attr)) + (X-Attr-border-pixmap attr))) + 4) + (cons #'(lambda (attr) + (if (X-Color-p (X-Attr-border-pixel attr)) + (X-Color-id (X-Attr-border-pixel attr)) + (X-Attr-border-pixel attr))) + 4) + (cons 'X-Attr-bit-gravity 1) + (cons 'X-Attr-win-gravity 1) + (cons 'X-Attr-backing-store 1) + (cons 'X-Attr-backing-planes 4) + (cons #'(lambda (attr) + (if (X-Color-p (X-Attr-backing-pixel attr)) + (X-Color-id (X-Attr-backing-pixel attr)) + (X-Attr-backing-pixel attr))) + 4) + (cons 'X-Attr-override-redirect 1) + (cons 'X-Attr-save-under 1) + (cons 'X-Attr-event-mask 4) + (cons 'X-Attr-do-not-propagate-mask 4) + (cons #'(lambda (attr) + (if (X-Colormap-p (X-Attr-colormap attr)) + (X-Colormap-id (X-Attr-colormap attr)) + (X-Attr-colormap attr))) + 4) + (cons #'(lambda (attr) + (if (X-Cursor-p (X-Attr-cursor attr)) + (X-Cursor-id (X-Attr-cursor attr)) + (X-Attr-cursor attr))) + 4)))) (defun X-Attr-p (attr &optional sig) "Return non-nil if ATTR is attributes structure. ＠＠ -379,7 +408,6 ＠＠ If SIG is given and ATTR is not attribut "Return a string representing the attributes ATTR." (X-Generate-message 'X-Attr attr)) - ;;;Configure window structure ;; (defstruct (X-Conf (:predicate X-Conf-isconf-p)) ＠＠ -388,16 +416,18 ＠＠ If SIG is given and ATTR is not attribut border-width sibling stackmode - (list '((X-Conf-x . 2) - (X-Conf-y . 2) - (X-Conf-width . 2) - (X-Conf-height . 2) - (X-Conf-border-width . 2) - ((lambda (conf) - (if (X-Win-p (X-Conf-sibling conf)) - (X-Win-id (X-Conf-sibling conf)) - (X-Conf-sibling conf))) . 4) - (X-Conf-stackmode . 1)))) + (list (list + (cons 'X-Conf-x 2) + (cons 'X-Conf-y 2) + (cons 'X-Conf-width 2) + (cons 'X-Conf-height 2) + (cons 'X-Conf-border-width 2) + (cons #'(lambda (conf) + (if (X-Win-p (X-Conf-sibling conf)) + (X-Win-id (X-Conf-sibling conf)) + (X-Conf-sibling conf))) + 4) + (cons 'X-Conf-stackmode 1)))) (defsubst X-Conf-p (conf &optional sig) "Return non-nil if CONF is X-Conf structure. ＠＠ -419,10 +449,10 ＠＠ If SIG is given and CONF is not X-Conf s (defun X-Win-invalidate (xdpy win) "Remove WIN from dpy list and invalidate cl struct." (add-timeout X-default-timeout - (lambda (xdpy-win) - (setf (X-Dpy-windows (car xdpy-win)) - (delq (cdr xdpy-win) (X-Dpy-windows (car xdpy-win)))) - (X-invalidate-cl-struct (cdr xdpy-win))) + #'(lambda (xdpy-win) + (setf (X-Dpy-windows (car xdpy-win)) + (delq (cdr xdpy-win) (X-Dpy-windows (car xdpy-win)))) + (X-invalidate-cl-struct (cdr xdpy-win))) (cons xdpy win))) ;; Properties list operations ＠＠ -488,12 +518,6 ＠＠ If you does not specify PRIORITY and EVT Signal `X-Events-stop' to stop events processing." (X-EventHandler-runall (X-Win-event-handlers win) xev)) -(defsubst X-Win-p (win &optional sig) - "Return non-nil if WIN is X-Win structure. -If SIG is given and WIN is not X-Win structure, SIG will -be signaled." - (X-Generic-p 'X-Win 'X-Win-iswin-p win sig)) - (defun X-Win-find (xdpy wid) "Find X-Win with id WID on XDPY." (X-Dpy-p xdpy 'X-Win-find) ＠＠ -519,11 +543,6 ＠＠ be signaled." plist) ; User defined plist -(defsubst X-Pixmap-p (pixmap &optional sig) - "Return non-nil if PIXMAP is X-Pixmap structure. -If SIG is given and PIXMAP is not X-Pixmap structure, SIG will be signaled." - (X-Generic-p 'X-Pixmap 'X-Pixmap-ispixmap-p pixmap sig)) - (defun X-Pixmap-find-or-make (dpy id) (make-X-Pixmap :dpy dpy :id id)) ＠＠ -591,11 +610,6 ＠＠ If SIG, then signal on error." dpy id colors) ; list of X-Color [unused] -(defsubst X-Colormap-p (cmap &optional sig) - "Return non-nil if CMAP is X-Colormap structure. -If SIG is given and CMAP is not X-Colormap structure, SIG will be signaled." - (X-Generic-p 'X-Colormap 'X-Colormap-iscmap-p cmap sig)) - (defun X-Colormap-lookup-by-rgb (cmap col) "Lookup color in colormap CMAP by R G B values of X-Color COL." (let ((cols (X-Colormap-colors cmap))) ＠＠ -667,41 +681,46 ＠＠ If SIG is given and CMAP is not X-Colorm clip-mask dash-offset dashes arc-mode - (list '((X-Gc-function . 1) - (X-Gc-plane-mask . 4) - ((lambda (gc) - (if (X-Color-p (X-Gc-foreground gc)) - (X-Color-id (X-Gc-foreground gc)) - (X-Gc-foreground gc))) . 4) - ((lambda (gc) - (if (X-Color-p (X-Gc-background gc)) - (X-Color-id (X-Gc-background gc)) - (X-Gc-background gc))) . 4) - (X-Gc-line-width . 2) - (X-Gc-line-style . 1) - (X-Gc-cap-style . 1) - (X-Gc-join-style . 1) - (X-Gc-fill-style . 1) - (X-Gc-fill-rule . 1) - (X-Gc-tile . 4) - (X-Gc-stipple . 4) - (X-Gc-tile-stipple-x-origin . 2) - (X-Gc-tile-stipple-y-origin . 2) - ((lambda (gc) - (if (X-Font-p (X-Gc-font gc)) - (X-Font-id (X-Gc-font gc)) - (X-Gc-font gc))) . 4) - (X-Gc-subwindow-mode . 1) - (X-Gc-graphics-exposures . 1) - (X-Gc-clip-x-origin . 2) - (X-Gc-clip-y-origin . 2) - ((lambda (gc) - (if (X-Pixmap-p (X-Gc-clip-mask gc)) - (X-Pixmap-id (X-Gc-clip-mask gc)) - (X-Gc-clip-mask gc))) . 4) - (X-Gc-dash-offset . 2) - (X-Gc-dashes . 1) - (X-Gc-arc-mode . 1)))) + (list (list + (cons 'X-Gc-function 1) + (cons 'X-Gc-plane-mask 4) + (cons #'(lambda (gc) + (if (X-Color-p (X-Gc-foreground gc)) + (X-Color-id (X-Gc-foreground gc)) + (X-Gc-foreground gc))) + 4) + (cons #'(lambda (gc) + (if (X-Color-p (X-Gc-background gc)) + (X-Color-id (X-Gc-background gc)) + (X-Gc-background gc))) + 4) + (cons 'X-Gc-line-width 2) + (cons 'X-Gc-line-style 1) + (cons 'X-Gc-cap-style 1) + (cons 'X-Gc-join-style 1) + (cons 'X-Gc-fill-style 1) + (cons 'X-Gc-fill-rule 1) + (cons 'X-Gc-tile 4) + (cons 'X-Gc-stipple 4) + (cons 'X-Gc-tile-stipple-x-origin 2) + (cons 'X-Gc-tile-stipple-y-origin 2) + (cons #'(lambda (gc) + (if (X-Font-p (X-Gc-font gc)) + (X-Font-id (X-Gc-font gc)) + (X-Gc-font gc))) + 4) + (cons 'X-Gc-subwindow-mode 1) + (cons 'X-Gc-graphics-exposures 1) + (cons 'X-Gc-clip-x-origin 2) + (cons 'X-Gc-clip-y-origin 2) + (cons #'(lambda (gc) + (if (X-Pixmap-p (X-Gc-clip-mask gc)) + (X-Pixmap-id (X-Gc-clip-mask gc)) + (X-Gc-clip-mask gc))) + 4) + (cons 'X-Gc-dash-offset 2) + (cons 'X-Gc-dashes 1) + (cons 'X-Gc-arc-mode 1)))) (defun X-Gc-p (gc &optional sig) (X-Generic-p 'X-Gc 'X-Gc-isgc-p gc sig)) ＠＠ -817,8 +836,8 ＠＠ If FONT-DESC is non-nil, return FONT's d (if (not X-use-queryfont) (nth 7 (XQueryTextExtents dpy font text)) - (apply '+ (mapcar (lambda (chr) - (X-Font-char-width chr font)) + (apply '+ (mapcar #'(lambda (chr) + (X-Font-char-width chr font)) text)))) ;;; Fontable stuff ＠＠ -854,26 +873,26 ＠＠ If SIG, then signal on error." src-char msk-char fgred fggreen fgblue bgred bggreen bgblue - - (list '(((lambda (curs) - (if (X-Font-p (X-Cursor-source curs)) - (X-Font-id (X-Cursor-source curs)) - (X-Cursor-source curs))) . 4) - ((lambda (curs) - (if (X-Font-p (X-Cursor-mask curs)) - (X-Font-id (X-Cursor-mask curs)) - (X-Cursor-mask curs))) . 4) - (X-Cursor-src-char . 2) - (X-Cursor-msk-char . 2) - (X-Cursor-fgred . 2) - (X-Cursor-fggreen . 2) - (X-Cursor-fgblue . 2) - (X-Cursor-bgred . 2) - (X-Cursor-bggreen . 2) - (X-Cursor-bgblue . 2)))) -(defsubst X-Cursor-p (cursor &optional sig) - (X-Generic-p 'X-Cursor 'X-Cursor-iscursor-p cursor sig)) + (list (list + (cons #'(lambda (curs) + (if (X-Font-p (X-Cursor-source curs)) + (X-Font-id (X-Cursor-source curs)) + (X-Cursor-source curs))) + 4) + (cons #'(lambda (curs) + (if (X-Font-p (X-Cursor-mask curs)) + (X-Font-id (X-Cursor-mask curs)) + (X-Cursor-mask curs))) + 4) + (cons 'X-Cursor-src-char 2) + (cons 'X-Cursor-msk-char 2) + (cons 'X-Cursor-fgred 2) + (cons 'X-Cursor-fggreen 2) + (cons 'X-Cursor-fgblue 2) + (cons 'X-Cursor-bgred 2) + (cons 'X-Cursor-bggreen 2) + (cons 'X-Cursor-bgblue 2)))) (defun X-Cursor-find-or-make (dpy id) (make-X-Cursor :dpy dpy :id id))