source: project/release/3/wmiirc/trunk/wmiirc.scm @ 8633

Last change on this file since 8633 was 8633, checked in by sjamaan, 12 years ago

Add workaround to make wmiirc work in chickens older than 3.0.1

File size: 10.7 KB
Line 
1;;;; wmiirc.scm
2;
3;; A library for writing wmii configuration scripts
4;;
5;; This wmiirc is for wmii 3.6
6;;
7; Copyright (c) 2008, Peter Bex
8; All rights reserved.
9;
10; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
11; conditions are met:
12;
13;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
14;     disclaimer.
15;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
16;     disclaimer in the documentation and/or other materials provided with the distribution.
17;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
18;     products derived from this software without specific prior written permission.
19;
20; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
21; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
22; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
23; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
24; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
25; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
26; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
27; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
28; POSSIBILITY OF SUCH DAMAGE.
29;
30; Please report bugs, suggestions and ideas to the Chicken Trac
31; ticket tracking system (assign tickets to user 'sjamaan'):
32; http://trac.callcc.org
33
34(declare
35 (export wmii:connect wmii:write wmii:read
36         wmii:colrules wmii:colrules-set!
37         wmii:tagrules wmii:tagrules-set!
38         wmii:key-code->string wmii:string->key-code
39         wmii:grabbed-keys wmii:grabbed-keys-set!
40         wmii:event-handlers wmii:event-handlers-set!
41         wmii:client=? wmii:event-loop
42         wmii:color->string wmii:string->color
43         wmii:global-settings wmii:global-settings-set!
44         wmii:tag wmii:tag-settings wmii:tag-settings-set!
45         wmii:change-state wmii:kill wmii:navigate-to wmii:send-to
46         wmii:goto-tag wmii:client-tags wmii:client-tags-set!
47         wmii:tags wmii:clients wmii:write-tab wmii:destroy-tab
48         wmii:tabs wmii:quit wmii:exec))
49
50(use 9p-client)
51
52;; Workaround for Chicken < 3.0.1
53(define (printf . args) (display (apply sprintf args)))
54
55(define *wmii:connection* #f)
56
57(define (camelcased->dasherized str)
58  (list->string
59   (reverse
60    (string-fold
61     (lambda (c l)
62       (if (char-upper-case? c)
63           (if (not (null? l))
64               (cons (char-downcase c) (cons #\- l))
65               (cons (char-downcase c) l))
66           (cons c l))) '() str))))
67
68(define (dasherized->camelcased str . rest)
69  (let-optionals rest ((initial-caps #f))
70    (let ((pieces (string-split str "-")))
71      (if initial-caps
72          (apply string-append (map string-titlecase pieces))
73          (apply string-append (car pieces) (map string-titlecase (cdr pieces)))))))
74
75(define (wmii:connect . rest)
76  (let-optionals rest ((inport #f)
77                       (outport #f))
78   (set! *wmii:connection*
79         (if (and inport outport)
80             (9p:client-connect inport outport)
81             (call-with-values
82                 (lambda ()
83                   (use unix-sockets)
84                   (unix-connect (sprintf "/tmp/ns.~A.~A/wmii"
85                                          (getenv "USER") (getenv "DISPLAY"))))
86               9p:client-connect)))
87   *wmii:connection*))
88
89(define (wmii:read file)
90  (9p:with-input-from-file *wmii:connection* file read-string))
91
92(define (wmii:read-lines file)
93  (9p:with-input-from-file *wmii:connection* file read-lines))
94
95(define (wmii:write file data)
96  (9p:with-output-to-file *wmii:connection* file (lambda () (display data))))
97
98(define (wmii:alist->rules alist)
99  (apply string-append
100   (map
101    (lambda (rule)
102      (sprintf "/~A/ -> ~A\n"
103               (car rule)
104               (if (pair? (cdr rule))
105                   (string-join (map ->string (cdr rule)) "+")
106                   (->string (cdr rule)))))
107    alist)))
108
109(define (wmii:rules->alist rules)
110  (map
111   (lambda (rule)
112     (let ((result (string-match "^/([^/]+)/\\s*->\\s*(.*)$" rule)))
113       (cons (second result) (string-split (third result) "+"))))
114   rules))
115
116(define (wmii:colrules)
117  (map string->number (wmii:rules->alist (wmii:read-lines "/colrules"))))
118
119(define (wmii:colrules-set! rules)
120  (wmii:write "/colrules" (wmii:alist->rules rules)))
121
122(define (wmii:tagrules)
123  (wmii:rules->alist (wmii:read-lines "/tagrules")))
124
125(define (wmii:tagrules-set! rules)
126  (wmii:write "/tagrules" (wmii:alist->rules rules)))
127
128(define (wmii:key-code->string key-code)
129  (string-join key-code "-"))
130
131(define (wmii:string->key-code str)
132  (string-split str "-"))
133
134(define (wmii:grabbed-keys)
135  (map wmii:string->key-code (wmii:read-lines "/keys")))
136
137(define (wmii:grabbed-keys-set! keys)
138  (9p:with-output-to-file *wmii:connection* "/keys"
139    (lambda ()
140      (for-each
141       (lambda (key)
142         (printf "~a\n" (wmii:key-code->string key)))
143       keys))))
144
145(define *wmii:event-handlers* (list))
146
147(define (wmii:event-handlers)
148  *wmii:event-handlers*)
149
150;; Option for not being smart about grabbed keys?
151(define (wmii:event-handlers-set! handlers . rest)
152  (let-optionals rest ((grab-keys #t)) 
153    (if grab-keys
154        (let loop ((handlers handlers)
155                   (keys '()))
156          (if (null? handlers)
157              (wmii:grabbed-keys-set! keys)
158              (match (car handlers)
159                     ((('key . key-code) . _) (loop (cdr handlers) (cons key-code keys)))
160                     (_ (loop (cdr handlers) keys)))))))
161  (set! *wmii:event-handlers* handlers))
162
163(define (wmii:parse-event line)
164  (let* ((parts (string-split line))
165         (type (string->symbol (camelcased->dasherized (car parts)))))
166    (case type
167      ((key)
168       (cons type (wmii:string->key-code (second parts))))
169      ((urgent-tag not-urgent-tag)
170       (list type (third parts) (string=? (second parts) "Client")))
171      ((urgent not-urgent)
172       (list type (second parts) (string=? (third parts) "Client")))
173      ((client-mouse-down client-click)
174       (list type (second parts) (string->number (third parts))))
175      (else
176       (cons type (cdr parts))))))
177
178(define wmii:client=? string=?)
179
180(define (wmii:handle-event event)
181  (let ((handler (alist-ref event
182                            *wmii:event-handlers*
183                            (lambda (template event)
184                              (if (pair? template)
185                                  (equal? template event)
186                                  (eq? template (car event)))))))
187    (if handler
188        (apply handler event))))
189
190(define (wmii:event-loop . rest)
191  (let-optionals rest ((kill-others #t))
192    (if kill-others (wmii:write "/event" "Start wmiirc")) ;; Kill off any running wmiirc
193    (9p:with-input-from-file *wmii:connection* "/event"
194      (lambda ()
195        (let loop ()
196          (let ((event (wmii:parse-event (read-line))))
197            (unless (equal? event '(start "wmiirc")) ;; Otherwise, return
198                    (condition-case (wmii:handle-event event)
199                                    (exn (9p-server-error)
200                                         (fprintf (current-error-port)
201                                                  "Server error: ~A\n"
202                                                  ((condition-property-accessor 'exn 'message) exn))
203                                         (loop)))
204                    (loop))))))))
205
206(define (wmii:color->string color)
207  (string-append "#" (string-pad (number->string color 16) 6 #\0)))
208
209(define (wmii:string->color str)
210  (string->number (string-drop str 1) 16))
211
212(define (wmii:settings->alist settings)
213 (map (lambda (line)
214        (let* ((contents (string-split line))
215               (setting (cons (string->symbol (car contents)) (cdr contents))))
216          (case (car setting)
217            ((focuscolors normcolors)
218             (cons (car setting) (map wmii:string->color (cdr setting))))
219            (else
220             (if (null? (cddr setting))
221                 (cons (car setting) (cadr setting))
222                 setting)))))
223      (if (pair? settings)
224          settings
225          (string-split settings "\n"))))
226
227(define (wmii:alist->settings alist)
228  (string-join
229   (map (lambda (setting)
230          (case (car setting)
231            ((focuscolors normcolors) (sprintf "~A ~A\n" (car setting) (string-join (map wmii:color->string (cdr setting)))))
232            (else (if (pair? (cdr setting))
233                      (sprintf "~A ~A\n" (car setting) (string-join (cdr setting)))
234                      (sprintf "~A ~A\n" (car setting) (cdr setting))))))
235        alist)))
236
237(define (wmii:global-settings)
238  (wmii:settings->alist (wmii:read "/ctl")))
239
240(define (wmii:global-settings-set! alist)
241  (wmii:write "/ctl" (wmii:alist->settings alist)))
242
243(define (wmii:tag . rest)
244  (let-optionals rest ((tag "sel"))
245    (car (wmii:read-lines (sprintf "/tag/~A/ctl" tag)))))
246
247(define (wmii:tag-settings . rest)
248  (let-optionals rest ((tag "sel"))
249    (wmii:settings->alist
250     (cdr (wmii:read-lines (sprintf "/tag/~A/ctl" tag))))))
251
252(define (wmii:tag-settings-set! alist . rest)
253  (let-optionals rest ((tag "sel"))
254    (wmii:write (sprintf "/tag/~A/ctl" tag) (wmii:alist->settings alist))))
255
256(define (wmii:state-transition->string b)
257  (case b
258    ((#t) "on")
259    ((#f) "off")
260    ((toggle) "toggle")
261    (else (error (sprintf "Unknown state transition type ~S" b)))))
262
263(define (wmii:string->state-transition s)
264  (cond
265   ((string=? s "on") #t)
266   ((string=? s "off") #f)
267   ((string=? s "toggle") 'toggle)
268   (else (error (sprintf "Unknown state transition type ~S" s)))))
269
270;; Unfortunately, there's no wmii:client-settings because this information is
271;; not exported by wmii.
272(define (wmii:change-state state value . rest)
273  (let-optionals rest ((client "sel"))
274    (wmii:write (sprintf "/client/~A/ctl" client)
275                (sprintf "~a ~a" state (wmii:state-transition->string value)))))
276
277(define (wmii:kill . rest)
278  (let-optionals rest ((client "sel"))
279    (wmii:write (sprintf "/client/~A/ctl" client) "kill")))
280
281(define (wmii:navigate-to where . rest)
282  (let-optionals rest ((tag "sel"))
283   (wmii:write (sprintf "/tag/~A/ctl" tag) (sprintf "select ~A" where))))
284
285(define (wmii:send-to direction . rest)
286  (let-optionals rest ((client "sel")
287                       (tag "sel"))
288   (wmii:write (sprintf "/tag/~A/ctl" tag)
289               (sprintf "send ~A ~A" client direction))))
290
291(define (wmii:goto-tag tag)
292  (wmii:write "/ctl" (sprintf "view ~A" tag)))
293
294(define (wmii:client-tags . rest)
295  (let-optionals rest ((client "sel"))
296   (string-split (wmii:read (sprintf "/client/~A/tags" client)) "+")))
297
298(define (wmii:client-tags-set! tags . rest)
299  (let-optionals rest ((client "sel"))
300   (wmii:write (sprintf "/client/~A/tags" client) (string-join tags "+"))))
301
302(define (wmii:tags)
303  (delete "sel" (9p:directory *wmii:connection* "/tag")))
304
305(define (wmii:clients)
306  (delete "sel" (9p:directory *wmii:connection* "/client")))
307
308(define (wmii:write-tab bar tab contents . rest)
309  (let-optionals rest ((colors #f))
310   (wmii:write (sprintf "~A/~A" bar tab)
311               (if colors
312                   (sprintf "~A ~A" (string-join (map wmii:color->string colors)) contents)
313                   contents))))
314
315(define (wmii:destroy-tab bar tab)
316  (9p:delete-file *wmii:connection* (sprintf "~A/~A" bar tab)))
317
318(define (wmii:tabs bar)
319  (9p:directory *wmii:connection* bar))
320
321(define (wmii:quit)
322  (wmii:write "/ctl" "quit"))
323
324(define (wmii:exec cmdline)
325  (wmii:write "/ctl" (sprintf "exec ~A" cmdline)))
Note: See TracBrowser for help on using the repository browser.