234 lines
7.1 KiB
Scheme
234 lines
7.1 KiB
Scheme
|
(define (iconify-window window screen-number)
|
||
|
|
(check-screen-number (window-display window) screen-number)
|
||
|
|
(if (not (%iconify-window (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
screen-number))
|
||
|
|
(error "cannot iconify window"
|
||
|
|
window)))
|
||
|
|
|
||
|
|
(import-lambda-definition %iconify-window (Xdisplay Xwindow scr-num)
|
||
|
|
"scx_Iconify_Window")
|
||
|
|
|
||
|
|
(define (withdraw-window window screen-number)
|
||
|
|
(check-screen-number screen-number)
|
||
|
|
(if (not (%withdraw-window (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
screen-number))
|
||
|
|
(error "cannot withdraw window"
|
||
|
|
window)))
|
||
|
|
|
||
|
|
(import-lambda-definition %withdraw-window (Xdisplay Xwindow scr-num)
|
||
|
|
"scx_Withdraw_Window")
|
||
|
|
|
||
|
|
(define (reconfigure-wm-window window screen-number . args)
|
||
|
|
(check-screen-number screen-number)
|
||
|
|
(if (not (%reconfigure-wm-window (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
screen-number
|
||
|
|
(named-args->alist args)))
|
||
|
|
(error "cannot reconfigure window"
|
||
|
|
window)))
|
||
|
|
|
||
|
|
(import-lambda-definition %reconfigure-wm-window (Xdisplay Xwindow scrnum alist)
|
||
|
|
"scx_Reconfigure_Wm_Window")
|
||
|
|
|
||
|
|
(define (wm-command window)
|
||
|
|
(vector->list (%wm-command (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window))))
|
||
|
|
|
||
|
|
(import-lambda-definition %wm-command (Xdisplay Xwindow)
|
||
|
|
"scx_Wm_Command")
|
||
|
|
|
||
|
|
(define (get-text-property window atom)
|
||
|
|
(let ((res (%get-text-property (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
(atom-Xatom atom))))
|
||
|
|
(cond
|
||
|
|
((eq? res #t) #f)
|
||
|
|
((eq? res #f) (error "cannot create string list from text property"))
|
||
|
|
(else (vector->list res)))))
|
||
|
|
|
||
|
|
(import-lambda-definition %get-text-property (Xdisplay Xwindow Xatom)
|
||
|
|
"scx_Get_Text_Property")
|
||
|
|
|
||
|
|
(define (set-text-property! window value atom)
|
||
|
|
(let ((res (%set-text-property! (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
(list->vector value)
|
||
|
|
(atom-Xatom atom))))
|
||
|
|
(if res
|
||
|
|
res
|
||
|
|
(error "cannot create text property from string list" value))))
|
||
|
|
|
||
|
|
(import-lambda-definition %set-text-property! (Xdisplay Xwindow value XAtom)
|
||
|
|
"scx_Set_Text_Property")
|
||
|
|
|
||
|
|
(define (wm-protocols window)
|
||
|
|
(let ((res (%wm-protocols (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window))))
|
||
|
|
(if res
|
||
|
|
(map make-atom
|
||
|
|
(vector->list res))
|
||
|
|
(error "cannot get WM protocols"))))
|
||
|
|
|
||
|
|
(import-lambda-definition %wm-protocols (Xdisplay Xwindow)
|
||
|
|
"scx_Wm_Protocols")
|
||
|
|
|
||
|
|
(define (set-wm-protocols! window protocols)
|
||
|
|
(let ((res (%set-wm-protocols! (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
(list->vector (map atom-Xatom protocols)))))
|
||
|
|
(if res
|
||
|
|
res
|
||
|
|
(error "cannot set WM protocols" protocols))))
|
||
|
|
|
||
|
|
(import-lambda-definition %set-wm-protocols! (Xdisplay Xwindow protocols)
|
||
|
|
"scx_Set_Wm_Protocols")
|
||
|
|
|
||
|
|
(define (wm-class window)
|
||
|
|
(let ((res (%wm-class (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window))))
|
||
|
|
(if res
|
||
|
|
res
|
||
|
|
(error "cannot get WM class hint"))))
|
||
|
|
|
||
|
|
(import-lambda-definition %wm-class (Xdisplay Xwindow)
|
||
|
|
"scx_Wm_Class")
|
||
|
|
|
||
|
|
(define (set-wm-class! window name class)
|
||
|
|
(%set-wm-class! (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
(if (symbol? name)
|
||
|
|
(symbol->string name)
|
||
|
|
name)
|
||
|
|
(if (symbol? class)
|
||
|
|
(symbol->string class)
|
||
|
|
class)))
|
||
|
|
|
||
|
|
(import-lambda-definition %set-wm-class! (Xdisplay Xwindow name class)
|
||
|
|
"scx_Set_Wm_Class")
|
||
|
|
|
||
|
|
(define (set-wm-command! window command)
|
||
|
|
(%set-wm-command! (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
(list->vector (map (lambda (x)
|
||
|
|
(if (symbol? x)
|
||
|
|
(symbol->string x)
|
||
|
|
x))
|
||
|
|
command))))
|
||
|
|
|
||
|
|
(import-lambda-definition %set-wm-command (Xdisplay Xwindow command)
|
||
|
|
"scx_Set_Wm_Command")
|
||
|
|
|
||
|
|
(define (wm-hints window)
|
||
|
|
(let ((res (%wm-hints (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)))
|
||
|
|
(make-window* (lambda (Xwindow)
|
||
|
|
(make-window Xwindow (window-display window)
|
||
|
|
#f)))
|
||
|
|
(make-pixmap* (lambda (Xpixmap)
|
||
|
|
(make-pixmap Xpixmap (window-display window)
|
||
|
|
#f))))
|
||
|
|
(vector-set! res 2 make-pixmap*)
|
||
|
|
(vector-set! res 3 make-window*)
|
||
|
|
(vector-set! res 6 make-pixmap*)
|
||
|
|
(vector-set! res 7 make-window*)
|
||
|
|
(map cons
|
||
|
|
'(input? initial-state icon-pixmap icon-window icon-x icon-y
|
||
|
|
icon-mask window-group urgency)
|
||
|
|
(vector->list res))))
|
||
|
|
|
||
|
|
(import-lambda-definition %wm-hints (Xdisplay Xwindow)
|
||
|
|
"scx_Wm_Hints")
|
||
|
|
|
||
|
|
(define (set-wm-hints! window . args)
|
||
|
|
(%set-wm-hints! (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
(map (lambda (p)
|
||
|
|
(case (car p)
|
||
|
|
((icon-pixmap icon-mask)
|
||
|
|
(cons (car p) (pixmap-Xpixmap (cdr p))))
|
||
|
|
((icon-window window-group)
|
||
|
|
(cons (car p) (window-Xwindow (cdr p))))
|
||
|
|
(else p)))
|
||
|
|
(named-args->alist args))))
|
||
|
|
|
||
|
|
(import-lambda-definition %set-wm-hints! (Xdisplay Xwindow args)
|
||
|
|
"scx_Set_Wm_Hints")
|
||
|
|
|
||
|
|
(define (transient-for window)
|
||
|
|
(make-window (%transient-for (display-Xdisplay (display-window window))
|
||
|
|
(window-Xwindow window))
|
||
|
|
(window-display window)
|
||
|
|
#f))
|
||
|
|
|
||
|
|
(import-lambda-definition %transient-for (Xdisplay Xwindow)
|
||
|
|
"scx_Transient_For")
|
||
|
|
|
||
|
|
(define (set-transient-for! window property-window)
|
||
|
|
(%set-transient-for (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
(window-Xwindow property-window)))
|
||
|
|
|
||
|
|
(import-lambda-definition %set-transient-for! (Xdisplay Xwindow
|
||
|
|
Xpropertywindow)
|
||
|
|
"scx_Set_Transient_For")
|
||
|
|
|
||
|
|
(define xa-wm-name (make-atom 39))
|
||
|
|
(define xa-wm-icon-name (make-atom 37))
|
||
|
|
(define xa-wm-client-machine (make-atom 36))
|
||
|
|
|
||
|
|
(define (wm-name w)
|
||
|
|
(get-text-property w xa-wm-name))
|
||
|
|
|
||
|
|
(define (wm-icon-name w)
|
||
|
|
(get-text-property w xa-wm-icon-name))
|
||
|
|
|
||
|
|
(define (wm-client-machine w)
|
||
|
|
(get-text-property w xa-wm-client-machine))
|
||
|
|
|
||
|
|
(define (set-wm-name! w s)
|
||
|
|
(set-text-property! w s xa-wm-name))
|
||
|
|
|
||
|
|
(define (set-wm-icon-name! w s)
|
||
|
|
(set-text-property! w s xa-wm-icon-name))
|
||
|
|
|
||
|
|
(define (set-wm-client-machine! w s)
|
||
|
|
(set-text-property! w s xa-wm-client-machine))
|
||
|
|
|
||
|
|
(define (wm-normal-hints window)
|
||
|
|
(let* ((v (%wm-normal-hints (display-Xdisplay (window-Xwindow window))
|
||
|
|
(window-Xwindow window)))
|
||
|
|
(alist (map cons
|
||
|
|
'(x y width height us-position us-size
|
||
|
|
min-width min-height max-width max-height
|
||
|
|
width-inc height-inc min-aspect-x min-aspect-y
|
||
|
|
max-aspect-x max-aspect-y base-width base-height
|
||
|
|
gravity)
|
||
|
|
(vector->list v))))
|
||
|
|
alist))
|
||
|
|
|
||
|
|
|
||
|
|
(define (set-wm-normal-hints! window . args)
|
||
|
|
(let ((alist (named-args->alist args)))
|
||
|
|
(%set-wm-normal-hints! (display-Xdisplay (window-Xwindow window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
alist)))
|
||
|
|
|
||
|
|
(define (icon-sizes window)
|
||
|
|
(let ((r (%icon-sizes (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window))))
|
||
|
|
(map vector->list
|
||
|
|
(vector->list r))))
|
||
|
|
|
||
|
|
(import-lambda-definition %icon-sizes (Xdisplay Xwindow)
|
||
|
|
"scx_Icon_Sizes")
|
||
|
|
|
||
|
|
(define (set-icon-sizes! window icon-sizes)
|
||
|
|
(%set-icon-sizes! (display-Xdisplay (window-display window))
|
||
|
|
(window-Xwindow window)
|
||
|
|
(list->vector (map list->vector icon-sizes))))
|
||
|
|
|
||
|
|
(import-lambda-definition %set-icon-sizes! (Xdisplay Xwindow sizes)
|
||
|
|
"scx_Set_Icon_Sizes")
|