scx/scheme/xlib/property.scm

;; find-atom returns an atom or #f if no atom of that name exists.

(define (find-atom display name)
  (%find-atom (display-Xdisplay display)
	      (if (symbol? name)
		  (symbol->string name)
		  name)))

(import-lambda-definition %find-atom (Xdisplay name)
  "scx_Find_Atom")

;; atom-name returns the name of the atom as a string.

(define (atom-name display atom)
  (%atom-name (display-Xdisplay display)
	      (atom-Xatom atom)))

(import-lambda-definition %atom-name (Xdisplay atom)
  "scx_Atom_Name")

;; list-properties return the list of atoms that exists for the
;; specified window. See XListProperties.

(define (list-properties window)
  (let ((atoms (%list-properties (display-Xdisplay (window-display window))
				 (window-Xwindow window))))
    (vector->list (vector-map! make-atom atoms))))

(import-lambda-definition %list-properties (Xdisplay Xwindow)
  "scx_List_Properties")

;; get-property-extended returns a list of four elements (atom format
;; data bytes-left) on success. format is one of 8, 16 or 32. #f is
;; returned if no such property of the requested type exists.
;; request-type can be #f, which means that the property can be of any
;; type. See XGetWindowProperty for offset, length and delete?.

(define (get-property-extended window atom request-type offset length delete?)
  (let ((type.format.data.bytes-left
	 (%get-property (window-Xwindow window)
			(display-Xdisplay (window-display window))
			(atom-Xatom atom)
			(if request-type
			    (atom-Xatom request-type)
			    0) ;; AnyPropertyType
			offset length delete?)))
    (if type.format.data.bytes-left
	(cons (make-atom (car type.format.data.bytes-left))
	      (cdr type.format.data.bytes-left))
	#f)))

(import-lambda-definition %get-property (Xwindow Xdisplay Xatom_prop Xatom_type
						 start len deletep)
   "scx_Get_Property")

;; get-property is a an easier way to access a property. It uses
;; get-property-extended to read the whole property into a vector. It
;; returns a list of three elements the vector, type-atom and the
;; format.

(define (get-property window atom delete?)
  (let loop ((i 5))
    (let ((t.f.d.b (get-property-extended window atom #f 0 i delete?)))
      (if (not t.f.d.b)
	  #f
	  (if (= (cadddr t.f.d.b) 0)
	      ;; if no bytes left, we're done
	      (list (caddr t.f.d.b)
		    (car t.f.d.b)
		    (cadr t.f.d.b))
	      ;; otherwise try to read twice as much
	      (loop (* i 2)))))))

;; get-string-property reads the specified property and returns the
;; data as a list of strings (0 in the data-vector are taken as
;; separators). The type of the property is ignored and the format has
;; to be 8 bit, otherwise #f is returned.

(define (get-string-property window atom delete?)
  (let ((v.t.f (get-property window atom delete?)))
    (if (or (not v.t.f) (not (= 8 (caddr v.t.f))))
	#f
	(let loop ((chars (map ascii->char (vector->list (car v.t.f))))
		   (str #f)
		   (rev-res '()))
	  (cond
	   ((null? chars)
	    (if str
		(reverse (cons str rev-res))
		(reverse rev-res)))
	   ((equal? (car chars) (ascii->char 0))
	    (loop (cdr chars) #f 
		  (cons (or str "") rev-res)))
	   (else
	    (loop (cdr chars) (string-append (or str "")
					     (string (car chars)))
		  rev-res)))))))

;; get-window-property reads the specified property of type WINDOW.

(define (get-window-property window atom delete?)
  (let ((dpy (window-display window))
	(v.t.f (get-property window atom delete?)))
    (if (or (not v.t.f) (not (eq? (intern-atom dpy "WINDOW")
				  (cadr v.t.f)))
	    (not (= 32 (caddr v.t.f))))
	#f ;; error message?
	(map (lambda (Xwindow)
	       (make-window Xwindow dpy #f))
	     (vector->list (car v.t.f))))))

;; change-property alters the property for the specified
;; window. property and type have to atoms, format has to be one of 8,
;; 16, 32, mode has to be a change-property-mode which defaults to
;; (change-property-mode replace) and data a vector of integers.

(define (change-property window property type format data . maybe-mode)
  (%change-property (display-Xdisplay (window-display window))
		    (window-Xwindow window)
		    (atom-Xatom property)
		    (atom-Xatom type)
		    (check-format format)
		    (change-property-mode->integer
		     (if (null? maybe-mode)
			 (change-property-mode replace)
			 (car maybe-mode)))
		    data))

(define-enumerated-type change-property-mode :change-property-mode
  change-property-mode? change-property-modes change-property-mode-name
  change-property-mode-index
  (replace prepend append))

(define (change-property-mode->integer mode)
  (change-property-mode-index mode))

(import-lambda-definition %change-property (Xdisplay Xwindow Xatom_prop
					    Xatom_type format mode data)
   "scx_Change_Property")

(define (check-format format)
  (if (not (and (number? format)
		(or (= format 8) (= format 16) (= format 32))))
      (error "property format has to be 8, 16 or 32" format)
      format))

;; change-string-property converts the given string or string-list
;; into a vector of 8-bit numbers (with ascii encoding) with 0
;; separating list-items and sets this value with change-property.

(define (change-string-property window property type str/str-list
				. maybe-mode)
  (let ((vec (list->vector (apply append
				  (map (lambda (s)
					 (append
					  (map char->ascii
					       (string->list s))
					  (list 0)))
				       (if (list? str/str-list)
					   str/str-list
					   (list str/str-list)))))))
    (apply change-property window property type 8 vec maybe-mode)))

;; change-window-property sets

;; See XDeleteProperty

(define (delete-property window property)
  (%delete-property (display-Xdisplay (window-display window))
		    (window-Xwindow window)
		    (atom-Xatom property)))

(import-lambda-definition %delete-property (Xdisplay Xwindow Xatom_prop)
   "scx_Delete_Property")

;; See XRotateProperties. delta defaults to 1

(define (rotate-properties window vector-of-atoms . maybe-delta)
  (%rotate-properties (display-Xdisplay (window-display window))
		      (window-Xwindow window)
		      (vector-map! atom-Xatom vector-of-atoms)
		      (if (null? maybe-delta)
			  1
			  (car maybe-delta))))
					
(import-lambda-definition %rotate-properties (Xdisplay Xwindow Xatom_vec delta)
  "scx_Rotate_Properties")

;; See XSetSelectionOwner

(define (set-selection-owner! display selection owner . maybe-time)
  (%set-selection-owner! (display-Xdisplay display)
			 (atom-Xatom selection)
			 (window-Xwindow owner)
			 (if (null? maybe-time)
			     special-time:current-time
			     (car maybe-time))))

(import-lambda-definition %set-selection-owner! (Xdisplay Xatom_s Xwindow_owner
							  time)
   "scx_Set_Selection_Owner")

;; See XGetSelectionOwner

(define (selection-owner display selection)
  (make-window (%get-selection-owner (display-Xdisplay display)
				     (atom-Xatom selection))
	       display
	       #f))

(import-lambda-definition %get-selection-owner (Xdisplay Xatom_s)
   "scx_Get_Selection_Owner")

;; property can be special-atom:none. See XConvertSelection

(define (convert-selection selection target property
			   requestor-window . maybe-time)
  (%convert-selection (display-Xdisplay (window-display requestor-window))
		      (atom-Xatom selection)
		      (atom-Xatom target)
		      (atom-Xatom property)
		      (window-Xwindow requestor-window)
		      (if (null? maybe-time)
			  special-time:current-time
			  (car maybe-time))))

(import-lambda-definition %convert-selection (Xdisplay Xatom_s Xatom_t
						       Xwindow time)
  "scx_Convert_Selection")