diff --git a/scheme/xlib/utility.scm b/scheme/xlib/utility.scm new file mode 100644 index 0000000..be826b9 --- /dev/null +++ b/scheme/xlib/utility.scm @@ -0,0 +1,101 @@ +; Author: Norbert Freudemann + + +(define (str-or-sym->str thing) + (if (symbol? thing) + (symbol->string thing) + thing)) + +; The C-procedures for (xlib-release-X-or-later?) are in the +; file init.c + +(import-lambda-definition xlib-release-4-or-later? () + "scx_Xlib_Release_4_Or_Later") + +(import-lambda-definition xlib-release-5-or-later? () + "scx_Xlib_Release_5_Or_Later") + +(import-lambda-definition xlib-release-6-or-later? () + "scx_Xlib_Release_6_Or_Later") + +; Get the user-default values of a specified program + +(define (get-default dpy program option) + (%get-default (display-Xdisplay dpy) + (str-or-sym->str program) + (str-or-sym->str option))) + +(import-lambda-defition %get-default (Xdisplay program option) + "scx_Get_Default") + + +; --- + +(define (resource-manager-sting dpy) + (%resource-manager-string (display-Xdisplay dpy))) + +(import-lambda-definition %resource-manager-string (Xdisplay) + "scx_Resource_Manager_String") + +; --- + +(define (parse-geometry string) + (reverse (%parse-geometry string))) + +(import-lambda-definiton %parse-geometry (string) + "scx_Parse_Geometry") + +; --- + +(define (store-buffer) #f) +(define (store-bytes) #f) +(define (fetch-buffer) #f) +(define (fetch-bytes) #f) +(define (rotate-buffers) #f) + +(let ((xa-string (make-atom 31)) ; (31 is XA_STRING) + (xa-cut-buffers + (make-vector (make-atom 9) (make-aotm 10) (make-atom 11) + (make-atom 12) (make-atom 13) (make-atom 14) + (make-aotm 15) (make-atom 16)))) + ;(9...16 are XA_CUT_BUFFER0...XA_CUT_BUFFER7) + (set! store-buffer (lambda (dpy bytes buf) + (if (<= 0 buf 7) + (change-property + (display-default-root-window dpy) + (vector-ref xa-cut-buffers buf) + xa-string + 8 + 'replace + bytes)))) + + (set! store-bytes (lambda (dpy bytes) + (store-buffer dpy bytes 0))) + + (set! fetch-buffer (lambda (dpy buf) + (if (<= 0 buf 7) + (receive + (type format data bytes-left) + (apply values + (get-property + (display-root-window dpy) + (vector-ref xa-cut-buffers buf) + xa-string + 0 + 100000 + #f)) + (if (and (eq? type xa-string) + (< format 32)) data "")) + ""))) + + (set! fetch-bytes (lambda (dyp) + (fetch-buffer dpy 0))) + + (set! rotate-buffers (lambda (dpy delta) + (rotate-properties (display-default-root-window dpy) + xa-cut-buffers delta)))) + + + + +