;;;
;;; properties.lisp
;;;
;;; Window Property Database
;;;
;;; Copyright (C) 2008, Alastair Bridgewater.
;;;

(in-package :clxs)

;; Window properties are stored in a lazily-created hash table on the
;; window instance.  This hash table is created on first insert of a
;; property, and maintained for the life of the window.

(defstruct property
  type
  format
  data)

(define-x-request change-property (:opcode 18)
    ((opcode :opcode :value 18)
     (mode (:enum :u8 (:replace :prepend :append)))
     (length :length :value (+ 6 (truncate (+ (* data-length format) 31) 32)))
     (window :window)
     (property-name :atom)
     (type :atom)
     (format :u8 :typecheck '(member 8 16 32))
     (data-length :u32))
  (let* ((properties (or (window-properties window)
			 (setf (window-properties window)
			       (make-hash-table))))
	 ;; Our only error conditions are from a preexisting property,
	 ;; therefore adding the new property here causes no harm.
	 (property (or (gethash property-name properties)
		       (setf (gethash property-name properties)
			     (make-property :type type :format format)))))

    (when (and (or (eq mode :prepend)
		   (eq mode :append)))
      (unless (= type (property-type property))
	(protocol-error :match))
      (unless (= format (property-format property))
	(protocol-error :match)))

    (flet
	((read-result-data (data offset)
	   (if (eq (client-state-byte-order client) :lsb-first)
	       (dotimes (i data-length)
		 (setf (aref data (+ offset i))
		       (request-integer request
					(+ 24 (truncate (* i format) 8))
					(truncate format 8)
					:little-endian t)))
	       (dotimes (i data-length)
		 (setf (aref data (+ offset i))
		       (request-integer request
					(+ 24 (truncate (* i format) 8))
					(truncate format 8)))))))

      (case mode
	(:relative
	 (let ((data (make-array data-length
				 :element-type `(unsigned-byte ,format))))
	   (setf (property-type property) type)
	   (setf (property-format property) format)
	   (setf (property-data property) data)
	   (read-result-data data 0)))

	(:append
	 (let* ((old-data (property-data property))
		(old-length (length old-data))
		(data (adjust-array old-data (+ data-length old-length))))
	   (setf (property-data property) data)
	   (read-result-data data data-length)))

	(:prepend
	 (let* ((old-data (property-data property))
		(data (make-array (+ data-length (length old-data))
				  :element-type `(unsigned-byte ,format))))
	   (setf (subseq data data-length) old-data)
	   (setf (property-data property) data)
	   (read-result-data data data-length)))))

    #+(or) (send-???-event :property-notify window property :new-value)))

(define-x-request delete-property (:opcode 19)
    ((opcode :opcode :value 19)
     (length :length :value 3)
     (window :window)
     (property :atom))
  (let ((properties (window-properties window)))
    (when (and properties (remhash property properties))
      #+(or) (send-???-event :property-notify window property :deleted))))

(define-x-request get-property (:opcode 20)
    ((opcode :opcode :value 20)
     (delete :bool)
     (length :length :value 6)
     (window :window)
     (property :atom)
     (type (:union :atom (:enum :u32 (:any-property-type))))
     (long-offset :u32)
     (long-length :u32))
  )

(define-x-request list-properties (:opcode 21)
    ((opcode :opcode :value 21)
     (length :length :value 2)
     (window :window))
  ;; NOTE: This would be easier if we did
  ;; (or (window-properties window) (make-hash-table))
  ;; or had a spare empty hash-table lying around.
  (let ((properties (window-properties window))
	response)
    (if (null properties)
	(progn
	  (setf response (make-array 32
				     :element-type '(unsigned-byte 8)
				     :initial-element 0))
	  ;; FIXME: SET-RESPONSE-FIELDS would be nice.
	  (setf (aref response 0) 1)
	  (if (eq (client-state-byte-order client) :lsb-first)
	      (progn
		(setf (request-integer response 2 2 :little-endian t)
		      (client-state-request-number client)))
	      (progn
		(setf (request-integer response 2 2)
		      (client-state-request-number client)))))
	(let ((count (hash-table-count properties)))
	  (setf response (make-array (+ 32 (* 4 count))
				     :element-type '(unsigned-byte 8)
				     :initial-element 0))
	  ;; FIXME: SET-RESPONSE-FIELDS would be nice.
	  (setf (aref response 0) 1)
	  (if (eq (client-state-byte-order client) :lsb-first)
	      (progn
		(setf (request-integer response 2 2 :little-endian t)
		      (client-state-request-number client))
		(setf (request-integer response 4 4 :little-endian t)
		      count)
		(setf (request-integer response 8 2 :little-endian t)
		      count)
		(loop
		   for atom being each hash-key in properties
		   for index from 32 by 4
		   do (setf (request-integer response index 4
					     :little-endian t)
			    atom)))
	      (progn
		(setf (request-integer response 2 2)
		      (client-state-request-number client))
		(setf (request-integer response 4 4)
		      count)
		(setf (request-integer response 8 2)
		      count)
		(loop
		   for atom being each hash-key in properties
		   for index from 32 by 4
		   do (setf (request-integer response index 4)
			    atom))))))
    (send-packet (client-state-network-client client) response)))

(define-x-request rotate-properties (:opcode 114)
    ((opcode :opcode :value 114)
     (length :length :value ...))
  ;; FIXME: Fill in.
  )

;;; EOF