;;;
;;;              Copyright 1990 by Digital Equipment AB, Sweden
;;;
;;;                                  and
;;;
;;;                       Hakan Huss and Johan Ihren
;;;
;;;                           All Rights Reserved
;;;
;;;    Permission to use, copy, modify, and distribute this software and
;;;    its documentation for any purpose and without fee is hereby
;;;    granted, provided that the above copyright notice appear in all
;;;    copies and that both that copyright notice and this permis-
;;;    sion notice appear in supporting documentation, and that the
;;;    names of the copyright holders not be used in advertising in
;;;    publicity pertaining to distribution of the software without
;;;    specific, written prior permission. The copyright holders make no
;;;    representations about the suitability of this software for any
;;;    purpose. It is provided "as is" without express or implied warranty.
;;;
;;;    THE COPYRIGHT HOLDERS DISCLAIM ALL WARRANTIES WITH REGARD TO
;;;    THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANT-
;;;    ABILITY AND FITNESS, IN NO EVENT SHALL THE COPYRIGHT HOLDERS
;;;    BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
;;;    ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
;;;    PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
;;;    TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE
;;;    OR PERFORMANCE OF THIS SOFTWARE.
;;;
;;;    Authors: Hakan Huss, KTH and Johan Ihren, KTH
;;;

;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/msg-handler.sc,v 1.4 90/04/01 13:51:00 johani Exp $

;;; The SCIX message handler.

(module msghandler (top-level msg-handler))

(include "../include/util.sch")
(include "../include/lowlevel.sch")
(include "../include/types.sch")			; needed by make-*

(define-external *current-reply* global)
(define-external send-GetInputFocus requests)

(include "formats.sc")
(include "replies.sc")

(include "mkerror.sc")
(include "mkevent.sc")
(include "mkreply.sc")

