222 lines
6.9 KiB
Scheme
222 lines
6.9 KiB
Scheme
;; 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-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?.
|
|
|
|
(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.
|
|
|
|
(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)))))))
|
|
|
|
;; 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)
|
|
(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)))
|
|
|
|
;; 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")
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|