Source

xlib / lisp / xlib-xc.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
;;; xlib-xc.el --- X Connection.

;; Copyright (C) 2003 by Free Software Foundation, Inc.

;; Author: Zajcev Evgeny <zevlg@yandex.ru>
;; Created: 18 October 2003
;; Keywords: xlib, xwem
;; X-CVS: $Id$
;; X-URL: http://lgarc.narod.ru/xwem/index.html

;; This file is part of XWEM.

;; XWEM is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XWEM is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
;; License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; 

;;; Code:

(eval-when-compile
  (require 'cl))

(defvar X-Dpy-dpys-list nil
  "List of all opened displays.")

;;;###autoload
(defstruct X-Visual
  id
  class
  bits-per-rgb
  cmap-entries
  red-mask
  green-mask
  blue-mask)

;;;###autoload
(defstruct X-Depth
  depth
  visuals)				; List of X-Visual

;;;###autoload
(defstruct X-Screen
  dpy					; display
  root					; Root window
  colormap
  white-pixel black-pixel
  root-event-mask			; Event mask for root window

  visualid
  backingstores
  save-unders
  width height				; in pixels
  mwidth mheight			; in millimeters
  min-maps max-maps
  default-gc
  root-depth				; Root depth
  depths				; List of X-Depth
  )

;;;###autoload
(defstruct X-ScreenFormat
  depth
  bits-per-pixel
  scanline-pad)
  
;;;###autoload
(defstruct (X-Dpy (:predicate X-Dpy-isxdpy-p))
  proc					; process, which holds X connection
  log-buffer				; buffer for logs, when debugging is non-nil
  properties				; User defined plist

  ;; Protecting section
  (readings 0)				; non-zero mean we are in reading mode
  (evq nil) (evq-protects 0)		; eventing, events queue and queue protects counter
  (snd-buf "") (snd-protects 0)		; for `X-Dpy-send-excursion'

  (parse-guess-dispatcher 'X-Dpy-parse-message-guess)
  (events-dispatcher 'X-Dpy-default-events-dispatcher)

  event-handlers			; event handlers, same as in X-Win

  message-buffer

  ;; X section
  name					; display name
  proto-maj proto-min			; major and minor numbers for X protocol
  vendor				; Vendor string
  min-keycode max-keycode		; keycodes allowed
  resource-base resource-mask (resource-id 1)
  (rseq-id 0)				; requests sequence number
  max-request-size			; Maximum request size allowed
  motion-bufsize
  byte-order				; Images byte order

  bitmap-scanline-unit
  bitmap-scanline-pad
  bitmap-bit-order

  formats				; List of X-ScreenFormat

  (default-screen 0)			; default screen number
  screens				; List of X-Screen

  error-hooks				; Hooks called when X error occurs

  ;; Various display lists
  atoms					; list of atoms
  windows				; list of windows
  fonts					; list of opened fonts
  extensions				; list of extensions
  )

;;;###autoload
(defmacro X-Dpy-reqseq (xdpy)
  "Extract least significant 16bit from request sequenc id in XDPY."
  `(logand (X-Dpy-rseq-id ,xdpy) 65535))

;;;###autoload
(defmacro X-Dpy-put-property (xdpy prop val)
  "Put property PROP with value VAL in XDPY's properties list."
  `(setf (X-Dpy-properties ,xdpy)
	 (plist-put (X-Dpy-properties ,xdpy) ,prop ,val)))

;;;###autoload
(defmacro X-Dpy-get-property (xdpy prop)
  "Get property PROP from XDPY's properties list."
  `(plist-get (X-Dpy-properties ,xdpy) ,prop))

;;;###autoload
(defmacro X-Dpy-rem-property (xdpy prop)
  "Remove property PROP from XDPY's properties list."
  `(setf (X-Dpy-properties ,xdpy) (plist-remprop (X-Dpy-properties ,xdpy) ,prop)))

;;;###autoload
(defsubst X-Dpy-EventHandler-add (dpy handler &optional priority evtypes-list)
  "To DPY's event handlers list add HANDLER."
  (setf (X-Dpy-event-handlers dpy)
	(X-EventHandler-add (X-Dpy-event-handlers dpy) handler priority evtypes-list)))

;;;###autoload
(defsubst X-Dpy-EventHandler-isset (dpy handler &optional priority evtypes-list)
  "Return non-nil if on DPY event HANDLER is set."
  (X-EventHandler-isset (X-Dpy-event-handlers dpy) handler priority evtypes-list))

;;;###autoload
(defsubst X-Dpy-EventHandler-rem (dpy handler &optional priority evtypes-list)
  "From DPY's event handlers list, remove HANDLER."
  (setf (X-Dpy-event-handlers dpy)
	(X-EventHandler-rem (X-Dpy-event-handlers dpy) handler priority evtypes-list)))

;;;###autoload
(defsubst X-Dpy-EventHandler-enable (dpy handler &optional priority evtypes-list)
  "In DPY's list of event handlers activate HANDLER."
  (X-EventHandler-enable (X-Dpy-event-handlers dpy) handler priority evtypes-list))

;;;###autoload
(defsubst X-Dpy-EventHandler-disable (dpy handler &optional priority evtypes-list)
  "In DPY's list of event handlers disable HANDLER."
  (X-EventHandler-disable (X-Dpy-event-handlers dpy) handler priority evtypes-list))

;;;###autoload
(defsubst X-Dpy-EventHandler-runall (dpy xev)
  "Run all DPY's event handlers on XEV.
Signal `X-Events-stop' to stop events processing."
  (X-EventHandler-runall (X-Dpy-event-handlers dpy) xev))

;; Formats operations
;;;###autoload
(defun X-formatfind (xdpy depth)
  "On display XDPY find proper X-ScreenFormat for gived DEPTH."
  (let ((formats (X-Dpy-formats xdpy)))
    (while (and formats (not (= depth (X-ScreenFormat-depth (car formats)))))
      (setq formats (cdr formats)))

    (car formats)))

;;;###autoload
(defun X-formatint (xdpy depth num)
  "On display XDPY convert NUM to string."
  (let ((fmt (X-formatfind xdpy depth))
	bpp cfun)
    (if (not (X-ScreenFormat-p fmt))
	""

      (setq bpp (/ (X-ScreenFormat-bits-per-pixel fmt) 8))
      (setq cfun (intern (format "int->string%d" bpp)))
      (funcall cfun num))))

;;;###autoload
(defun X-formatpad (xdpy depth str)
  "Return padded STR."
  (let ((fmt (X-formatfind xdpy depth))
	bp)
    
    ;; XXX Can't deal with bits
    (if (not (X-ScreenFormat-p fmt))
	;; XXX Assume depth is 1 for bitmaps
	str

      (setq bp (/ (X-ScreenFormat-scanline-pad fmt) 8))
      (concat str
	      (make-string (% (- bp (% (length str) bp)) bp) ?\x00)))))

;;;###autoload
(defun X-Dpy-p (xdpy &optional sig)
  "Return non-nil if XDPY is X display.
If SIG is given and XDPY is not X display, SIG will be signaled."
  (let ((isdpy (X-Dpy-isxdpy-p xdpy)))
    (if (and (not isdpy) sig)
	(signal 'wrong-type-argument (list sig 'X-Dpy-p xdpy))
      isdpy)))

;;;###autoload
(defun X-Dpy-get-id (xdpy)
  "Get id to be used on X display XDPY."
  (X-Dpy-p xdpy 'X-Dpy-get-id)

  (let* ((newid (X-Dpy-resource-id xdpy))
	 (newword (float 0))
	 (bitcnt 0)			;bit counter in mask
	 (idcnt 0)			;bit counter in id
	 (servmask (X-Dpy-resource-mask xdpy)) ;service mask (our unique bits)
	 (servbase (X-Dpy-resource-base xdpy)))	;service base (always set)
    ;; we can say <30 because top 3 bits are always 0
    (while (< bitcnt 30)		;while there is more in the mask
      (if (Xtest servmask (Xmask bitcnt))
	  (progn
	    (if (Xtest newid (Xmask idcnt)) ;set bit in id if it is
					;set in the id value.
		(setq newword (Xmask-or newword (Xmask bitcnt))))
	    (setq idcnt (1+ idcnt))))	;inc idcnt when we have a mask match
      (setq bitcnt (1+ bitcnt)))	;always inc bitmask cnter

    (incf (X-Dpy-resource-id xdpy))	;inc to next id counter value
    (Xmask-or newword servbase)))	;return the id with base attached

;;; Process functions
;;;###autoload
(defun X-Dpy-create-connection (dname dnum)
  "Create X connection to display with name DNAME and number DNUM."

  (let* ((xcon (open-network-stream (format "X-%s:%d" dname dnum)
				   nil	; no buffer
				   dname
				   (+ 6000 dnum)))
	 (xdpy (make-X-Dpy :proc xcon :name (format "%s:%d" dname dnum))))
    
    (set-process-filter xcon 'X-Dpy-filter)
    (set-process-sentinel xcon 'X-Dpy-sentinel)

    (add-to-list 'X-Dpy-dpys-list xdpy)
    xdpy))

(defun X-Dpy-find-dpy (proc)
  "Find xdpy by process PROC."
  (let ((dpys X-Dpy-dpys-list))
    (while (and dpys (not (eq proc (X-Dpy-proc (car dpys)))))
      (setq dpys (cdr dpys)))
    (car dpys)))

(defun X-Dpy-filter (proc out)
  "Filter for X nework connections."
  (let ((xdpy (X-Dpy-find-dpy proc)))
    (X-Dpy-p xdpy 'X-Dpy-filter)

    (setf (X-Dpy-message-buffer xdpy)
	  (concat (X-Dpy-message-buffer xdpy) out))
    
    (funcall (X-Dpy-parse-guess-dispatcher xdpy) xdpy)))

(defun X-Dpy-sentinel (proc &optional event)
  "Sentinel for X connections."
  (let ((xdpy (X-Dpy-find-dpy proc)))
    (X-Dpy-p xdpy 'X-Dpy-sentinel)

    (message "X: Removing process %S" proc)
    (sit-for 1)
    (delete-process proc)

    (setq X-Dpy-dpys-list (delq xdpy X-Dpy-dpys-list))))

;;;###autoload
(defun X-Dpy-close (xdpy)
  "Close connection associated with XDPY."
  (X-Dpy-p xdpy 'X-Dpy-close)
  (X-Dpy-sentinel (X-Dpy-proc xdpy)))

;; Logging
;;;###autoload
(defun X-Dpy-log (xdpy &rest args)
  "Put a message in the in the log buffer specified by XDPY.
If XDPY is nil, then put into current buffer.  Log additional ARGS as well."
  (X-Dpy-p xdpy 'X-Dpy-log)

  (when (and (X-Dpy-log-buffer xdpy)
	     (bufferp (get-buffer-create (X-Dpy-log-buffer xdpy))))
    (with-current-buffer (get-buffer-create (X-Dpy-log-buffer xdpy))
      (goto-char (point-min))
      (insert (format "%d: " (nth 1 (current-time))))
      (insert (apply 'format (mapcar (lambda (arg) (eval arg)) args))))
    ))

(defun X-Dpy-log-verbatim (xdpy arg)
  (X-Dpy-p xdpy 'X-Dpy-log-verbatim)

  (when (bufferp (X-Dpy-log-buffer xdpy))
    (with-current-buffer (X-Dpy-log-buffer xdpy)
      (goto-char (point-min))
      (insert "[" arg "]" "\n"))
    ))

;;; Sending/receiving functions
;;;###autoload
(defun X-Dpy-send-flush (xdpy s)
  "Just send S to display XDPY. Do not increase rseq-id."
  (X-Dpy-p xdpy 'X-Dpy-send-flush)

  (when (not (stringp s))
    (signal 'wrong-type-argument '(X-Dpy-send-flush stringp s)))

  (process-send-string (X-Dpy-proc xdpy) s))

;;;###autoload
(defun X-Dpy-send (xdpy s)
  "Send the X server DPY the string S. Increase request id rseq-id.
There is special mode when we are collecting X output to send it all at once."
  (X-Dpy-p xdpy 'X-Dpy-send)

  (when (not (stringp s))
    (signal 'wrong-type-argument '(X-Dpy-send stringp s)))

  (unwind-protect
      (if (> (X-Dpy-snd-protects xdpy) 0)
	  (setf (X-Dpy-snd-buf xdpy) (concat (X-Dpy-snd-buf xdpy) s))

	(process-send-string (X-Dpy-proc xdpy) s))

    ;; increase request sequence number
    (incf (X-Dpy-rseq-id xdpy))))

;;;###autoload
(defun X-Dpy-send-read (xdpy s rf)
  "Send S to display XDPY and receive answer according to receive fields RF."
  (X-Dpy-p xdpy 'X-Dpy-send-read)

  (when (not (stringp s))
    (signal 'wrong-type-argument '(X-Dpy-send-read stringp s)))

  (let (rval)
    (X-Dpy-read-excursion xdpy
      ;; Flush output buffer
      (X-Dpy-send-flush xdpy (X-Dpy-snd-buf xdpy))
      (setf (X-Dpy-snd-buf xdpy) "")

      (process-send-string (X-Dpy-proc xdpy) s)
      (unwind-protect
	  (setq rval (X-Dpy-parse-message rf nil xdpy))

	;; increase request sequence number
	(incf (X-Dpy-rseq-id xdpy))))
    rval))

;;; Event dispatcher
(defun X-Dpy-default-events-dispatcher (xdpy win xev)
  "Default events  dispatcher."
  (X-Dpy-log xdpy "Get event: %S, for win: %S\n" '(X-Event-name xev)
	     '(if (X-Win-p win) (X-Win-id win) win))

  (when (X-Win-p win)
    (if (X-Win-event-handlers win)
	;; WIN has its own event handlers
	(X-Win-EventHandler-runall win xev)

      ;; Otherwise try common handlers
      (when (X-Dpy-event-handlers xdpy)
	(X-Dpy-EventHandler-runall xdpy xev)
	))))

;;; Sending section
(defconst X-byte-order ?l "Byte order used by emacs X.  B MSB, l LSB.")
(defconst X-protocol-minor-version 0 "Minor version of client.")
(defconst X-protocol-major-version 11 "Major version of client.")

;;;###autoload
(defconst X-client-to-open
  (list [1 X-byte-order]
	[1 0]				;unused
	[2 X-protocol-major-version]
	[2 X-protocol-minor-version]
	[2 0]				;auth name
	[2 0]				;auth data
	[2 0]				;unused
	;; No auth name or data, so empty
	)
  "XStruct list of sizes when opening a connection.")

(defmacro X-Force-char-num (maybechar)
  "Force MAYBECHAR to be a number for XEmacs platform."
  ;; This is an annoying XEmacs problem  To bad it slows down
  ;; Emacs too.
  (if (fboundp 'characterp)
      (list 'if (list 'characterp maybechar)
	    (list 'setq maybechar (list 'char-to-int maybechar)))))

;;;###autoload
(defun X-Create-message (message-s &optional pad-notneed)
  "Takes the MESSAGE-S structure and builds a net string.
MESSAGE-S is a list of vectors and symbols which formulate the message
to be sent to the XServer.  Each vector is of this form:
  [ SIZE VALUE ]
  SIZE is the number of BYTES used by the message.
  VALUE is the lisp object whose value is to take up SIZE bytes.
  If VALUE or SIZE is a symbol or list, extract that elements value.
    If the resulting value is still a list or symbol, extract it's value
    until it is no longer a symbol or a list.
  If VALUE is a number, massage it to the correct size.
  If VALUE is a string, append that string verbatum.
  If VALUE is nil, fill it with that many NULL characters.

When PAD-NOTNEED is non-nil, then do not pad to 4 bytes."
  
  (let ((gc-cons-threshold most-positive-fixnum)	;inhibit gc'ing
	(news nil)
	(ts   nil)
	(tvec nil)
	(tval nil)
	(tlen nil))
    (while message-s
      (setq tvec (car message-s))
      (setq tval (aref tvec 1))
      (setq tlen (aref tvec 0))

      ;; Check for symbols, or symbols containing symbols.
      (while (and tlen (or (listp tlen) (symbolp tlen)))
	(setq tlen (eval tlen)))

      ;; Check for symbols, or symbols containing symbols.
      (while (and (not (null tval))	; nil symbol allowed
		  (not (eq tval t))	; t symbol allowed
		  (or (listp tval) (symbolp tval)))
	(setq tval (eval tval)))

      ;; Fix XEmacs 20 broken characters
      (X-Force-char-num tval)

      ;; Numbers, put in.
      (cond
       ;; numbers get converted based on size.
       ((numberp tval)
	(cond
	 ((= tlen 1)
	  (setq ts (int->string1 tval)))
	 ((= tlen 2)
	  (setq ts (int->string tval)))
	 ((= tlen 4)
	  (setq ts (int->string4 tval)))
	 (t
	  (error "Wrong size for a message part to be a number!"))))

       ;; strings get appended onto the end.
       ((stringp tval)
	(setq ts tval))

       ;; nil is usually filler, so stuff on some 0s
       ((eq tval nil)
	(setq ts (make-string tlen ?\x00)))

       ;; t is alias for True
       ((eq tval t)
	(setq ts (concat (make-string (- tlen 1) ?\x00) (make-string 1 ?\x01))))

       ;; some sort of error
       (t
	(error "Invalid type to be put into an Xmessage")))

      (setq ts (concat ts "\0\0\0\0"))	; make sure we fill length req.
      (setq ts (substring ts 0 tlen))
      (setq news (concat news ts))
      (setq message-s (cdr message-s)))

    ;; pad the message
    (if (and (not pad-notneed)
	     (/= (% (length news) 4) 0))
	(let ((s "\0\0\0\0"))
	  (setq news (concat news (substring s 0 (- 4 (% (length news) 4)))))))
    news))

(provide 'xlib-xc)

;;; xlib-xc.el ends here