;;; handling-event is only used in msg-handler, and should logically be
;;; locally bound in it. This, however, leads to unaligned access, probably
;;; due to some memory allocation bug in Scheme->C.
(define handling-event #f)

(define msg-handler
  (let ((msg-list '())
	(strange-stuff '()))		; Debug.
    ;; xdas -- the X protocol disassembler. xdas will take a string containing
    ;;	       output from the server and process it according to the following
    ;;         rules:
    ;;         If the first byte is 1 then this is a x-reply? to a request.
    ;;         If the first byte is 0 then this is an error. The error type is
    ;;         in the second byte.
    ;;         If the first byte is 2-34 then this is an event.
    ;;         
    ;;         xdas returns an appropriate object, or 'not-enough if the
    ;;         message doesn't contain enough information for the specified
    ;;         type, If the message claims to be longer than 16kb, an error is
    ;;         signaled.
    ;;
    (define (xdas str reply-type dpy)
      (let* ((type (get-next-byte! str))
	     (masked-type (bit-and type #x7f)) ) ; Mask off SendEvent-flag
	(cond ((zero? type)			 ; This is an error
	       (let ((bytes-left (- (c-input-string-length str)
				    (c-input-string-pos str) ))
		     (errno (peek-next-byte str)))
		 (if (< bytes-left 31)	; Partial message read?
		     (begin
		       (set-c-input-string-pos! str
						(- (c-input-string-pos str)
						   1) )
		       'not-enough)
		     (make-error str dpy) )))
	      ((= type 1)			 ; This is a reply
	       (let ((bytes-left (- (c-input-string-length str)
				    (c-input-string-pos str) ))
		     (tot-len (+ 32
				 (* 4
				    (c-unsigned-ref (c-input-string-string str)
						    (+ (c-input-string-pos str)
						       3))))))
		 (if (> tot-len 16384)
		     (error 'xdas
	       "Got a message longer than 16kb from server, can't handle it."))
		 (if (< bytes-left (- tot-len 1))  ; Partial message read?
		     (begin 
		       (set-c-input-string-pos! str
						(- (c-input-string-pos str)
						   1) )
		       'not-enough)
		     (make-reply reply-type str dpy) )))
	      ((and (>= masked-type 2) (<= masked-type 34)) ; This is an event
	       (let ((bytes-left (- (c-input-string-length str)
				    (c-input-string-pos str) )))
		 (if (< bytes-left 31)
		     (begin 
		       (set-c-input-string-pos! str
						(- (c-input-string-pos str)
						   1) )
		       'not-enough)
		     (make-event type str dpy)) ))
	      (else
	       (error 'xdas "Unknown type of message: ~a." type) ))))

    ;; wait-for-reply -- reads the messages from the server in quest for a
    ;;                   reply with sequence number seq-nr, which is returned.
    ;;                   Possible events and errors are dispatched to the
    ;;                   corresponding handler. Other replys are treated as
    ;;                   errors (this might be wrong...).
    ;;
    ;; Note: Wait-for-reply starts by telling next-message that the next reply
    ;;       found will be of reply-type. Then it walks through msg-list in
    ;;       search of this reply. It feels a bit insecure to leave the reply
    ;;       on its own like this, but as message arrival is guarenteed to be
    ;;       in order it should not give any problems.
    ;;
    (define (wait-for-reply seq-nr reply-type dpy)
      (if handling-event
	  (mutex-wait-for-reply seq-nr reply-type dpy)
	  (let ((r (find-msg-with-seq-nr seq-nr reply-type)))
	    (if r
		r
		(let loop ((found-msgs (next-message dpy reply-type)))
		  (if (not found-msgs)
		      ;; Did not find a message
		      (loop (next-message dpy reply-type))
		      ;; Found a message
		      (let ((r (find-msg-with-seq-nr seq-nr reply-type)))
			(if (not r)		; Didn't find it, sorry
			    (loop (next-message dpy reply-type))
			    r))))))))

    ;; mutex-wait-for-reply -- returns the reply with the wanted sequence
    ;;                         number without dispatching of events that are
    ;;                         queued
    (define (mutex-wait-for-reply seq-nr reply-type dpy)
      (let loop ((found-msgs #t))
	(if (not found-msgs)
	    ;; Did not find a message
	    (loop (next-message dpy reply-type))
	    ;; Found a message
	    (let iloop ((msg-l msg-list))
	      (if (null? msg-l)
		  (loop (next-message dpy reply-type))
		  (let ((msg (car msg-l)))
		    (cond ((x-reply? msg)
			   (if (= (msg 'seq-nr) seq-nr)
			       (begin
				 ;; set! is needed if we try to delete
				 ;; the first element in the list, as
				 ;; remq! can't handle that.
				 (set! msg-list (remq! msg msg-list))
				 msg)
			       (begin
				 (format #t ; Should really be a error.
       "mutex-wait-for-reply: Warning: Saw a lost reply: ~a when fetching ~a~%"
                                 (cons (msg 'reply-name)
				       (msg 'seq-nr) )
				 (cons reply-type seq-nr) )
				 (flush-buffer)
				 (set! msg-list (remq! msg msg-list))
				 (iloop (cdr msg-l)) )))
			  ((x-error? msg)
			   (if (= seq-nr (msg 'seq-nr)) ; Did we get an
			       (begin	    ; error instead of a reply?
				 (set! msg-list (remq! msg msg-list))
				 msg)
			       (if (< seq-nr (msg 'seq-nr)); later error?
				   (error 'mutex-wait-for-reply
			"Did not find a reply or error to round-trip request")
				   (iloop (cdr msg-l)) )))
			  (else (iloop (cdr msg-l))) )))))))

    (define (find-msg-with-seq-nr seq-nr reply-type)
      (let loop ()
	(if (null? msg-list)
	    #f				; Did not find it, sorry
	    (let ((msg (car msg-list)))
	      (cond ((x-event? msg)
		     (event-dispatch)
		     (loop) )
		    ((x-reply? msg)
		     (if (= seq-nr (msg 'seq-nr))
			 (begin
			   (set! msg-list (remq! msg msg-list))
			   msg)
			 (begin
			   (format #t ; Should really be a error.
      "find-msg-with-seq-nr: Warning: Saw a lost reply: ~a when fetching ~a~%"
                                   (cons (msg 'reply-name)
					 (msg 'seq-nr) )
				   (cons reply-type seq-nr) )
			   (flush-buffer)
			   (set! strange-stuff (cons msg strange-stuff))
			   (set! msg-list (remq! msg msg-list))
			   (loop) )))
		    ((x-error? msg)
		     (if (= seq-nr (msg 'seq-nr)) ; Did we get an error instead
			 (begin		          ; of a reply?
			   (set! msg-list (cdr msg-list))
			   msg)
			 (if (< seq-nr (msg 'seq-nr)) ; Is this a later error?
			     (error 'find-msg-with-seq-nr
		    "Did not find a reply or error to round-trip request")
			     (begin
			       (error-dispatch)
			       (loop) ))))
		    (else 
		     (set! strange-stuff (cons msg strange-stuff))
		     (error 'find-msg-with-seq-nr
			    "Unknown kind of server message")))))))

    (define (event-dispatch)
      (let* ((event (car msg-list))
	     (msgs (event 'supported-messages))
	     (event-object (cond ((memq 'event msgs) (event 'event))
				 ((memq 'parent msgs) (event 'parent))
				 ((memq 'window msgs) (event 'window))
				 ((memq (event 'event-name)
					'(KeymapNotify MappingNotify))
				  ((event 'display) 'keyboard) )
				 ((memq (event 'event-name)
					'(SelectionClear SelectionRequest) )
				  (event 'owner) )
				 ((eq? (event 'event-name) 'SelectionNotify)
				  (event 'requestor) )
				 ((memq (event 'event-name)
					'(GraphicsExposure NoExposure) )
				  (event 'drawable) )
				 (else #f) ))) ; Shouldn't happen.
	(set! handling-event #t)	; Flag that we are handling an event
	(event-object 'scix-event-dispatch msg-handler event-object)
	(set! handling-event #f) ))
	
    (define (error-dispatch)
      (let* ((error (car msg-list))
	     (dpy (error 'display)) )
	(dpy 'scix-error-dispatch error)
	(set! msg-list (cdr msg-list)) ))
	
    ;; next-event! -- used by the event-handling routines (callbacks and the
    ;;               event-dispatch method in windows).
    (define (next-event!)
      (let ((e (car msg-list)))
	(set! msg-list (cdr msg-list))
	e))

    ;; my-events! -- returns a list with the consecutive events belonging to o.
    ;;               msg-list is stripped of these events.
    (define (my-events! o)
      (let loop ((its-events '()) (msg-l msg-list))
	(if (null? msg-l)
	    (begin
	      (set! msg-list msg-l)
	      its-events)
	    (let ((msg (car msg-l)))
	      (if (and (x-event? msg)
		       (right-object-for-dispatch? msg o) )
		  (loop (append its-events (list msg)) (cdr msg-l))
		  (begin
		    (set! msg-list msg-l)
		    its-events))))))

    ;; my-events -- returns a list with the consecutive events belonging to o.
    ;;              msg-list remains intact.
    (define (my-events o)
      (let loop ((its-events '()) (msg-l msg-list))
	(if (null? msg-l)
	    its-events
	    (let ((msg (car msg-l)))
	      (if (and (x-event? msg)
		       (right-object-for-dispatch? msg o) )
		  (loop (append its-events (list msg)) (cdr msg-l))
		  its-events)))))

    ;; right-object-for-dispatch? -- return #t if obj is the "right" recipient
    ;;                               of the event event.
    ;; Note: Instead of querying the event for its supported-messages and then
    ;;       deciding on selector method the selector method should maybe be
    ;;       gained by looking up the event-name in a table. That would also
    ;;       facilitate extensions of the protocol.
    (define (right-object-for-dispatch? event obj)
      (let* ((msgs (event 'supported-messages))
	     (ev-obj (cond ((memq 'event msgs) (event 'event))
			   ((memq 'parent msgs) (event 'parent))
			   ((memq 'window msgs) (event 'window))
			   ((memq (event 'event-name)
				  '(SelectionClear SelectionRequest) )
			    (event 'owner) )
			   ((eq? (event 'event-name) 'SelectionNotify)
			    (event 'requestor) )
			   ((memq (event 'event-name)
				  '(GraphicsExposure NoExposure) )
			    (event 'drawable) )
			   (else #f))))
	(eq? ev-obj obj) ))

    ;; put-event! -- used by the event-handling routines to push an event back
    ;;              onto the unprocessed list of messages.
    (define (put-event! event)
      (if (x-event? event)
	  (set! msg-list (cons event msg-list))
	  (error 'put-event "Argument was not an event") ))

    ;; next-message
    ;;
    ;; Note1: next-message flushes the dpy with the philosophy that it is
    ;;        stupid to ask for new input before you have shown the result of
    ;;        the last.
    ;; Note2: reply-type is used for the additional purpose of indicating that
    ;;        the unread data in the inputbuffer should be discarded.
    ;; Note3: The use of next-message has changed. Now n-m should just read all
    ;;        messages it can find and queue them in msg-list. If any messages
    ;;        were found, return #t otherwise return #f.
    (define (next-message dpy reply-type)
      (dpy 'flush!)
      (non-blocking-io (dpy 'scix-socket))
      (let loop ((str (readfromserver dpy)))
	(if (null? str)
	    (begin
	      (blocking-io (dpy 'scix-socket))
	      #f)				; No, did not find anything
	    (begin
	      (let ((r (xdas str reply-type dpy)))
		(if (eq? r 'not-enough)     ; Partial message, update state
		    (let iloop ()
		      (set! str (readmorefromserver dpy str))
		      (set! r (xdas str reply-type dpy))
		      (if (eq? r 'not-enough)
			  (iloop) )))
		(set! msg-list (append msg-list (list r))) ; Queue parsed msg
		(if (not (end-of-input-string? str))
		    (loop str)                         ; Parse rest of string
		    (begin
		      (blocking-io (dpy 'scix-socket))
		      #t)))))))		             ; Yes, did find something
    
    ;; mainloop -- Terminate? is a function of no arguments
    ;;             that returns #t if the loop should terminate. Calc (if
    ;;             present) should be a procedure of one argument that does
    ;;             whatever the application wants done when not handling
    ;;             events. The argument is a procedure of no arguments that
    ;;             should be called from within the calc procedure now and then
    ;;             to handled events. Note that if a calc-procedure is supplied
    ;;             it is up to the calc-procedure itself to terminate, the
    ;;             terminate? predicate is only used when no "idle"-calculation
    ;;             is supplied.
    ;;             Example of use, first without a calc-procedure:
    ;;             (mainloop (lambda ()
    ;;                         (button 'button-state) ) ; a toggle-button
    ;;                       (list scr) )               ; with states #t and #f
    ;;
    ;;             With a simple calc-procedure:
    ;;             (mainloop #f                         ; terminate? unused
    ;;                       (list scr)
    ;;                       (lambda (handle-events)    ; calc-procedure
    ;;                         (let loop ()
    ;;                           (do-some-calculating)
    ;;                           (handle-events)
    ;;                           (loop) )))
    ;;
    ;;             Note: mainloop starts and ends with flushing all buffered
    ;;             requests in the displays provided.
    (define (mainloop terminate? dpy-list . calc)
      (let* ((sd-l (map (lambda (d) (d 'scix-socket)) dpy-list))
	     (nfds (+ (apply max sd-l) 1))
	     (select-mask 0) )
	(define (act-on-event)
	  (let loop ((dpy-list dpy-list))
	    (if (not (null? dpy-list))
		(if (next-message (car dpy-list) #f); Any messages on this dpy?
		    (let iloop ()                     ; Yes
		      (if (not (null? msg-list))
			  (begin
			    (if (x-event? (car msg-list))
				(event-dispatch)
				(error-dispatch) )
			    (iloop) )
			  (loop (cdr dpy-list)) ))))))        ; No
      
	(for-each (lambda (sd)		; Set up argument for select
		    (set! select-mask (bit-or select-mask
					      (bit-lsh 1 sd) )))
		  sd-l)
	(act-on-event)			; Handle any pending events.
	(if (null? calc)
	    ;; Have nothing to do while waiting for events.
	    (let loop ()
	      (if (not (terminate?))
		  (begin
		    (select nfds select-mask); NOTE: select used only for
		    (act-on-event)	; blocking, returned info is not used.
		    (loop) )
		  'done))
	    ;; Have something to do while waiting for events.
	    ((car calc) act-on-event) )))

    (define (delete-lower! seq-nr)
      (let loop ((msg-l msg-list))
	(cond ((null? msg-l) (set! msg-list '()))
	      ((>= ((car msg-l) 'seq-nr) seq-nr) (set! msg-list msg-l))
	      (else (loop (cdr msg-l))) )))
    
    ;; The msg-handler's interface to the world:
    (define (me msg . args)
      (cond ((eq? msg 'next-event!) (if (null? msg-list)
					#f
					(next-event!)))
	    ;; Non-destructive version of next-event!.
	    ((eq? msg 'next-event) (if (null? msg-list)
				       #f
				       (car msg-list)))
	    ((eq? msg 'my-events!) (my-events! (car args)))
	    ;; Non-destructive version of my-events!.
	    ((eq? msg 'my-events) (my-events (car args)))
	    ((eq? msg 'put-event!) (put-event! (car args)))
	    ((eq? msg 'scix-next-message) (apply next-message args))
	    ((eq? msg 'scix-msg-list) msg-list)
	    ((eq? msg 'sync!) (apply
			       (lambda (dpy discard)
				 (let ((old-flag handling-event))
				   (me 'flush!)
				   (set! handling-event #t)
				   (if discard
				       (delete-lower!
					((send-GetInputFocus dpy) 'seq-nr) )
				       (send-GetInputFocus dpy))
				   (set! handling-event old-flag)
				   #t))
			       args))
	    ((eq? msg 'flush!) (set! msg-list '()))
	    ((eq? msg 'scix-wait-for-reply) (apply wait-for-reply args))
	    ((eq? msg 'mainloop) (apply mainloop args))
	    ((eq? msg 'scix-strange-stuff) strange-stuff)
	    ((eq? msg 'object-class) 'msg-handler)
	    ((eq? msg 'object-system) 'light-weight)
	    ((eq? msg 'supported-messages)
	     '(next-event! next-event my-events! my-events put-event!
			   scix-next-message msg-list flush!
			   scix-wait-for-reply mainloop strange-stuff
			   sync!))
	    ((eq? msg 'object-desc) #f)	; Not currently supported.
	    ((eq? msg 'me) (lambda () me))
	    (else (error 'msg-handler "Unknown message: ~a"
			 (cons msg args))) ))
    me))

;;; Create the queues.
(define *error-queue* '())	  

(define (empty-error-queue)
  (set! *error-queue* '()))

(define (reply-seq-nr reply)
  (reply 'seq-nr) )

(define (error-seq-nr error)
  (error 'seq-nr) )

(define (x-error? message)
  (eq? 'error (message 'object-class)) )

(define (x-event? message)
  (eq? 'event (message 'object-class)) )

(define (x-reply? message)
  (eq? 'reply (message 'object-class)) )