;;;
;;;              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
;;;

;;; SCIX display object.

;;; $Header: /deneb/src0/johani/scix-0.96/src/RCS/dpy-object.sc,v 1.5 90/04/01 13:50:06 johani Exp $

(module display (top-level make-display))

(include "../include/lw-objects.sch")
(include "../include/lowlevel.sch")       ; things used by the display object
(include "../include/requests.sch")
(include "../include/msg-handler.sch")
(include "../include/util.sch")		  ; utilities needed by define-class
(include "../include/masks.sch")

(define-external make-screen objects)
(define-external make-visual objects)
(define-external make-hash-vector hash)
(define-external x-protocol-atoms global)

(include "../macros/extend-syntax.sc")
(include "../macros/define-class.sc")

;;; Display object -- Most of the functionality of the display should be
;;;                   exported to the screen objects.
(define-class (display display-name)
  (locals
   (fd #f) (seq-nr -1) (allocator #f) (state #f) (screens '())
   (pointer #f) (keyboard #f) (atombox #f) (request-buffer "")
   (current-request (make-string 1024)) (tot-buffer-size 0)
   (buffer #t) (max-buffer 1024) (queried-extensions `()) (initial-reply #f)
   (id-vector (make-hash-vector (lambda (x) x)
				(lambda (o)
				  (o 'id) )
				101))
   (history-list '((-1 history-list)))
   (error-handler (lambda (error)
		    (format #t
"error-handler: Got a ~a-error. Major opcode: ~a. Assoc. object present: ~a~%"
			    ((car error) 'error-name)
			    ((car error) 'major-opcode)
			    (if (cadr error)
				(cadr error)
				'no))
		    (set! *error-queue* (append *error-queue*
						(list (car error)))) )) )
  (methods
   (scix-history-list (lambda () history-list)) ; Debug
   (scix-socket (lambda () fd))
   (scix-initial-reply (lambda ()
			 initial-reply))
   (scix-id-vector (lambda () id-vector))
   (scix-unique-id (lambda ()		; Return a new unused X id.
		     (if (eq? state 'initialized)
			 (allocator) )))
   (disconnect (lambda ()
		 (disconnectdisplay fd)
		 'disconnected))
   (atombox (lambda ()
	      (if atombox
		  atombox
		  (begin
		    (set! atombox (make-atombox x-protocol-atoms me))
		    atombox))))		    
   (pointer (lambda ()		; Return the pointer object
	      (if pointer
		  pointer
		  (begin
		    (set! pointer (make-pointer me))
		    pointer))))
   (keyboard (lambda ()		; Return the keyboard object
	       (if keyboard
		   keyboard
		   (begin
		     (set! keyboard (make-keyboard me))
		     keyboard))))
   (defaultscreen (lambda ()
		    (car screens) ))
   (screens (lambda () screens))	; A list of screen objects
   
   ;;
   ;; Buffering operations
   ;;
   ;; Note1: It is difficult to have the check for overflow in C, as it is
   ;;        impossible to have the current position there all the time
   ;;        (because of several dpy's sharing the same C routines).
   (scix-xas (lambda (l rest)
	       (let ((current-request-size 0))
		 (zero-buffer-position)
		 (for-each (lambda (p)
			     ((car p) (cdr p) current-request) )
			   l)
		 (set! current-request-size (current-buffer-position))
		 (if buffer
		     (if (> (+ tot-buffer-size current-request-size)
			    max-buffer)
			 (begin		  ;; Need to flush the buffer
			   (writesock fd request-buffer tot-buffer-size)
			   (set! tot-buffer-size
				 (string-append! request-buffer
						 current-request
						 0
						 current-request-size)) )
			 (begin
			   (set! tot-buffer-size
				 (string-append! request-buffer
						 current-request
						 tot-buffer-size
						 current-request-size))))
		     (begin
		       (writesock fd current-request current-request-size)
		       (set! tot-buffer-size 0) ))
		 (set! seq-nr (+ 1 seq-nr))
		 (let ((r (strip-object rest))) ; Any special error object?
		   (if (not (null? r))
		       (set-cdr! (last-pair history-list)
				 (list (cons seq-nr r)) )))
		 seq-nr)))
   
   (do-buffer (lambda () (set! buffer #t)))
   (do-not-buffer (lambda ()
		    (me 'flush!)
		    (set! buffer #f) ))
   (flush! (lambda ()
	     (if (not (zero? tot-buffer-size))
		 (begin
		   (writesock fd request-buffer tot-buffer-size)
		   (set! tot-buffer-size 0)
		   #t)		; #t indicates stuff found to flush
		 #f)))		; #f           nothing to flush
   

   (sync! (lambda (discard)
	    (msg-handler 'sync! me discard) ))

   ;; Error handling.
   ;;
   ;; Note: The structure of an error-object as recieved by an error-handler
   ;;       is (<error> <object>), where <error> is the error-object supplied
   ;;       by the disassembler and <object> is the unparsed object that can
   ;;       be supplied in the assembler. It can typically be a continuation.
   ;;       The history-list is a list of pairs of seq-nr and <object>.
   (install-error-handler (lambda (handler)
			    (let ((old-handler error-handler))
			      (set! error-handler handler)
			      old-handler)))
   (scix-error-dispatch (lambda (error)
			  (let ((error-seq-nr (error 'seq-nr)))
			    (let loop ((hist-l history-list))
			      (cond ((null? hist-l)
				     (error-handler (list error #f)) )
				    ((= error-seq-nr (caar hist-l))
				     (set-cdr! history-list (cdr hist-l))
				     (error-handler (list error
							  (cdar hist-l) )))
				    (else
				     (loop (cdr hist-l)) ))))))
   
   ;;
   ;; Methods directly mapped on X protocol core requests
   ;;
   (setselectionowner (lambda (owner sel time . rest)  ; #22: SetSelectionOwner
			(send-setselectionowner owner sel time me rest) ))
   (getselectionowner (lambda (sel . rest)             ; #23: GetSelectionOwner
			(send-getselectionowner sel me rest) ))
   (convertselection (lambda (requestor sel target      ; #24: ConvertSelection
					prop time . rest) 
		       (send-convertselection requestor sel target
					      prop time me rest) ))
   (sendevent (lambda (propagate w ev-mask              ; #25: SendEvent
				 ev-name ev-data . rest) 
		(send-sendevent propagate w ev-mask
				ev-name ev-data me rest) ))
   (allowevents (lambda (mode time . rest)              ; #35: AllowEvents
		  (send-allowevents mode time me rest) ))
   (grabserver (lambda rest		                ; #36: GrabServer
		 (send-grabserver me rest) ))
   (ungrabserver (lambda rest		                ; #37: UngrabServer
		   (send-ungrabserver me rest) ))
   (setinputfocus (lambda (revert-to focus time . rest) ; #42: SetInputFocus
		    (send-setinputfocus revert-to focus time me rest) ))
   (getinputfocus (lambda rest		                ; #43: GetInputFocus
		    (send-getinputfocus me rest) ))
   (listfonts (lambda (maxnames pattern . rest)         ; #49: ListFonts
		(send-listfonts maxnames pattern me rest) ))
   (listfontswithinfo (lambda (maxnames pattern . rest) ;#50: ListFontsWithInfo
			(send-listfontswithinfo maxnames pattern me rest) ))
   (setfontpath (lambda (list-of-str . rest)	        ; #51: SetFontPath
		  (send-setfontpath list-of-str me rest) ))
   (getfontpath (lambda rest		                ; #52: GetFontPath
		  (send-getfontpath me rest) ))
   (queryextension (lambda (name . rest)                ; #98: QueryExtension
		     (send-queryextension name me rest) ))
   (listextensions (lambda rest                         ; #99: ListExtensions
		     (send-listextensions me rest) ))
   (bell (lambda (percent . rest)	                ; #104: Bell
	   (send-bell percent me rest) ))
   (setscreensaver (lambda (timeout interval            ; #107: SetScreenSaver
				    prefer-blanking allow-exposures . rest)
		     (send-setscreensaver timeout interval prefer-blanking
					  allow-exposures me rest) ))
   (getscreensaver (lambda rest                         ; #108: GetScreenSaver
		     (send-getscreensaver me rest) ))
   (changehosts (lambda (mode family addr . rest)       ; #109: ChangeHosts
		  (send-changehosts mode family addr me rest) ))
   (listhosts (lambda rest                              ; #110: ListHosts
		(send-listhosts me rest) ))
   (setaccesscontrol (lambda (mode . rest)             ; #111: SetAccessControl
		       (send-setaccesscontrol mode me rest) ))
   (setclosedownmode (lambda (mode . rest)             ; #112: SetCloseDownMode
		       (send-setclosedownmode mode me rest) ))
   (killclient (lambda (resource . rest)                ; #113: KillClient
		 (send-killclient resource me rest) ))
   (forcescreensaver (lambda (mode . rest)             ; #115: ForceScreenSaver
		       (send-forcescreensaver mode me rest) ))
   (nooperation (lambda rest                            ; #127: NoOperation
		  (send-nooperation me rest) )) )
  
  ;; The init routine for a display object attempts to connect to the server
  ;; and on success sets up various local variables.
  ;;
  (init (set! fd (connectdisplay (if (zero? (string-length display-name))
				     0
				     display-name)))
	(cond ((negative? fd)
	       (format #t "make-display: Error when connecting to server~%")
	       (set! me #f) )		; Junk display object
	      (else
	       (let ((reply (send-initconnection me)))
		 (cond ((memq 'vendor (reply 'supported-messages)) ; Got to
			(set! initial-reply reply)  ; test for something...
			(set! allocator (make-xid-allocator initial-reply))
			(blocking-io fd)
			(set! screens (map (lambda (data)
					     (make-screen data me))
					   (initial-reply 'roots) ))
			(set! max-buffer
			      (initial-reply 'max-request-len) )
			(set! request-buffer (make-string max-buffer))
			(set! current-request (make-string max-buffer))
			(set! state 'initialized) )
		       (else
			(format #t
			"make-display: Connection refused. Reason: ~a~%"
				(reply 'reason) )
			(set! me #f) ))))))		; Junk display object
  
  ) ;; End of define-class

;;; make-xid-allocator is converted to both display and initial-reply as
;;; objects
(define (make-xid-allocator initial-reply)
  (let ((id 0)
	(id-mask (initial-reply 'resource-id-mask))
	(id-base (initial-reply 'resource-id-base)) )
    (lambda ()
      (set! id (+ 1 id))
      (bit-or (bit-and id id-mask) id-base) )))