;; Copyright 2015 John J Foerch. All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in ;; the documentation and/or other materials provided with the ;; distribution. ;; ;; THIS SOFTWARE IS PROVIDED BY JOHN J FOERCH ''AS IS'' AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE ;; DISCLAIMED. IN NO EVENT SHALL JOHN J FOERCH OR CONTRIBUTORS BE LIABLE ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR ;; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ;; ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (module xlib-utils (;; xcontext api make-xcontext xcontext? xcontext-display xcontext-screen xcontext-window with-xcontext ;; xcontext helpers %xcontext-accessor ;; the utils window-property-type window-property-format window-property-data window-property-count make-atom-property make-number-property make-numbers-property make-text-property window-property-set window-property-append switch-to-desktop) (import chicken scheme foreign foreigners) (use (srfi 4) data-structures lolevel matchable xlib) (foreign-declare "#include ") ;;; ;;; Xcontext ;;; (define current-xcontext (make-parameter #f)) (define-record-type xcontext: (%%make-xcontext display screen window) xcontext? (display xcontext-display xcontext-display-set!) (screen xcontext-screen xcontext-screen-set!) (window xcontext-window xcontext-window-set!)) (define (xcontext-populate xc #!key display screen window) (when display (xcontext-display-set! xc display)) (when screen (xcontext-screen-set! xc screen)) (when window (xcontext-window-set! xc window)) (when (and (xcontext-display xc) (not (xcontext-screen xc))) (xcontext-screen-set! xc (xdefaultscreen display))) xc) (define %make-xcontext (case-lambda ((display screen window) (%%make-xcontext display screen window)) (() (%%make-xcontext #f #f #f)))) (define (xcontext-clone xc) (%%make-xcontext (xcontext-display xc) (xcontext-screen xc) (xcontext-window xc))) (define make-xcontext (match-lambda* (() (%make-xcontext)) (((? keyword? k) . rest) (apply xcontext-populate (%make-xcontext) k rest)) ((xc (? keyword? k) . rest) (apply xcontext-populate (xcontext-clone xc) k rest)))) (define (%xcontext-accessor field) (alist-ref field `((xcontext . ,identity) (display . ,xcontext-display) (screen . ,xcontext-screen) (window . ,xcontext-window)))) (define-syntax with-xcontext (syntax-rules () ((with-xcontext xc (field ...) form . forms) (let* ((_xc xc) ;; evaluate xc only once (field ((%xcontext-accessor 'field) _xc)) ...) form . forms)))) ;;; ;;; Window Property Utils ;;; (define-record window-property type format data count) (define (make-atom-property xcontext atom-name) (let* ((display (xcontext-display xcontext)) (data (xinternatom display atom-name 0))) (let-location ((data unsigned-long data)) (make-window-property "ATOM" 32 (location data) 1)))) (define (make-number-property number) (let-location ((data unsigned-long number)) (make-window-property "CARDINAL" 32 (location data) 1))) (define (make-numbers-property numbers) (let* ((vec (list->u32vector numbers)) (len (u32vector-length vec)) (lvec ((foreign-lambda* c-pointer ((u32vector s) (int length)) "unsigned long * lvec = malloc(sizeof(unsigned long) * length);" "int i;" "for (i = 0; i < length; i++) {" " lvec[i] = s[i];" "}" "C_return(lvec);") vec len))) (set-finalizer! lvec free) (make-window-property "CARDINAL" 32 lvec len))) (define (make-text-property textp) (let ((tp (make-xtextproperty))) (set-xtextproperty-value! tp (make-locative textp)) (set-xtextproperty-encoding! tp XA_STRING) (set-xtextproperty-format! tp 32) (set-xtextproperty-nitems! tp 1) tp)) (define (window-property-set xcontext key value) (with-xcontext xcontext (display window) (xchangeproperty display window (xinternatom display key 0) (xinternatom display (window-property-type value) 0) (window-property-format value) PROPMODEREPLACE (window-property-data value) (window-property-count value)))) (define (window-property-append xcontext key value) (with-xcontext xcontext (display window) (xchangeproperty display window (xinternatom display key 0) (xinternatom display (window-property-type value) 0) (window-property-format value) PROPMODEAPPEND (window-property-data value) (window-property-count value)))) ;;; ;;; Switch To Desktop ;;; (define (switch-to-desktop/number display screen desktop) (let ((root (xrootwindow display screen)) (event-mask (bitwise-ior SUBSTRUCTURENOTIFYMASK SUBSTRUCTUREREDIRECTMASK)) (event (make-xclientmessageevent))) (set-xclientmessageevent-type! event CLIENTMESSAGE) (set-xclientmessageevent-serial! event 0) (set-xclientmessageevent-send_event! event 1) (set-xclientmessageevent-display! event display) (set-xclientmessageevent-window! event root) (set-xclientmessageevent-message_type! event (xinternatom display "_NET_CURRENT_DESKTOP" 0)) (set-xclientmessageevent-format! event 32) (define make-event-data-l (foreign-lambda* void (((c-pointer long) data_l) (long l0) (long l1) (long l2) (long l3) (long l4)) "data_l[0] = l0; data_l[1] = l1;" "data_l[2] = l2; data_l[3] = l3;" "data_l[4] = l4;")) (make-event-data-l (xclientmessageevent-data-l event) desktop (current-seconds) 0 0 0) (xsendevent display root 0 event-mask event))) (define (switch-to-desktop xcontext desktop) (with-xcontext xcontext (display screen) (cond ((number? desktop) (switch-to-desktop/number display screen desktop)) ((string? desktop) (let ((root (xrootwindow display screen)) (MAX_PROPERTY_VALUE_LEN 4096) (property (xinternatom display "_NET_DESKTOP_NAMES" 0)) (req_type (xinternatom display "UTF8_STRING" 0))) (let-location ((xa_ret_type unsigned-long) (ret_format int) (ret_nitems unsigned-long) (ret_bytes_after unsigned-long) (ret_prop unsigned-c-string*)) (xgetwindowproperty display root property 0 (/ MAX_PROPERTY_VALUE_LEN 4) 0 req_type (location xa_ret_type) (location ret_format) (location ret_nitems) (location ret_bytes_after) (location ret_prop)) (assert (= req_type xa_ret_type)) (define find-desktop (foreign-lambda* int ((unsigned-c-string target) ((c-pointer unsigned-c-string) names) (unsigned-long nitems)) "int i, d = 0, atstart = 1;" "for (i = 0; i < nitems; i++) {" " if (atstart) {" " if (0 == strcmp(target, &names[0][i]))" " C_return(d);" " atstart = 0;" " }" " if (names[0][i] == 0) {" " atstart = 1;" " d++;" " }" "}" "C_return(-1);")) (let ((desktop-number (find-desktop desktop (location ret_prop) ret_nitems))) (when (> desktop-number -1) (switch-to-desktop/number display screen desktop-number))))))))) )