From 4eb658e8a909c309287ea976c3f1f514b3aff356 Mon Sep 17 00:00:00 2001 From: frese Date: Tue, 21 Aug 2001 14:45:32 +0000 Subject: [PATCH] first implementation. --- scheme/xlib/client.scm | 233 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 233 insertions(+) create mode 100644 scheme/xlib/client.scm diff --git a/scheme/xlib/client.scm b/scheme/xlib/client.scm new file mode 100644 index 0000000..36359a6 --- /dev/null +++ b/scheme/xlib/client.scm @@ -0,0 +1,233 @@ +(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")