- fixed a bug in get-property.

- added some functions for easier access to properties: get-property,
  get-string-property, change-string-property.

c/xlib/property.c

@@ -46,20 +46,23 @@ s48_value scx_List_Properties (s48_value Xwindow, s48_value Xdisplay){
 
 
 s48_value scx_Get_Property(s48_value Xwindow, s48_value Xdisplay, 
-		       s48_value Xatom_prop,
+			   s48_value Xatom_prop,
-		       s48_value Xatom_type, s48_value start, s48_value len,
+			   s48_value Xatom_type, s48_value start,
-		       s48_value deletep) {
+			   s48_value len, s48_value deletep) {
-  Atom req_type = AnyPropertyType, actual_type_ret;
+  // Assumes short is 16 bits and int is 32 bits!
+  
+  Atom req_type = S48_FALSE_P(Xatom_prop) ? AnyPropertyType
+    : SCX_EXTRACT_ATOM(Xatom_type);
+
+  Atom actual_type_ret;
   int format_ret, i;
   unsigned long nitems_ret, bytes_left_ret;
   unsigned char* prop_ret;
-  s48_value ret = S48_FALSE, x, v = S48_FALSE;
 
-  S48_DECLARE_GC_PROTECT(2);
+  s48_value ret = S48_FALSE, x = S48_FALSE, v = S48_FALSE;
+
+  S48_DECLARE_GC_PROTECT(3);
 
-  if (!S48_FALSE_P(Xatom_type)){
-    req_type = s48_extract_integer(Xatom_type);
-  }
   //not used: Disable_Interrupts
   XGetWindowProperty (SCX_EXTRACT_DISPLAY(Xdisplay), 
 		      SCX_EXTRACT_WINDOW(Xwindow),
@@ -69,61 +72,59 @@ s48_value scx_Get_Property(s48_value Xwindow, s48_value Xdisplay,
 		      req_type, &actual_type_ret, &format_ret, &nitems_ret,
 		      &bytes_left_ret, &prop_ret);
 
-  S48_GC_PROTECT_2 (ret, v);
+  if (actual_type_ret == None) {
-  ret = s48_cons(s48_enter_integer(bytes_left_ret), S48_NULL);
+    // Property does not exists
-  if (nitems_ret){
+    ret = S48_FALSE;
-    if (format_ret == 8){
+  } else {
-      char d[nitems_ret+1];
+    // Create the data as a vector
-      bcopy((char *)prop_ret, d, (int)nitems_ret);
+    S48_GC_PROTECT_3 (ret, v, x);
-      d[nitems_ret+1] = (char)0;
+
-      ret = s48_cons (s48_enter_string(d), ret);
+    v = s48_make_vector(nitems_ret, S48_FALSE);
-    }else{
+    for (i = 0; i < nitems_ret; i++) {
-      // Assumes short is 16 bits and int is 32 bits.
+      switch (format_ret) {
-      v = s48_make_vector (nitems_ret, S48_NULL);
+      case 8: x = s48_enter_fixnum(((char*) prop_ret)[i]); break;
-      for (i = 0; i < nitems_ret; i++){
+      case 16: x = s48_enter_fixnum(((short*) prop_ret)[i]); break;
-	x = s48_enter_integer (format_ret == 16 ?
+      case 32: x = s48_enter_integer(((long*) prop_ret)[i]); break;
-	*((short *)prop_ret + i) : *((int *)prop_ret + i));
-	S48_VECTOR_SET(v, i, x);
       }
-      ret = s48_cons(v, ret);
+      S48_VECTOR_SET(v, i, x);
     }
-  }else{ 
+
-    ret = (S48_NULL, ret);
+    ret = s48_cons(s48_enter_integer(bytes_left_ret), S48_NULL);
+    ret = s48_cons(v, ret);
+    ret = s48_cons(s48_enter_integer(format_ret), ret);
+    ret = s48_cons(SCX_ENTER_ATOM(actual_type_ret), ret);
+
+    S48_GC_UNPROTECT();
+    XFree(prop_ret); // only if property exists??
   }
-  ret = s48_cons(s48_enter_integer((long)format_ret), ret);
+
-  ret = s48_cons(s48_enter_integer((long)actual_type_ret), ret);
-  S48_GC_UNPROTECT();
   return ret;
 }
 
 
 s48_value scx_Change_Property(s48_value Xdisplay, s48_value Xwindow,
-			  s48_value Xatom_prop,  s48_value Xatom_type,
+			      s48_value Xatom_prop,  s48_value Xatom_type,
-			  s48_value format, s48_value mode, 
+			      s48_value format, s48_value mode, 
-			  s48_value data){
+			      s48_value data) {
-  int i, x, f, m, nitems;
+  long i, x;
-  char* buf;
+  int f = (int)s48_extract_integer(format);
-  m = s48_extract_integer(mode);
+  int m = s48_extract_integer(mode);
-  f = (int)s48_extract_integer(format);
+  int nitems = S48_VECTOR_LENGTH(data);
-  switch (f) {
+
-  case 8:
+  unsigned char buf[nitems * f];
-    buf = s48_extract_string(data);
+
-    nitems = strlen(buf);
+  for (i = 0; i < nitems; i++) {
-    break;
+    x = s48_extract_integer(S48_VECTOR_REF(data, i));
-  case 16: case 32:
+    switch (f) {
-    nitems = S48_VECTOR_LENGTH(data);
+    case 8: ((char*) buf)[i] = (char)x; break;
-    // Alloca (buf, char*, nitems * (f / sizeof (char)));
+    case 16: ((short*) buf)[i] = (short)x; break;
-    for (i = 0; i < nitems; i++) {
+    case 32: ((long*) buf)[i] = (long)x; break;
-      x = (int)s48_extract_integer(S48_VECTOR_REF(data, nitems));
+    }
-      if (f == 16) {
-	*((short *)buf + i) = x;     /* Assumes short is 16 bits */
-	}else *((int *)buf + i) = x; 
-    }   /*   and int is 32 bits. */
-      break;
   }
+
   XChangeProperty (SCX_EXTRACT_DISPLAY(Xdisplay), SCX_EXTRACT_WINDOW(Xwindow),
 		   SCX_EXTRACT_ATOM(Xatom_prop), SCX_EXTRACT_ATOM(Xatom_type),
-		   f, m, (unsigned char *)buf, nitems);
+		   f, m, buf, nitems);
   return S48_UNSPECIFIC;
 }
 

scheme/xlib/property.scm

@@ -1,21 +1,4 @@
-; --- author  : Norbert Freudemann ---
+;; find-atom returns an atom or #f if no atom of that name exists.
-; --- cr-date : 09.07.2001 ---
-; --- last-mod: 11.07.2001 ---
-
-
-; --- RETURN: atom
-
-(define (intern-atom display name)
-  (make-atom  (%intern-atom (display-Xdisplay display)
-			    (if (symbol? name)
-				(symbol->string name)
-				name))))
-
-(import-lambda-definition %intern-atom (Xdisplay name)
-  "scx_Intern_Atom")			  
-
-
-; ---  RETURN: atom or symbol: none
 
 (define (find-atom display name)
   (%find-atom (display-Xdisplay display)
@@ -26,7 +9,7 @@
 (import-lambda-definition %find-atom (Xdisplay name)
   "scx_Find_Atom")
 
-; ---  RETURN: string
+;; atom-name returns the name of the atom as a string.
 
 (define (atom-name display atom)
   (%atom-name (display-Xdisplay display)
@@ -35,55 +18,137 @@
 (import-lambda-definition %atom-name (Xdisplay atom)
   "scx_Atom_Name")
 
-; ---   RETURN: vector of atoms 
+;; 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-window-property 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?.
 
-; ---	Return: list consisting: '(atom integer data integer)
+(define (get-window-property window atom request-type offset length delete?)
-
+  (let ((type.format.data.bytes-left
-(define (get-property window property request-type offset length delete?)
+	 (%get-property (window-Xwindow window)
-  (%get-property (window-Xwindow window)
+			(display-Xdisplay (window-display window))
-		 (display-Xdisplay (window-display window))
+			(atom-Xatom atom)
-		 (atom-Xatom property)
+			(if request-type
-		 (atom-Xatom request-type)
+			    (atom-Xatom request-type)
-		 offset length delete?))
+			    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-window-property to read the whole property into a vector. It
+;; returns a list of three elements the vector, type-atom and the
+;; format.
 
-; --- RETURN -> "void"
+(define (get-property window atom delete?)
+  (let loop ((i 5))
+    (let ((t.f.d.b (get-window-property 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)))))))
 
-(define (change-property window property type format mode data)
+;; 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)))))))
+
+;; 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)
-		    format
+		    (check-format format)
-		    (property-mode->integer mode)
+		    (change-property-mode->integer
+		     (if (null? maybe-mode)
+			 (change-property-mode replace)
+			 (car maybe-mode)))
 		    data))
 
-(define (property-mode->integer mode)
+(define-enumerated-type change-property-mode :change-property-mode
-  (case mode
+  change-property-mode? change-property-modes change-property-mode-name
-    ((replace) 0)
+  change-property-mode-index
-    ((prepend) 1)
+  (replace prepend append))
-    ((append) 2)
+
-    (else (error "illegal change-property mode" mode))))
+(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")
 
-; --- RETURN -> "void"
+(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)))
+
+;; See XDeleteProperty
 
 (define (delete-property window property)
   (%delete-property (display-Xdisplay (window-display window))
@@ -93,33 +158,34 @@
 (import-lambda-definition %delete-property (Xdisplay Xwindow Xatom_prop)
    "scx_Delete_Property")
 
+;; See XRotateProperties. delta defaults to 1
 
-; --- RETURN -> "void"
+(define (rotate-properties window vector-of-atoms . maybe-delta)
-
-(define (rotate-properties window vector-of-atoms delta)
   (%rotate-properties (display-Xdisplay (window-display window))
 		      (window-Xwindow window)
 		      (vector-map! atom-Xatom vector-of-atoms)
-		      delta))
+		      (if (null? maybe-delta)
-					
+			  1
+			  (car maybe-delta))))
 					
 (import-lambda-definition %rotate-properties (Xdisplay Xwindow Xatom_vec delta)
   "scx_Rotate_Properties")
 
-; --- RETURN -> "void"
+;; See XSetSelectionOwner
 
-(define (set-selection-owner! display selection owner time)
+(define (set-selection-owner! display selection owner . maybe-time)
   (%set-selection-owner! (display-Xdisplay display)
 			 (atom-Xatom selection)
 			 (window-Xwindow owner)
-			 time))
+			 (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
-; --- RETURN -> Window (s48 record)
 
 (define (selection-owner display selection)
   (make-window (%get-selection-owner (display-Xdisplay display)
@@ -127,21 +193,21 @@
 	       display
 	       #f))
 
-
 (import-lambda-definition %get-selection-owner (Xdisplay Xatom_s)
    "scx_Get_Selection_Owner")
 
-; --- RETURN -> "void"
+;; property can be special-atom:none. See XConvertSelection
 
-(define (convert-selection selection target property requestor-window time)
+(define (convert-selection selection target property
+			   requestor-window . maybe-time)
   (%convert-selection (display-Xdisplay (window-display requestor-window))
 		      (atom-Xatom selection)
 		      (atom-Xatom target)
-		      (if (eq? 'none property)
+		      (atom-Xatom property)
-			  0
-			  (atom-Xatom property))
 		      (window-Xwindow requestor-window)
-		      time))
+		      (if (null? maybe-time)
+			  special-time:current-time
+			  (car maybe-time))))
 
 (import-lambda-definition %convert-selection (Xdisplay Xatom_s Xatom_t
 						       Xwindow time)