;; 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 xcontext-data xcontext-data-set! with-xcontext ;; xcontext helpers %xcontext-accessor ;; event dispatching add-event-handler! handle-event ;; event unpacking xclientmessageevent-data-b xclientmessageevent-data-s xclientmessageevent-data-l ;; 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 set-wm-protocols active-window-title switch-to-desktop) (import chicken scheme foreign foreigners) (use (srfi 1 4) data-structures lolevel matchable (only miscmacros begin0) (rename xlib (xclientmessageevent-data-b %xclientmessageevent-data-b) (xclientmessageevent-data-s %xclientmessageevent-data-s) (xclientmessageevent-data-l %xclientmessageevent-data-l))) (foreign-declare "#include ") ;;; ;;; Xcontext ;;; (define current-xcontext (make-parameter #f)) (define-record-type :xcontext (%%make-xcontext display screen window event-handlers) xcontext? (display xcontext-display xcontext-display-set!) (screen xcontext-screen xcontext-screen-set!) (window xcontext-window xcontext-window-set!) (event-handlers xcontext-event-handlers xcontext-event-handlers-set!) (data xcontext-data xcontext-data-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))) (when (and (xcontext-display xc) (xcontext-screen xc) (not (xcontext-window xc))) (xcontext-window-set! xc (xrootwindow display (xcontext-screen xc)))) xc) (define %make-xcontext (case-lambda ((display screen window) (%%make-xcontext display screen window #f)) (() (%%make-xcontext #f #f #f #f)))) (define (xcontext-clone xc) (%%make-xcontext (xcontext-display xc) (xcontext-screen xc) (xcontext-window xc) #f)) (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-root xc) (xrootwindow (xcontext-display xc) (xcontext-screen xc))) (define (%xcontext-accessor field) (alist-ref field `((xcontext . ,identity) (display . ,xcontext-display) (screen . ,xcontext-screen) (window . ,xcontext-window) (data . ,xcontext-data) (root . ,xcontext-root)))) (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)))) ;;; ;;; Event Dispatching ;;; (define-record-type :event-handler (%make-event-handler handler mask guard) event-handler? (handler event-handler-handler) (mask event-handler-mask) (guard event-handler-guard)) (define (make-event-handler handler mask guard) (let ((mask (cond ((pair? mask) (apply bitwise-ior mask)) ((eq? #f mask) 0) (else mask)))) (%make-event-handler handler mask guard))) (define (add-event-handler! xcontext event-type mask handler guard) (let* ((handler (make-event-handler handler mask guard)) (added? #f) (new-event-list (fold (lambda (x h) (cons (if (= event-type (first x)) (begin (set! added #t) (cons* event-type handler (cdr x))) x) h)) '() (or (xcontext-event-handlers xcontext) (list))))) (xcontext-event-handlers-set! xcontext (if added? new-event-list (cons (list event-type handler) new-event-list))))) (define (handle-event event xcontexts) (let* ((window (xevent-xany-window event)) (event-type (xevent-type event)) (target-xc (find (lambda (xc) (= window (xcontext-window xc))) xcontexts))) (and-let* ((handlers (xcontext-event-handlers target-xc)) (handlers (alist-ref event-type handlers))) (for-each (lambda (handler) (when ((or (event-handler-guard handler) identity) event) ((event-handler-handler handler) target-xc event))) handlers)))) ;;; ;;; Event Unpacking ;;; (define (xclientmessageevent-data-b event) (let ((data (%xclientmessageevent-data-b event))) (list-tabulate 20 (lambda (i) ((foreign-lambda* char (((c-pointer char) data) (int i)) "C_return(data[i]);") data i))))) (define (xclientmessageevent-data-s event) (let ((data (%xclientmessageevent-data-s event))) (list-tabulate 10 (lambda (i) ((foreign-lambda* short (((c-pointer short) data) (int i)) "C_return(data[i]);") data i))))) (define (xclientmessageevent-data-l event) (let ((data (%xclientmessageevent-data-l event))) (list-tabulate 5 (lambda (i) ((foreign-lambda* long (((c-pointer long) data) (int i)) "C_return(data[i]);") data i))))) ;;; ;;; 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)))) (define (set-wm-protocols xcontext syms) (with-xcontext xcontext (display window) (let* ((atoms (map (lambda (a) (xinternatom display (symbol->string a) 1)) syms)) (vec (list->u32vector atoms)) (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) (xsetwmprotocols display window lvec len)))) ;;; ;;; Active Window Title ;;; #> int ignore_errors (Display* d, XErrorEvent* e) { return 0; } <# (define (active-window-title xcontext) (with-xcontext xcontext (display screen root) (let ((property (xinternatom display "_NET_ACTIVE_WINDOW" 0))) (let-location ((xa_ret_type unsigned-long) (ret_format int) (ret_nitems unsigned-long) (ret_bytes_after unsigned-long) (ret_window_id unsigned-c-string*)) (xgetwindowproperty display root property 0 4 0 ANYPROPERTYTYPE (location xa_ret_type) (location ret_format) (location ret_nitems) (location ret_bytes_after) (location ret_window_id)) (if (= NONE xa_ret_type) ;; property did not exist #f (let ((window-id ((foreign-lambda* unsigned-long ((c-pointer data)) "unsigned long** longs = (unsigned long**)data;" "C_return(longs[0][0]);") (location ret_window_id)))) (if (= NONE window-id) #f (let-location ((ret_prop unsigned-c-string*)) ((foreign-lambda* void () "XSetErrorHandler(ignore_errors);")) (let ((result (xfetchname display window-id (location ret_prop)))) (begin0 (if (not (zero? result)) ret_prop #f) ((foreign-lambda* void () "XSetErrorHandler(NULL);")))))))))))) ;;; ;;; 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))))))))) )