diff --git a/c/xlib/property.c b/c/xlib/property.c index 18966b7..67c34c9 100644 --- a/c/xlib/property.c +++ b/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_type, s48_value start, s48_value len, - s48_value deletep) { - Atom req_type = AnyPropertyType, actual_type_ret; + s48_value Xatom_prop, + s48_value Xatom_type, s48_value start, + s48_value len, s48_value deletep) { + // 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); - ret = s48_cons(s48_enter_integer(bytes_left_ret), S48_NULL); - if (nitems_ret){ - if (format_ret == 8){ - char d[nitems_ret+1]; - bcopy((char *)prop_ret, d, (int)nitems_ret); - d[nitems_ret+1] = (char)0; - ret = s48_cons (s48_enter_string(d), ret); - }else{ - // Assumes short is 16 bits and int is 32 bits. - v = s48_make_vector (nitems_ret, S48_NULL); - for (i = 0; i < nitems_ret; i++){ - x = s48_enter_integer (format_ret == 16 ? - *((short *)prop_ret + i) : *((int *)prop_ret + i)); - S48_VECTOR_SET(v, i, x); + if (actual_type_ret == None) { + // Property does not exists + ret = S48_FALSE; + } else { + // Create the data as a vector + S48_GC_PROTECT_3 (ret, v, x); + + v = s48_make_vector(nitems_ret, S48_FALSE); + for (i = 0; i < nitems_ret; i++) { + switch (format_ret) { + case 8: x = s48_enter_fixnum(((char*) prop_ret)[i]); break; + case 16: x = s48_enter_fixnum(((short*) prop_ret)[i]); break; + case 32: x = s48_enter_integer(((long*) prop_ret)[i]); break; } - 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 format, s48_value mode, - s48_value data){ - int i, x, f, m, nitems; - char* buf; - m = s48_extract_integer(mode); - f = (int)s48_extract_integer(format); - switch (f) { - case 8: - buf = s48_extract_string(data); - nitems = strlen(buf); - break; - case 16: case 32: - nitems = S48_VECTOR_LENGTH(data); - // Alloca (buf, char*, nitems * (f / sizeof (char))); - for (i = 0; i < nitems; i++) { - 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; + s48_value Xatom_prop, s48_value Xatom_type, + s48_value format, s48_value mode, + s48_value data) { + long i, x; + int f = (int)s48_extract_integer(format); + int m = s48_extract_integer(mode); + int nitems = S48_VECTOR_LENGTH(data); + + unsigned char buf[nitems * f]; + + for (i = 0; i < nitems; i++) { + x = s48_extract_integer(S48_VECTOR_REF(data, i)); + switch (f) { + case 8: ((char*) buf)[i] = (char)x; break; + case 16: ((short*) buf)[i] = (short)x; break; + case 32: ((long*) buf)[i] = (long)x; 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; } diff --git a/scheme/xlib/property.scm b/scheme/xlib/property.scm index d08a75e..af0afa2 100644 --- a/scheme/xlib/property.scm +++ b/scheme/xlib/property.scm @@ -1,21 +1,4 @@ -; --- author : Norbert Freudemann --- -; --- 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 +;; find-atom returns an atom or #f if no atom of that name exists. (define (find-atom display name) (%find-atom (display-Xdisplay display) @@ -24,9 +7,9 @@ name))) (import-lambda-definition %find-atom (Xdisplay name) - "scx_Find_Atom") + "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-property window property request-type offset length delete?) - (%get-property (window-Xwindow window) - (display-Xdisplay (window-display window)) - (atom-Xatom property) - (atom-Xatom request-type) - offset length delete?)) +(define (get-window-property 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-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 - (property-mode->integer mode) + (check-format format) + (change-property-mode->integer + (if (null? maybe-mode) + (change-property-mode replace) + (car maybe-mode))) data)) -(define (property-mode->integer mode) - (case mode - ((replace) 0) - ((prepend) 1) - ((append) 2) - (else (error "illegal change-property mode" mode)))) +(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") -; --- 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 delta) +(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) - 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") - -; --- RETURN -> Window (s48 record) +;; See XGetSelectionOwner (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) - 0 - (atom-Xatom property)) + (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)