- fixed a bug in get-property.
- added some functions for easier access to properties: get-property, get-string-property, change-string-property.
This commit is contained in:
frese
parent
8bd6fd9c30
commit
6bb4947c2c
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue