source: project/release/5/mpd-client/trunk/mpd-client.scm @ 37507

Last change on this file since 37507 was 37507, checked in by wasamasa, 11 months ago

mpd-client: Add C5 port

File size: 9.9 KB
Line 
1;; mpd-client.scm
2;; client library for mpd (http://www.musicpd.org)
3
4(module mpd-client
5  (;; mpd connection
6   mpd-connection?
7   mpd-host mpd-port mpd-password mpd-version
8   connect disconnect ping
9
10   ;; server information and status
11   get-commands get-stats get-status clear-error! shutdown-server!
12   get-output-devices enable-output-device! disable-output-device!
13   set-options!
14
15   ;; query and modify playlist
16   add-song! move-song! remove-song! swap-songs!
17   shuffle-playlist! clear-playlist!
18   load-playlist! save-playlist! remove-playlist!
19   get-current-song get-playlist get-playlist-changes
20   by-position
21   
22   ;; song database
23   find-songs search-songs list-metadata list-directory list-directory/r
24   update-song-database!
25 
26   ;; playback control
27   play! pause! stop! next-song! previous-song!)
28
29  (import scheme)
30  (import scheme)
31  (import (chicken base))
32  (import (chicken condition))
33  (import (chicken io))
34  (import (chicken port))
35  (import (chicken string))
36  (import (chicken tcp))
37  (import (chicken time))
38  (import (only (srfi 1) filter-map))
39  (import (only regex regexp string-search))
40
41 
42  (define-record-type :mpd-conn
43    (make-mpd-conn host port password i o version time)
44    mpd-connection?
45    (host mpd-host)
46    (port mpd-port)
47    (password mpd-password)
48    (i in-port in-port-set!)
49    (o out-port out-port-set!)
50    (version mpd-version mpd-version-set!)
51    (time last-contact-time last-contact-time-set!))
52
53  (define-record-type :by-position
54    (by-position pos)
55    by-position?
56    (pos position))
57 
58  (define (update-time conn)
59    (last-contact-time-set! conn (current-seconds)))
60
61  (define re-ok+version (regexp "^OK MPD (.*)$"))
62  (define re-err (regexp "^ACK ?(.*)$"))
63  (define re-pair (regexp "^([^:]+): (.*)$"))
64
65  (define (raise-mpd-error msg . args)
66    (abort
67     (make-composite-condition
68      (make-property-condition 'exn 'message msg 'arguments args)
69      (make-property-condition 'mpd))))
70
71  (define (connect #!optional (host "localhost") (port 6600) password)
72    (reconnect (make-mpd-conn host port password #f #f #f 0)))
73
74  (define (reconnect conn)
75    (if (in-port conn)
76        (disconnect conn))
77    (receive (i o) (tcp-connect (mpd-host conn) (mpd-port conn))
78      (let ((l (read-line i)))
79        (cond
80         ((eof-object? l)
81          (close-input-port i)
82          (close-output-port o)
83          (raise-mpd-error "connection closed unexpectedly"))
84         ((string-search re-ok+version l)
85          => (lambda (m)
86               (in-port-set! conn i)
87               (out-port-set! conn o)
88               (mpd-version-set! conn (cadr m))
89               (update-time conn)
90               (cond ((mpd-password conn) => (cut cmd conn "password" <>)))
91               conn))
92         (else
93          (close-input-port i)
94          (close-output-port o)
95          (raise-mpd-error "unexpected greeting" l))))))
96
97  (define (disconnect conn)
98    (close-input-port (in-port conn))
99    (close-output-port (out-port conn))
100    (in-port-set! conn #f)
101    (out-port-set! conn #f)
102    (last-contact-time-set! conn 0)
103    (void))
104
105  (define (ping conn)
106    (send-command conn "ping" '())
107    (let ((l (read-line (in-port conn))))
108      (cond
109       ((eof-object? l)
110        (reconnect conn))
111       ((equal? l "OK")
112        (update-time conn))
113       (else
114        (update-time conn)
115        (raise-mpd-error "unexpected line from server" l)))))
116
117  (define (check-connection conn)
118    (let ((i (in-port conn)))
119      (cond
120       ((and (char-ready? i)
121             (eof-object? (peek-char i)))
122        (reconnect conn))
123       ((> (current-seconds)
124           (+ (last-contact-time conn) 30))
125        (ping conn)))))
126
127  (define (get-result conn)
128    (let loop ((l (read-line (in-port conn))) (r '()))
129      (cond
130       ((eof-object? l)
131        (disconnect conn)
132        (raise-mpd-error "connection closed unexpectedly"))
133       ((equal? l "OK")
134        (update-time conn)
135        (reverse r))
136       ((string-search re-err l)
137        => (lambda (m)
138             (update-time conn)
139             (raise-mpd-error "error from server" (cadr m))))
140       ((string-search re-pair l)
141        => (lambda (m)
142             (let ((s (string->symbol (cadr m))))
143               (loop (read-line (in-port conn))
144                     (cons (cons s (convert-type s (caddr m)))
145                           r)))))
146       (else
147        (update-time conn)
148        (raise-mpd-error "unexpected line from server" l)))))
149
150  (define playlist-is-number (make-parameter #f))
151
152  (define (convert-type k v)
153    (case k
154      ((volume playlistlength song songid bitrate xfade
155               Id Pos Time Track
156               artists albums songs uptime playtime db_playtime db_update
157               updating_db outputid cpos)
158       (string->number v))
159      ((playlist)
160       (if (playlist-is-number)
161           (string->number v)
162           v))
163      ((time audio)
164       (map string->number (string-split v ":")))
165      ((repeat random outputenabled)
166       (not (string=? v "0")))
167      ((state)
168       (string->symbol v))
169      (else v)))
170
171  (define (send-command conn cmd args)
172    (display
173     (with-output-to-string
174       (lambda ()
175         (display cmd)
176         (for-each
177          (lambda (arg)
178            (when arg
179              (display " ")
180              (display
181               (cond
182                ((string? arg)
183                 (string-append "\"" (string-translate arg "\"") "\""))
184                (else arg)))))
185          args)
186         (newline)))
187     (out-port conn))
188    (update-time conn))
189
190  (define (cmd conn cmd . args)
191    (check-connection conn)
192    (send-command conn cmd args)
193    (get-result conn))
194
195  (define (result/1-col colname result)
196    (filter-map
197     (lambda (p)
198       (and (eqv? colname (car p)) (cdr p)))
199     result))
200
201  (define (result/1-col* result)
202    (map cdr result))
203
204  (define (result/m-col result)
205    (let loop ((result result) (out '()))
206      (cond
207       ((null? result)
208        (reverse out))
209       ((char-lower-case? (string-ref (symbol->string (caar result)) 0))
210        (loop (cdr result) (cons (list (car result)) out)))
211       (else
212        (loop (cdr result) (cons (cons (car result) (car out)) (cdr out)))))))
213
214  (define (result/m-col* result)
215    (let loop ((result result) (out '()) (first-key #f))
216      (cond
217       ((null? result)
218        (reverse out))
219       ((not first-key)
220        (loop result out (caar result)))
221       ((eq? first-key (caar result))
222        (loop (cdr result) (cons (list (car result)) out) first-key))
223       (else
224        (loop (cdr result) (cons (cons (car result) (car out)) (cdr out))
225              first-key)))))
226
227
228  ;; server information and status
229
230  (define (get-commands c #!optional (allowed #t))
231    (result/1-col 'command (cmd c (if allowed "commands" "notcommands"))))
232  (define (get-stats c) (cmd c "stats"))
233  (define (get-status c)
234    (parameterize ((playlist-is-number #t))
235      (cmd c "status")))
236  (define (clear-error! c) (cmd c "clearerror"))
237  (define (shutdown-server! c) (cmd c "kill"))
238  (define (get-output-devices c) (result/m-col* (cmd c "outputs")))
239  (define (enable-output-device! c id) (cmd c "enableoutput" id))
240  (define (disable-output-device! c id) (cmd c "disableoutput" id))
241  (define (set-options! c . opts)
242    (when (pair? opts)
243      (case (car opts)
244        ((#:crossfade) (cmd c "crossfade" (cadr opts)))
245        ((#:random)    (cmd c "random" (if (cadr opts) 1 0)))
246        ((#:repeat)    (cmd c "repeat" (if (cadr opts) 1 0)))
247        ((#:volume)    (cmd c "setvol" (cadr opts)))
248        (else          (raise-mpd-error "unknown option" (car opts))))
249      (apply set-options! c (cddr opts))))
250
251  ;; query and modify playlist
252
253  (define (add-song! c path) (result/1-col 'Id (cmd c "addid" path)))
254  (define (move-song! c from to)
255    (if (by-position? from)
256        (cmd c "move" (position from) to)
257        (cmd c "moveid" from to)))
258  (define (remove-song! c song)
259    (if (by-position? song)
260        (cmd c "delete" (position song))
261        (cmd c "deleteid" song)))
262  (define (swap-songs! c song1 song2)
263    (cond
264     ((and (by-position? song1) (by-position? song2))
265      (cmd c "swap" (position song1) (position song2)))
266     ((and (integer? song1) (integer? song2))
267      (cmd c "swapid" song1 song2))
268     (else (raise-mpd-error "both songs to be swapped must be specified in the same way"))))
269  (define (shuffle-playlist! c) (cmd c "shuffle"))
270  (define (clear-playlist! c) (cmd c "clear"))
271  (define (load-playlist! c pl) (cmd c "load" pl))
272  (define (save-playlist! c n) (cmd c "save" n))
273  (define (remove-playlist! c n) (cmd c "rm" n))
274  (define (get-current-song c) (cmd c "currentsong"))
275  (define (get-playlist c #!optional song)
276    (result/m-col
277     (if (by-position? song)
278         (cmd c "playlistinfo" (position song))
279         (cmd c "playlistid" song))))
280  (define (get-playlist-changes c version #!optional (full? #t))
281    (result/m-col (cmd c (if full? "plchanges" "plchangesposid") version)))
282
283  ;; song database
284
285  (define (find-songs c type s) (result/m-col (cmd c "find" type s)))
286  (define (search-songs c type s) (result/m-col (cmd c "search" type s)))
287  (define (list-metadata c type #!optional limit s)
288    (result/1-col* (cmd c "list" type limit s)))
289  (define (list-directory c #!optional dir)
290    (result/m-col (cmd c "lsinfo" dir)))
291  (define (list-directory/r c #!optional path (full? #t))
292    (if full?
293        (result/m-col (cmd c "listallinfo" path))
294        (cmd c "listall" path)))
295  (define (update-song-database! c #!optional path)
296    (cmd c "update" path))
297
298  ;; playback control
299
300  (define (play! c #!optional song time)
301    (let ((pos? (by-position? song)))
302      (cmd c (cond ((and pos? time) "seek")
303                   (time "seekid")
304                   (pos? "play")
305                   (else "playid"))
306           (if pos? (position song) song)
307           time)))
308  (define (pause! c pause?) (cmd c "pause" (if pause? 1 0)))
309  (define (stop! c) (cmd c "stop"))
310  (define (next-song! c) (cmd c "next"))
311  (define (previous-song! c) (cmd c "previous"))
312
313)
Note: See TracBrowser for help on using the repository browser.