;;; 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: xlib-xc.el,v 1.3 2004/07/14 08:38:53 youngs Exp $
;; 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)
  (require 'xlib-math)
  (require 'xlib-xwin))

(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)))

(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)))

(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))

(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)))

(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))

(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))

(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
