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

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

Add wmii:directory and wmii:read-lines

File size: 10.8 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:read-lines wmii:directory
37         wmii:colrules wmii:colrules-set!
38         wmii:tagrules wmii:tagrules-set!
39         wmii:key-code->string wmii:string->key-code
40         wmii:grabbed-keys wmii:grabbed-keys-set!
41         wmii:event-handlers wmii:event-handlers-set!
42         wmii:client=? wmii:event-loop
43         wmii:color->string wmii:string->color
44         wmii:global-settings wmii:global-settings-set!
45         wmii:tag wmii:tag-settings wmii:tag-settings-set!
46         wmii:change-state wmii:kill wmii:navigate-to wmii:send-to
47         wmii:goto-tag wmii:client-tags wmii:client-tags-set!
48         wmii:tags wmii:clients wmii:write-tab wmii:destroy-tab
49         wmii:tabs wmii:quit wmii:exec))
50
51(use 9p-client)
52
53;; Workaround for Chicken < 3.0.1
54(define (printf . args) (display (apply sprintf args)))
55
56(define *wmii:connection* #f)
57
58(define (camelcased->dasherized str)
59  (list->string
60   (reverse
61    (string-fold
62     (lambda (c l)
63       (if (char-upper-case? c)
64           (if (not (null? l))
65               (cons (char-downcase c) (cons #\- l))
66               (cons (char-downcase c) l))
67           (cons c l))) '() str))))
68
69(define (dasherized->camelcased str . rest)
70  (let-optionals rest ((initial-caps #f))
71    (let ((pieces (string-split str "-")))
72      (if initial-caps
73          (apply string-append (map string-titlecase pieces))
74          (apply string-append (car pieces) (map string-titlecase (cdr pieces)))))))
75
76(define (wmii:connect . rest)
77  (let-optionals rest ((inport #f)
78                       (outport #f))
79   (set! *wmii:connection*
80         (if (and inport outport)
81             (9p:client-connect inport outport)
82             (call-with-values
83                 (lambda ()
84                   (use unix-sockets)
85                   (unix-connect (sprintf "/tmp/ns.~A.~A/wmii"
86                                          (getenv "USER") (getenv "DISPLAY"))))
87               9p:client-connect)))
88   *wmii:connection*))
89
90(define (wmii:read file)
91  (9p:with-input-from-file *wmii:connection* file read-string))
92
93(define (wmii:read-lines file)
94  (9p:with-input-from-file *wmii:connection* file read-lines))
95
96(define (wmii:write file data)
97  (9p:with-output-to-file *wmii:connection* file (lambda () (display data))))
98
99(define (wmii:directory path)
100  (9p:directory *wmii:connection* path))
101
102(define (wmii:alist->rules alist)
103  (apply string-append
104   (map
105    (lambda (rule)
106      (sprintf "/~A/ -> ~A\n"
107               (car rule)
108               (if (pair? (cdr rule))
109                   (string-join (map ->string (cdr rule)) "+")
110                   (->string (cdr rule)))))
111    alist)))
112
113(define (wmii:rules->alist rules)
114  (reverse
115    (map
116     (lambda (rule)
117       (let ((result (string-match "^/([^/]+)/\\s*->\\s*(.*)$" rule)))
118         (cons (second result) (string-split (third result) "+"))))
119     rules)))
120
121(define (wmii:colrules)
122  (map string->number (wmii:rules->alist (wmii:read-lines "/colrules"))))
123
124(define (wmii:colrules-set! rules)
125  (wmii:write "/colrules" (wmii:alist->rules rules)))
126
127(define (wmii:tagrules)
128  (wmii:rules->alist (wmii:read-lines "/tagrules")))
129
130(define (wmii:tagrules-set! rules)
131  (wmii:write "/tagrules" (wmii:alist->rules rules)))
132
133(define (wmii:key-code->string key-code)
134  (string-join key-code "-"))
135
136(define (wmii:string->key-code str)
137  (string-split str "-"))
138
139(define (wmii:grabbed-keys)
140  (map wmii:string->key-code (wmii:read-lines "/keys")))
141
142(define (wmii:grabbed-keys-set! keys)
143  (9p:with-output-to-file *wmii:connection* "/keys"
144    (lambda ()
145      (for-each
146       (lambda (key)
147         (printf "~a\n" (wmii:key-code->string key)))
148       keys))))
149
150(define *wmii:event-handlers* (list))
151
152(define (wmii:event-handlers)
153  *wmii:event-handlers*)
154
155;; Option for not being smart about grabbed keys?
156(define (wmii:event-handlers-set! handlers . rest)
157  (let-optionals rest ((grab-keys #t)) 
158    (if grab-keys
159        (let loop ((handlers handlers)
160                   (keys '()))
161          (if (null? handlers)
162              (wmii:grabbed-keys-set! keys)
163              (match (car handlers)
164                     ((('key . key-code) . _) (loop (cdr handlers) (cons key-code keys)))
165                     (_ (loop (cdr handlers) keys)))))))
166  (set! *wmii:event-handlers* handlers))
167
168(define (wmii:parse-event line)
169  (let* ((parts (string-split line))
170         (type (string->symbol (camelcased->dasherized (car parts)))))
171    (case type
172      ((key)
173       (cons type (wmii:string->key-code (second parts))))
174      ((urgent-tag not-urgent-tag)
175       (list type (third parts) (string=? (second parts) "Client")))
176      ((urgent not-urgent)
177       (list type (second parts) (string=? (third parts) "Client")))
178      ((client-mouse-down client-click)
179       (list type (second parts) (string->number (third parts))))
180      (else
181       (cons type (cdr parts))))))
182
183(define wmii:client=? string=?)
184
185(define (wmii:handle-event event)
186  (let ((handler (alist-ref event
187                            *wmii:event-handlers*
188                            (lambda (template event)
189                              (if (pair? template)
190                                  (equal? template event)
191                                  (eq? template (car event)))))))
192    (if handler
193        (apply handler event))))
194
195(define (wmii:event-loop . rest)
196  (let-optionals rest ((kill-others #t))
197    (if kill-others (wmii:write "/event" "Start wmiirc")) ;; Kill off any running wmiirc
198    (9p:with-input-from-file *wmii:connection* "/event"
199      (lambda ()
200        (let loop ()
201          (let ((event (wmii:parse-event (read-line))))
202            (unless (equal? event '(start "wmiirc")) ;; Otherwise, return
203                    (condition-case (wmii:handle-event event)
204                                    (exn (9p-server-error)
205                                         (fprintf (current-error-port)
206                                                  "Server error: ~A\n"
207                                                  ((condition-property-accessor 'exn 'message) exn))
208                                         (loop)))
209                    (loop))))))))
210
211(define (wmii:color->string color)
212  (string-append "#" (string-pad (number->string color 16) 6 #\0)))
213
214(define (wmii:string->color str)
215  (string->number (string-drop str 1) 16))
216
217(define (wmii:settings->alist settings)
218 (map (lambda (line)
219        (let* ((contents (string-split line))
220               (setting (cons (string->symbol (car contents)) (cdr contents))))
221          (case (car setting)
222            ((focuscolors normcolors)
223             (cons (car setting) (map wmii:string->color (cdr setting))))
224            (else
225             (if (null? (cddr setting))
226                 (cons (car setting) (cadr setting))
227                 setting)))))
228      (if (pair? settings)
229          settings
230          (string-split settings "\n"))))
231
232(define (wmii:alist->settings alist)
233  (string-join
234   (map (lambda (setting)
235          (case (car setting)
236            ((focuscolors normcolors) (sprintf "~A ~A\n" (car setting) (string-join (map wmii:color->string (cdr setting)))))
237            (else (if (pair? (cdr setting))
238                      (sprintf "~A ~A\n" (car setting) (string-join (cdr setting)))
239                      (sprintf "~A ~A\n" (car setting) (cdr setting))))))
240        alist)))
241
242(define (wmii:global-settings)
243  (wmii:settings->alist (wmii:read "/ctl")))
244
245(define (wmii:global-settings-set! alist)
246  (wmii:write "/ctl" (wmii:alist->settings alist)))
247
248(define (wmii:tag . rest)
249  (let-optionals rest ((tag "sel"))
250    (car (wmii:read-lines (sprintf "/tag/~A/ctl" tag)))))
251
252(define (wmii:tag-settings . rest)
253  (let-optionals rest ((tag "sel"))
254    (wmii:settings->alist
255     (cdr (wmii:read-lines (sprintf "/tag/~A/ctl" tag))))))
256
257(define (wmii:tag-settings-set! alist . rest)
258  (let-optionals rest ((tag "sel"))
259    (wmii:write (sprintf "/tag/~A/ctl" tag) (wmii:alist->settings alist))))
260
261(define (wmii:state-transition->string b)
262  (case b
263    ((#t) "on")
264    ((#f) "off")
265    ((toggle) "toggle")
266    (else (error (sprintf "Unknown state transition type ~S" b)))))
267
268(define (wmii:string->state-transition s)
269  (cond
270   ((string=? s "on") #t)
271   ((string=? s "off") #f)
272   ((string=? s "toggle") 'toggle)
273   (else (error (sprintf "Unknown state transition type ~S" s)))))
274
275;; Unfortunately, there's no wmii:client-settings because this information is
276;; not exported by wmii.
277(define (wmii:change-state state value . rest)
278  (let-optionals rest ((client "sel"))
279    (wmii:write (sprintf "/client/~A/ctl" client)
280                (sprintf "~a ~a" state (wmii:state-transition->string value)))))
281
282(define (wmii:kill . rest)
283  (let-optionals rest ((client "sel"))
284    (wmii:write (sprintf "/client/~A/ctl" client) "kill")))
285
286(define (wmii:navigate-to where . rest)
287  (let-optionals rest ((tag "sel"))
288   (wmii:write (sprintf "/tag/~A/ctl" tag) (sprintf "select ~A" where))))
289
290(define (wmii:send-to direction . rest)
291  (let-optionals rest ((client "sel")
292                       (tag "sel"))
293   (wmii:write (sprintf "/tag/~A/ctl" tag)
294               (sprintf "send ~A ~A" client direction))))
295
296(define (wmii:goto-tag tag)
297  (wmii:write "/ctl" (sprintf "view ~A" tag)))
298
299(define (wmii:client-tags . rest)
300  (let-optionals rest ((client "sel"))
301   (string-split (wmii:read (sprintf "/client/~A/tags" client)) "+")))
302
303(define (wmii:client-tags-set! tags . rest)
304  (let-optionals rest ((client "sel"))
305   (wmii:write (sprintf "/client/~A/tags" client) (string-join tags "+"))))
306
307(define (wmii:tags)
308  (delete "sel" (9p:directory *wmii:connection* "/tag")))
309
310(define (wmii:clients)
311  (delete "sel" (9p:directory *wmii:connection* "/client")))
312
313(define (wmii:write-tab bar tab contents . rest)
314  (let-optionals rest ((colors #f))
315   (wmii:write (sprintf "~A/~A" bar tab)
316               (if colors
317                   (sprintf "~A ~A" (string-join (map wmii:color->string colors)) contents)
318                   contents))))
319
320(define (wmii:destroy-tab bar tab)
321  (9p:delete-file *wmii:connection* (sprintf "~A/~A" bar tab)))
322
323(define (wmii:tabs bar)
324  (wmii:directory bar))
325
326(define (wmii:quit)
327  (wmii:write "/ctl" "quit"))
328
329(define (wmii:exec cmdline)
330  (wmii:write "/ctl" (sprintf "exec ~A" cmdline)))
Note: See TracBrowser for help on using the repository browser.