Merge changes from emacs-23 branch
[emacs.git] / lisp / mpc.el
blob8feddf8829bf81b072c34861dc956c2c547eb0df
1 ;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8 -*-
3 ;; Copyright (C) 2006-2011 Free Software Foundation, Inc.
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
6 ;; Keywords: multimedia
8 ;; This file is part of GNU Emacs.
10 ;; GNU Emacs is free software: you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation, either version 3 of the License, or
13 ;; (at your option) any later version.
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 ;;; Commentary:
25 ;; This is an Emacs front end to the Music Player Daemon.
27 ;; It mostly provides a browser inspired from Rhythmbox for your music
28 ;; collection and also allows you to play the music you select. The basic
29 ;; interface is somewhat unusual in that it does not focus on the
30 ;; playlist as much as on the browser.
31 ;; I play albums rather than songs and thus don't have much need for
32 ;; playlists, and it shows. Playlist support exists, but is still limited.
34 ;; Bugs:
36 ;; - when reaching end/start of song while ffwd/rewind, it may get wedged,
37 ;; signal an error, ... or when mpc-next/prev is called while ffwd/rewind.
38 ;; - MPD errors are not reported to the user.
40 ;; Todo:
42 ;; - add bindings/buttons/menuentries for the various commands.
43 ;; - mpc-undo
44 ;; - visual feedback for drag'n'drop
45 ;; - display/set `repeat' and `random' state (and maybe also `crossfade').
46 ;; - allow multiple *mpc* sessions in the same Emacs to control different mpds.
47 ;; - look for .folder.png (freedesktop) or folder.jpg (XP) as well.
48 ;; - fetch album covers and lyrics from the web?
49 ;; - improve MPC-Status: better volume control, add a way to show/hide the
50 ;; rest, plus add the buttons currently in the toolbar.
51 ;; - improve mpc-songs-mode's header-line column-headings so they can be
52 ;; dragged to resize.
53 ;; - allow selecting several entries by drag-mouse.
54 ;; - poll less often
55 ;; - use the `idle' command
56 ;; - do the time-ticking locally (and sync every once in a while)
57 ;; - look at the end of play time to make sure we notice the end
58 ;; as soon as possible
59 ;; - better volume widget.
60 ;; - add synthesized tags.
61 ;; e.g. pseudo-artist = artist + composer + performer.
62 ;; e.g. pseudo-performer = performer or artist
63 ;; e.g. rewrite artist "Foo bar & baz" to "Foo bar".
64 ;; e.g. filename regexp -> compilation flag
65 ;; - window/buffer management.
66 ;; - menubar, tooltips, ...
67 ;; - add mpc-describe-song, mpc-describe-album, ...
68 ;; - add import/export commands (especially export to an MP3 player).
69 ;; - add a real notion of album (as opposed to just album-name):
70 ;; if all songs with same album-name have same artist -> it's an album
71 ;; else it's either several albums or a compilation album (or both),
72 ;; in which case we could use heuristics or user provided info:
73 ;; - if the user followed the 1-album = 1-dir idea, then we can group songs
74 ;; by their directory to create albums.
75 ;; - if a `compilation' flag is available, and if <=1 of the songs have it
76 ;; set, then we can group songs by their artist to create albums.
77 ;; - if two songs have the same track-nb and disk-nb, they're not in the
78 ;; same album. So from the set of songs with identical album names, we
79 ;; can get a lower bound on the number of albums involved, and then see
80 ;; which of those may be non-compilations, etc...
81 ;; - use a special directory name for compilations.
82 ;; - ask the web ;-)
84 ;;; Code:
86 ;; Prefixes used in this code:
87 ;; mpc-proc : management of connection (in/out formatting, ...)
88 ;; mpc-status : auto-updated status info
89 ;; mpc-volume : stuff handling the volume widget
90 ;; mpc-cmd : mpdlib abstraction
92 ;; UI-commands : mpc-
93 ;; internal : mpc--
95 (eval-when-compile (require 'cl))
97 (defgroup mpc ()
98 "A Client for the Music Player Daemon."
99 :prefix "mpc-"
100 :group 'multimedia
101 :group 'applications)
103 (defcustom mpc-browser-tags '(Genre Artist|Composer|Performer
104 Album|Playlist)
105 "Tags for which a browser buffer should be created by default."
106 ;; FIXME: provide a list of tags, for completion.
107 :type '(repeat symbol))
109 ;;; Misc utils ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
111 (defun mpc-assq-all (key alist)
112 (let ((res ()) val)
113 (dolist (elem alist)
114 (if (and (eq (car elem) key)
115 (not (member (setq val (cdr elem)) res)))
116 (push val res)))
117 (nreverse res)))
119 (defun mpc-union (&rest lists)
120 (let ((res (nreverse (pop lists))))
121 (dolist (list lists)
122 (let ((seen res)) ;Don't remove duplicates within each list.
123 (dolist (elem list)
124 (unless (member elem seen) (push elem res)))))
125 (nreverse res)))
127 (defun mpc-intersection (l1 l2 &optional selectfun)
128 "Return L1 after removing all elements not found in L2.
129 If SELECTFUN is non-nil, elements aren't compared directly, but instead
130 they are passed through SELECTFUN before comparison."
131 (let ((res ()))
132 (if selectfun (setq l2 (mapcar selectfun l2)))
133 (dolist (elem l1)
134 (when (member (if selectfun (funcall selectfun elem) elem) l2)
135 (push elem res)))
136 (nreverse res)))
138 (defun mpc-event-set-point (event)
139 (condition-case nil (posn-set-point (event-end event))
140 (error (condition-case nil (mouse-set-point event)
141 (error nil)))))
143 (defun mpc-compare-strings (str1 str2 &optional ignore-case)
144 "Compare strings STR1 and STR2.
145 Contrary to `compare-strings', this tries to get numbers sorted
146 numerically rather than lexicographically."
147 (let ((res (compare-strings str1 nil nil str2 nil nil ignore-case)))
148 (if (not (integerp res)) res
149 (let ((index (1- (abs res))))
150 (if (or (>= index (length str1)) (>= index (length str2)))
152 (let ((digit1 (memq (aref str1 index)
153 '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
154 (digit2 (memq (aref str2 index)
155 '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9))))
156 (if digit1
157 (if digit2
158 (let ((num1 (progn (string-match "[0-9]+" str1 index)
159 (match-string 0 str1)))
160 (num2 (progn (string-match "[0-9]+" str2 index)
161 (match-string 0 str2))))
162 (cond
163 ;; Here we presume that leading zeroes are only used
164 ;; for same-length numbers. So we'll incorrectly
165 ;; consider that "000" comes after "01", but I don't
166 ;; think it matters.
167 ((< (length num1) (length num2)) (- (abs res)))
168 ((> (length num1) (length num2)) (abs res))
169 ((< (string-to-number num1) (string-to-number num2))
170 (- (abs res)))
171 (t (abs res))))
172 ;; "1a" comes before "10", but "0" comes before "a".
173 (if (and (not (zerop index))
174 (memq (aref str1 (1- index))
175 '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
176 (abs res)
177 (- (abs res))))
178 (if digit2
179 ;; "1a" comes before "10", but "0" comes before "a".
180 (if (and (not (zerop index))
181 (memq (aref str1 (1- index))
182 '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))
183 (- (abs res))
184 (abs res))
185 res))))))))
187 (defun mpc-string-prefix-p (str1 str2)
188 ;; FIXME: copied from pcvs-util.el.
189 "Tell whether STR1 is a prefix of STR2."
190 (eq t (compare-strings str2 nil (length str1) str1 nil nil)))
192 ;; This can speed up mpc--song-search significantly. The table may grow
193 ;; very large, tho. It's only bounded by the fact that it gets flushed
194 ;; whenever the connection is established; which seems to work OK thanks
195 ;; to the fact that MPD tends to disconnect fairly often, although our
196 ;; constant polling often prevents disconnection.
197 (defvar mpc--find-memoize (make-hash-table :test 'equal)) ;; :weakness t
198 (defvar mpc-tag nil) (make-variable-buffer-local 'mpc-tag)
200 ;;; Support for the actual connection and MPD command execution ;;;;;;;;;;;;
202 (defcustom mpc-host
203 (concat (or (getenv "MPD_HOST") "localhost")
204 (if (getenv "MPD_PORT") (concat ":" (getenv "MPD_PORT"))))
205 "Host (and port) where the Music Player Daemon is running.
206 The format is \"HOST\" or \"HOST:PORT\" where PORT defaults to 6600
207 and HOST defaults to localhost."
208 :type 'string)
210 (defvar mpc-proc nil)
212 (defconst mpc--proc-end-re "^\\(?:OK\\(?: MPD .*\\)?\\|ACK \\(.*\\)\\)\n")
214 (put 'mpc-proc-error 'error-conditions '(mpc-proc-error error))
215 (put 'mpc-proc-error 'error-message "MPD error")
217 (defun mpc--debug (format &rest args)
218 (if (get-buffer "*MPC-debug*")
219 (with-current-buffer "*MPC-debug*"
220 (goto-char (point-max))
221 (insert-before-markers ;So it scrolls.
222 (replace-regexp-in-string "\n" "\n "
223 (apply 'format format args))
224 "\n"))))
226 (defun mpc--proc-filter (proc string)
227 (mpc--debug "Receive \"%s\"" string)
228 (with-current-buffer (process-buffer proc)
229 (if (process-get proc 'ready)
230 (if nil ;; (string-match "\\`\\(OK\n\\)+\\'" string)
231 ;; I haven't figured out yet why I get those extraneous OKs,
232 ;; so I'll just ignore them for now.
234 (delete-process proc)
235 (set-process-buffer proc nil)
236 (pop-to-buffer (clone-buffer))
237 (error "MPD output while idle!?"))
238 (save-excursion
239 (let ((start (or (marker-position (process-mark proc)) (point-min))))
240 (goto-char start)
241 (insert string)
242 (move-marker (process-mark proc) (point))
243 (beginning-of-line)
244 (when (and (< start (point))
245 (re-search-backward mpc--proc-end-re start t))
246 (process-put proc 'ready t)
247 (unless (eq (match-end 0) (point-max))
248 (error "Unexpected trailing text"))
249 (let ((error (match-string 1)))
250 (delete-region (point) (point-max))
251 (let ((callback (process-get proc 'callback)))
252 (process-put proc 'callback nil)
253 (if error (signal 'mpc-proc-error error))
254 (funcall callback)))))))))
256 (defun mpc--proc-connect (host)
257 (mpc--debug "Connecting to %s..." host)
258 (with-current-buffer (get-buffer-create (format " *mpc-%s*" host))
259 ;; (pop-to-buffer (current-buffer))
260 (let (proc)
261 (while (and (setq proc (get-buffer-process (current-buffer)))
262 (progn ;; (debug)
263 (delete-process proc)))))
264 (erase-buffer)
265 (let ((port 6600))
266 (when (string-match ":[^.]+\\'" host)
267 (setq port (substring host (1+ (match-beginning 0))))
268 (setq host (substring host 0 (match-beginning 0)))
269 (unless (string-match "[^[:digit:]]" port)
270 (setq port (string-to-number port))))
271 (let* ((coding-system-for-read 'utf-8-unix)
272 (coding-system-for-write 'utf-8-unix)
273 (proc (open-network-stream "MPC" (current-buffer) host port)))
274 (when (processp mpc-proc)
275 ;; Inherit the properties of the previous connection.
276 (let ((plist (process-plist mpc-proc)))
277 (while plist (process-put proc (pop plist) (pop plist)))))
278 (mpc-proc-buffer proc 'mpd-commands (current-buffer))
279 (process-put proc 'callback 'ignore)
280 (process-put proc 'ready nil)
281 (clrhash mpc--find-memoize)
282 (set-process-filter proc 'mpc--proc-filter)
283 (set-process-sentinel proc 'ignore)
284 (set-process-query-on-exit-flag proc nil)
285 ;; This may be called within a process filter ;-(
286 (with-local-quit (mpc-proc-sync proc))
287 proc))))
289 (defun mpc--proc-quote-string (s)
290 (if (numberp s) (number-to-string s)
291 (setq s (replace-regexp-in-string "[\"\\]" "\\\\\\&" s))
292 (if (string-match " " s) (concat "\"" s "\"") s)))
294 (defconst mpc--proc-alist-to-alists-starters '(file directory))
296 (defun mpc--proc-alist-to-alists (alist)
297 (assert (or (null alist)
298 (memq (caar alist) mpc--proc-alist-to-alists-starters)))
299 (let ((starter (caar alist))
300 (alists ())
301 tmp)
302 (dolist (pair alist)
303 (when (eq (car pair) starter)
304 (if tmp (push (nreverse tmp) alists))
305 (setq tmp ()))
306 (push pair tmp))
307 (if tmp (push (nreverse tmp) alists))
308 (nreverse alists)))
310 (defun mpc-proc ()
311 (or (and mpc-proc
312 (buffer-live-p (process-buffer mpc-proc))
313 (not (memq (process-status mpc-proc) '(closed)))
314 mpc-proc)
315 (setq mpc-proc (mpc--proc-connect mpc-host))))
317 (defun mpc-proc-sync (&optional proc)
318 "Wait for MPC process until it is idle again.
319 Return the buffer in which the process is/was running."
320 (unless proc (setq proc (mpc-proc)))
321 (unwind-protect
322 (condition-case err
323 (progn
324 (while (and (not (process-get proc 'ready))
325 (accept-process-output proc)))
326 (if (process-get proc 'ready) (process-buffer proc)
327 ;; (delete-process proc)
328 (error "No response from MPD")))
329 (error (message "MPC: %s" err) (signal (car err) (cdr err))))
330 (unless (process-get proc 'ready)
331 ;; (debug)
332 (message "Killing hung process")
333 (delete-process proc))))
335 (defun mpc-proc-cmd (cmd &optional callback)
336 "Send command CMD to the MPD server.
337 If CALLBACK is nil, wait for the command to finish before returning,
338 otherwise return immediately and call CALLBACK with no argument
339 when the command terminates.
340 CMD can be a string which is passed as-is to MPD or a list of strings
341 which will be concatenated with proper quoting before passing them to MPD."
342 (let ((proc (mpc-proc)))
343 (if (and callback (not (process-get proc 'ready)))
344 (lexical-let ((old (process-get proc 'callback))
345 (callback callback)
346 (cmd cmd))
347 (process-put proc 'callback
348 (lambda ()
349 (funcall old)
350 (mpc-proc-cmd cmd callback))))
351 ;; Wait for any pending async command to terminate.
352 (mpc-proc-sync proc)
353 (process-put proc 'ready nil)
354 (with-current-buffer (process-buffer proc)
355 (erase-buffer)
356 (mpc--debug "Send \"%s\"" cmd)
357 (process-send-string
358 proc (concat (if (stringp cmd) cmd
359 (mapconcat 'mpc--proc-quote-string cmd " "))
360 "\n")))
361 (if callback
362 (lexical-let ((buf (current-buffer))
363 (callback callback))
364 (process-put proc 'callback
365 callback
366 ;; (lambda ()
367 ;; (funcall callback
368 ;; (prog1 (current-buffer)
369 ;; (set-buffer buf))))
371 ;; If `callback' is nil, we're executing synchronously.
372 (process-put proc 'callback 'ignore)
373 ;; This returns the process's buffer.
374 (mpc-proc-sync proc)))))
376 ;; This function doesn't exist in Emacs-21.
377 ;; (put 'mpc-proc-cmd-list 'byte-optimizer 'byte-optimize-pure-func)
378 (defun mpc-proc-cmd-list (cmds)
379 (concat "command_list_begin\n"
380 (mapconcat (lambda (cmd)
381 (if (stringp cmd) cmd
382 (mapconcat 'mpc--proc-quote-string cmd " ")))
383 cmds
384 "\n")
385 "\ncommand_list_end"))
387 (defun mpc-proc-cmd-list-ok ()
388 ;; To implement this, we'll need to tweak the process filter since we'd
389 ;; then sometimes get "trailing" text after "OK\n".
390 (error "Not implemented yet"))
392 (defun mpc-proc-buf-to-alist (&optional buf)
393 (with-current-buffer (or buf (current-buffer))
394 (let ((res ()))
395 (goto-char (point-min))
396 (while (re-search-forward "^\\([^:]+\\): \\(.*\\)\n" nil t)
397 (push (cons (intern (match-string 1)) (match-string 2)) res))
398 (nreverse res))))
400 (defun mpc-proc-buf-to-alists (buf)
401 (mpc--proc-alist-to-alists (mpc-proc-buf-to-alist buf)))
403 (defun mpc-proc-cmd-to-alist (cmd &optional callback)
404 (if callback
405 (lexical-let ((buf (current-buffer))
406 (callback callback))
407 (mpc-proc-cmd cmd (lambda ()
408 (funcall callback (prog1 (mpc-proc-buf-to-alist
409 (current-buffer))
410 (set-buffer buf))))))
411 ;; (lexical-let ((res nil))
412 ;; (mpc-proc-cmd-to-alist cmd (lambda (alist) (setq res alist)))
413 ;; (mpc-proc-sync)
414 ;; res)
415 (mpc-proc-buf-to-alist (mpc-proc-cmd cmd))))
417 (defun mpc-proc-tag-string-to-sym (tag)
418 (intern (capitalize tag)))
420 (defun mpc-proc-buffer (proc use &optional buffer)
421 (let* ((bufs (process-get proc 'buffers))
422 (buf (cdr (assoc use bufs))))
423 (cond
424 ((and buffer (buffer-live-p buf) (not (eq buffer buf)))
425 (error "Duplicate MPC buffer for %s" use))
426 (buffer
427 (if buf
428 (setcdr (assoc use bufs) buffer)
429 (process-put proc 'buffers (cons (cons use buffer) bufs))))
430 (t buf))))
432 ;;; Support for regularly updated current status information ;;;;;;;;;;;;;;;
434 ;; Exported elements:
435 ;; `mpc-status' holds the uptodate data.
436 ;; `mpc-status-callbacks' holds the registered callback functions.
437 ;; `mpc-status-refresh' forces a refresh of the data.
438 ;; `mpc-status-stop' stops the automatic updating.
440 (defvar mpc-status nil)
441 (defvar mpc-status-callbacks
442 '((state . mpc--status-timers-refresh)
443 ;; (song . mpc--queue-refresh)
444 ;; (state . mpc--queue-refresh) ;To detect the end of the last song.
445 (state . mpc--faster-toggle-refresh) ;Only ffwd/rewind while play/pause.
446 (volume . mpc-volume-refresh)
447 (file . mpc-songpointer-refresh)
448 ;; The song pointer may need updating even if the file doesn't change,
449 ;; if the same song appears multiple times in a row.
450 (song . mpc-songpointer-refresh)
451 (updating_db . mpc-updated-db)
452 (updating_db . mpc--status-timers-refresh)
453 (t . mpc-current-refresh))
454 "Alist associating properties to the functions that care about them.
455 Each entry has the form (PROP . FUN) where PROP can be t to mean
456 to call FUN for any change whatsoever.")
458 (defun mpc--status-callback ()
459 (let ((old-status mpc-status))
460 ;; Update the alist.
461 (setq mpc-status (mpc-proc-buf-to-alist))
462 (assert mpc-status)
463 (unless (equal old-status mpc-status)
464 ;; Run the relevant refresher functions.
465 (dolist (pair mpc-status-callbacks)
466 (when (or (eq t (car pair))
467 (not (equal (cdr (assq (car pair) old-status))
468 (cdr (assq (car pair) mpc-status)))))
469 (funcall (cdr pair)))))))
471 (defvar mpc--status-timer nil)
472 (defun mpc--status-timer-start ()
473 (add-hook 'pre-command-hook 'mpc--status-timer-stop)
474 (unless mpc--status-timer
475 (setq mpc--status-timer (run-with-timer 1 1 'mpc--status-timer-run))))
476 (defun mpc--status-timer-stop ()
477 (when mpc--status-timer
478 (cancel-timer mpc--status-timer)
479 (setq mpc--status-timer nil)))
480 (defun mpc--status-timer-run ()
481 (when (process-get (mpc-proc) 'ready)
482 (condition-case err
483 (with-local-quit (mpc-status-refresh))
484 (error (message "MPC: %s" err)))))
486 (defvar mpc--status-idle-timer nil)
487 (defun mpc--status-idle-timer-start ()
488 (when mpc--status-idle-timer
489 ;; Turn it off even if we'll start it again, in case it changes the delay.
490 (cancel-timer mpc--status-idle-timer))
491 (setq mpc--status-idle-timer
492 (run-with-idle-timer 1 t 'mpc--status-idle-timer-run))
493 ;; Typically, the idle timer is started from the mpc--status-callback,
494 ;; which is run asynchronously while we're already idle (we typically
495 ;; just started idling), so the timer itself will only be run the next
496 ;; time we idle :-(
497 ;; To work around that, we immediately start the repeat timer.
498 (mpc--status-timer-start))
499 (defun mpc--status-idle-timer-stop (&optional really)
500 (when mpc--status-idle-timer
501 ;; Turn it off even if we'll start it again, in case it changes the delay.
502 (cancel-timer mpc--status-idle-timer))
503 (setq mpc--status-idle-timer
504 (unless really
505 ;; We don't completely stop the timer, so that if some other MPD
506 ;; client starts playback, we may get a chance to notice it.
507 (run-with-idle-timer 10 t 'mpc--status-idle-timer-run))))
508 (defun mpc--status-idle-timer-run ()
509 (when (process-get (mpc-proc) 'ready)
510 (condition-case err
511 (with-local-quit (mpc-status-refresh))
512 (error (message "MPC: %s" err))))
513 (mpc--status-timer-start))
515 (defun mpc--status-timers-refresh ()
516 "Start/stop the timers according to whether a song is playing."
517 (if (or (member (cdr (assq 'state mpc-status)) '("play"))
518 (cdr (assq 'updating_db mpc-status)))
519 (mpc--status-idle-timer-start)
520 (mpc--status-idle-timer-stop)
521 (mpc--status-timer-stop)))
523 (defun mpc-status-refresh (&optional callback)
524 "Refresh `mpc-status'."
525 (lexical-let ((cb callback))
526 (mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong"))
527 (lambda ()
528 (mpc--status-callback)
529 (if cb (funcall cb))))))
531 (defun mpc-status-stop ()
532 "Stop the autorefresh of `mpc-status'.
533 This is normally used only when quitting MPC.
534 Any call to `mpc-status-refresh' may cause it to be restarted."
535 (setq mpc-status nil)
536 (mpc--status-idle-timer-stop 'really)
537 (mpc--status-timer-stop))
539 ;;; A thin layer above the raw protocol commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;
541 ;; (defvar mpc-queue nil)
542 ;; (defvar mpc-queue-back nil)
544 ;; (defun mpc--queue-head ()
545 ;; (if (stringp (car mpc-queue)) (car mpc-queue) (cadar mpc-queue)))
546 ;; (defun mpc--queue-pop ()
547 ;; (when mpc-queue ;Can be nil if out of sync.
548 ;; (let ((song (car mpc-queue)))
549 ;; (assert song)
550 ;; (push (if (and (consp song) (cddr song))
551 ;; ;; The queue's first element is itself a list of
552 ;; ;; songs, where the first element isn't itself a song
553 ;; ;; but a description of the list.
554 ;; (prog1 (cadr song) (setcdr song (cddr song)))
555 ;; (prog1 (if (consp song) (cadr song) song)
556 ;; (setq mpc-queue (cdr mpc-queue))))
557 ;; mpc-queue-back)
558 ;; (assert (stringp (car mpc-queue-back))))))
560 ;; (defun mpc--queue-refresh ()
561 ;; ;; Maintain the queue.
562 ;; (mpc--debug "mpc--queue-refresh")
563 ;; (let ((pos (cdr (or (assq 'Pos mpc-status) (assq 'song mpc-status)))))
564 ;; (cond
565 ;; ((null pos)
566 ;; (mpc-cmd-clear 'ignore))
567 ;; ((or (not (member pos '("0" nil)))
568 ;; ;; There's only one song in the playlist and we've stopped.
569 ;; ;; Maybe it's because of some external client that set the
570 ;; ;; playlist like that and/or manually stopped the playback, but
571 ;; ;; it's more likely that we've simply reached the end of
572 ;; ;; the song. So remove it.
573 ;; (and (equal (assq 'state mpc-status) "stop")
574 ;; (equal (assq 'playlistlength mpc-status) "1")
575 ;; (setq pos "1")))
576 ;; ;; We're not playing the first song in the queue/playlist any
577 ;; ;; more, so update the queue.
578 ;; (dotimes (i (string-to-number pos)) (mpc--queue-pop))
579 ;; (mpc-proc-cmd (mpc-proc-cmd-list
580 ;; (make-list (string-to-number pos) "delete 0"))
581 ;; 'ignore)
582 ;; (if (not (equal (cdr (assq 'file mpc-status))
583 ;; (mpc--queue-head)))
584 ;; (message "MPC's queue is out of sync"))))))
586 (defvar mpc--find-memoize-union-tags nil)
588 (defun mpc-cmd-flush (tag value)
589 (puthash (cons tag value) nil mpc--find-memoize)
590 (dolist (uniontag mpc--find-memoize-union-tags)
591 (if (member (symbol-name tag) (split-string (symbol-name uniontag) "|"))
592 (puthash (cons uniontag value) nil mpc--find-memoize))))
595 (defun mpc-cmd-special-tag-p (tag)
596 (or (memq tag '(Playlist Search Directory))
597 (string-match "|" (symbol-name tag))))
599 (defun mpc-cmd-find (tag value)
600 "Return a list of all songs whose tag TAG has value VALUE.
601 The songs are returned as alists."
602 (or (gethash (cons tag value) mpc--find-memoize)
603 (puthash (cons tag value)
604 (cond
605 ((eq tag 'Playlist)
606 ;; Special case for pseudo-tag playlist.
607 (let ((l (condition-case err
608 (mpc-proc-buf-to-alists
609 (mpc-proc-cmd (list "listplaylistinfo" value)))
610 (mpc-proc-error
611 ;; "[50@0] {listplaylistinfo} No such playlist"
612 nil)))
613 (i 0))
614 (mapcar (lambda (s)
615 (prog1 (cons (cons 'Pos (number-to-string i)) s)
616 (incf i)))
617 l)))
618 ((eq tag 'Search)
619 (mpc-proc-buf-to-alists
620 (mpc-proc-cmd (list "search" "any" value))))
621 ((eq tag 'Directory)
622 (let ((pairs
623 (mpc-proc-buf-to-alist
624 (mpc-proc-cmd (list "listallinfo" value)))))
625 (mpc--proc-alist-to-alists
626 ;; Strip away the `directory' entries.
627 (delq nil (mapcar (lambda (pair)
628 (if (eq (car pair) 'directory)
629 nil pair))
630 pairs)))))
631 ((string-match "|" (symbol-name tag))
632 (add-to-list 'mpc--find-memoize-union-tags tag)
633 (let ((tag1 (intern (substring (symbol-name tag)
634 0 (match-beginning 0))))
635 (tag2 (intern (substring (symbol-name tag)
636 (match-end 0)))))
637 (mpc-union (mpc-cmd-find tag1 value)
638 (mpc-cmd-find tag2 value))))
640 (condition-case err
641 (mpc-proc-buf-to-alists
642 (mpc-proc-cmd (list "find" (symbol-name tag) value)))
643 (mpc-proc-error
644 ;; If `tag' is not one of the expected tags, MPD burps
645 ;; about not having the relevant table. FIXME: check
646 ;; the kind of error.
647 (error "Unknown tag %s" tag)
648 (let ((res ()))
649 (setq value (cons tag value))
650 (dolist (song (mpc-proc-buf-to-alists
651 (mpc-proc-cmd "listallinfo")))
652 (if (member value song) (push song res)))
653 res)))))
654 mpc--find-memoize)))
656 (defun mpc-cmd-list (tag &optional other-tag value)
657 ;; FIXME: we could also provide a `mpc-cmd-list' alternative which
658 ;; doesn't take an "other-tag value" constraint but a "song-list" instead.
659 ;; That might be more efficient in some cases.
660 (cond
661 ((eq tag 'Playlist)
662 (let ((pls (mpc-assq-all 'playlist (mpc-proc-cmd-to-alist "lsinfo"))))
663 (when other-tag
664 (dolist (pl (prog1 pls (setq pls nil)))
665 (let ((plsongs (mpc-cmd-find 'Playlist pl)))
666 (if (not (mpc-cmd-special-tag-p other-tag))
667 (when (member (cons other-tag value)
668 (apply 'append plsongs))
669 (push pl pls))
670 ;; Problem N°2: we compute the intersection whereas all
671 ;; we care about is whether it's empty. So we could
672 ;; speed this up significantly.
673 ;; We only compare file names, because the full song-entries
674 ;; are slightly different (the ones in plsongs include
675 ;; position and id info specific to the playlist), and it's
676 ;; good enough because this is only used with "search", which
677 ;; doesn't pay attention to playlists and URLs anyway.
678 (let* ((osongs (mpc-cmd-find other-tag value))
679 (ofiles (mpc-assq-all 'file (apply 'append osongs)))
680 (plfiles (mpc-assq-all 'file (apply 'append plsongs))))
681 (when (mpc-intersection plfiles ofiles)
682 (push pl pls)))))))
683 pls))
685 ((eq tag 'Directory)
686 (if (null other-tag)
687 (apply 'nconc
688 (mpc-assq-all 'directory
689 (mpc-proc-buf-to-alist
690 (mpc-proc-cmd "lsinfo")))
691 (mapcar (lambda (dir)
692 (let ((shortdir
693 (if (get-text-property 0 'display dir)
694 (concat " "
695 (get-text-property 0 'display dir))
696 " ↪ "))
697 (subdirs
698 (mpc-assq-all 'directory
699 (mpc-proc-buf-to-alist
700 (mpc-proc-cmd (list "lsinfo" dir))))))
701 (dolist (subdir subdirs)
702 (put-text-property 0 (1+ (length dir))
703 'display shortdir
704 subdir))
705 subdirs))
706 (process-get (mpc-proc) 'Directory)))
707 ;; If there's an other-tag, then just extract the dir info from the
708 ;; list of other-tag's songs.
709 (let* ((other-songs (mpc-cmd-find other-tag value))
710 (files (mpc-assq-all 'file (apply 'append other-songs)))
711 (dirs '()))
712 (dolist (file files)
713 (let ((dir (file-name-directory file)))
714 (if (and dir (setq dir (directory-file-name dir))
715 (not (equal dir (car dirs))))
716 (push dir dirs))))
717 ;; Dirs might have duplicates still.
718 (setq dirs (delete-dups dirs))
719 (let ((newdirs dirs))
720 (while newdirs
721 (let ((dir (file-name-directory (pop newdirs))))
722 (when (and dir (setq dir (directory-file-name dir))
723 (not (member dir dirs)))
724 (push dir newdirs)
725 (push dir dirs)))))
726 dirs)))
728 ;; The UI should not provide access to such a thing anyway currently.
729 ;; But I could imagine adding in the future a browser for the "search"
730 ;; tag, which would provide things like previous searches. Not sure how
731 ;; useful that would be tho.
732 ((eq tag 'Search) (error "Not supported"))
734 ((string-match "|" (symbol-name tag))
735 (let ((tag1 (intern (substring (symbol-name tag)
736 0 (match-beginning 0))))
737 (tag2 (intern (substring (symbol-name tag)
738 (match-end 0)))))
739 (mpc-union (mpc-cmd-list tag1 other-tag value)
740 (mpc-cmd-list tag2 other-tag value))))
742 ((null other-tag)
743 (condition-case nil
744 (mapcar 'cdr (mpc-proc-cmd-to-alist (list "list" (symbol-name tag))))
745 (mpc-proc-error
746 ;; If `tag' is not one of the expected tags, MPD burps about not
747 ;; having the relevant table.
748 ;; FIXME: check the kind of error.
749 (error "MPD does not know this tag %s" tag)
750 (mpc-assq-all tag (mpc-proc-cmd-to-alist "listallinfo")))))
752 (condition-case nil
753 (if (mpc-cmd-special-tag-p other-tag)
754 (signal 'mpc-proc-error "Not implemented")
755 (mapcar 'cdr
756 (mpc-proc-cmd-to-alist
757 (list "list" (symbol-name tag)
758 (symbol-name other-tag) value))))
759 (mpc-proc-error
760 ;; DAMN!! the 3-arg form of `list' is new in 0.12 !!
761 ;; FIXME: check the kind of error.
762 (let ((other-songs (mpc-cmd-find other-tag value)))
763 (mpc-assq-all tag
764 ;; Don't use `nconc' now that mpc-cmd-find may
765 ;; return a memoized result.
766 (apply 'append other-songs))))))))
768 (defun mpc-cmd-stop (&optional callback)
769 (mpc-proc-cmd "stop" callback))
771 (defun mpc-cmd-clear (&optional callback)
772 (mpc-proc-cmd "clear" callback)
773 ;; (setq mpc-queue-back nil mpc-queue nil)
776 (defun mpc-cmd-pause (&optional arg callback)
777 "Pause or resume playback of the queue of songs."
778 (lexical-let ((cb callback))
779 (mpc-proc-cmd (list "pause" arg)
780 (lambda () (mpc-status-refresh) (if cb (funcall cb))))
781 (unless callback (mpc-proc-sync))))
783 (defun mpc-cmd-status ()
784 (mpc-proc-cmd-to-alist "status"))
786 (defun mpc-cmd-play ()
787 (mpc-proc-cmd "play")
788 (mpc-status-refresh))
790 (defun mpc-cmd-add (files &optional playlist)
791 "Add the songs FILES to PLAYLIST.
792 If PLAYLIST is t or nil or missing, use the main playlist."
793 (mpc-proc-cmd (mpc-proc-cmd-list
794 (mapcar (lambda (file)
795 (if (stringp playlist)
796 (list "playlistadd" playlist file)
797 (list "add" file)))
798 files)))
799 (if (stringp playlist)
800 (mpc-cmd-flush 'Playlist playlist)))
802 (defun mpc-cmd-delete (song-poss &optional playlist)
803 "Delete the songs at positions SONG-POSS from PLAYLIST.
804 If PLAYLIST is t or nil or missing, use the main playlist."
805 (mpc-proc-cmd (mpc-proc-cmd-list
806 (mapcar (lambda (song-pos)
807 (if (stringp playlist)
808 (list "playlistdelete" playlist song-pos)
809 (list "delete" song-pos)))
810 ;; Sort them from last to first, so the renumbering
811 ;; caused by the earlier deletions don't affect
812 ;; later ones.
813 (sort song-poss '>))))
814 (if (stringp playlist)
815 (puthash (cons 'Playlist playlist) nil mpc--find-memoize)))
818 (defun mpc-cmd-move (song-poss dest-pos &optional playlist)
819 (let ((i 0))
820 (mpc-proc-cmd
821 (mpc-proc-cmd-list
822 (mapcar (lambda (song-pos)
823 (if (>= song-pos dest-pos)
824 ;; positions past dest-pos have been
825 ;; shifted by i.
826 (setq song-pos (+ song-pos i)))
827 (prog1 (if (stringp playlist)
828 (list "playlistmove" playlist song-pos dest-pos)
829 (list "move" song-pos dest-pos))
830 (if (< song-pos dest-pos)
831 ;; This move has shifted dest-pos by 1.
832 (decf dest-pos))
833 (incf i)))
834 ;; Sort them from last to first, so the renumbering
835 ;; caused by the earlier deletions affect
836 ;; later ones a bit less.
837 (sort song-poss '>))))
838 (if (stringp playlist)
839 (puthash (cons 'Playlist playlist) nil mpc--find-memoize))))
841 (defun mpc-cmd-update (&optional arg callback)
842 (lexical-let ((cb callback))
843 (mpc-proc-cmd (if arg (list "update" arg) "update")
844 (lambda () (mpc-status-refresh) (if cb (funcall cb))))
845 (unless callback (mpc-proc-sync))))
847 (defun mpc-cmd-tagtypes ()
848 (mapcar 'cdr (mpc-proc-cmd-to-alist "tagtypes")))
850 ;; This was never integrated into MPD.
851 ;; (defun mpc-cmd-download (file)
852 ;; (with-current-buffer (generate-new-buffer " *mpc download*")
853 ;; (set-buffer-multibyte nil)
854 ;; (let* ((proc (mpc-proc))
855 ;; (stdbuf (process-buffer proc))
856 ;; (markpos (marker-position (process-mark proc)))
857 ;; (stdcoding (process-coding-system proc)))
858 ;; (unwind-protect
859 ;; (progn
860 ;; (set-process-buffer proc (current-buffer))
861 ;; (set-process-coding-system proc 'binary (cdr stdcoding))
862 ;; (set-marker (process-mark proc) (point))
863 ;; (mpc-proc-cmd (list "download" file)))
864 ;; (set-process-buffer proc stdbuf)
865 ;; (set-marker (process-mark proc) markpos stdbuf)
866 ;; (set-process-coding-system proc (car stdcoding) (cdr stdcoding)))
867 ;; ;; The command has completed, let's decode.
868 ;; (goto-char (point-max))
869 ;; (delete-char -1) ;Delete final newline.
870 ;; (while (re-search-backward "^>" nil t)
871 ;; (delete-char 1))
872 ;; (current-buffer))))
874 ;;; Misc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
876 (defcustom mpc-mpd-music-directory nil
877 "Location of MPD's music directory."
878 :type '(choice (const nil) directory))
880 (defcustom mpc-data-directory
881 (if (and (not (file-directory-p "~/.mpc"))
882 (file-directory-p "~/.emacs.d"))
883 "~/.emacs.d/mpc" "~/.mpc")
884 "Directory where MPC.el stores auxiliary data."
885 :type 'directory)
887 (defun mpc-data-directory ()
888 (unless (file-directory-p mpc-data-directory)
889 (make-directory mpc-data-directory))
890 mpc-data-directory)
892 (defun mpc-file-local-copy (file)
893 ;; Try to set mpc-mpd-music-directory.
894 (when (and (null mpc-mpd-music-directory)
895 (string-match "\\`localhost" mpc-host))
896 (let ((files '("~/.mpdconf" "/etc/mpd.conf"))
897 file)
898 (while (and files (not file))
899 (if (file-exists-p (car files)) (setq file (car files)))
900 (setq files (cdr files)))
901 (with-temp-buffer
902 (ignore-errors (insert-file-contents file))
903 (goto-char (point-min))
904 (if (re-search-forward "^music_directory[ ]+\"\\([^\"]+\\)\"")
905 (setq mpc-mpd-music-directory
906 (match-string 1))))))
907 ;; Use mpc-mpd-music-directory if applicable, or else try to use the
908 ;; `download' command, although it's never been accepted in `mpd' :-(
909 (if (and mpc-mpd-music-directory
910 (file-exists-p (expand-file-name file mpc-mpd-music-directory)))
911 (expand-file-name file mpc-mpd-music-directory)
912 ;; (let ((aux (expand-file-name (replace-regexp-in-string "[/]" "|" file)
913 ;; (mpc-data-directory))))
914 ;; (unless (file-exists-p aux)
915 ;; (condition-case err
916 ;; (with-local-quit
917 ;; (with-current-buffer (mpc-cmd-download file)
918 ;; (write-region (point-min) (point-max) aux)
919 ;; (kill-buffer (current-buffer))))
920 ;; (mpc-proc-error (message "Download error: %s" err) (setq aux nil))))
921 ;; aux)
924 ;;; Formatter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
926 (defun mpc-secs-to-time (secs)
927 ;; We could use `format-seconds', but it doesn't seem worth the trouble
928 ;; because we'd still need to check (>= secs (* 60 100)) since the special
929 ;; %z only allows us to drop the large units for small values but
930 ;; not to drop the small units for large values.
931 (if (stringp secs) (setq secs (string-to-number secs)))
932 (if (>= secs (* 60 100)) ;More than 100 minutes.
933 (format "%dh%02d" ;"%d:%02d:%02d"
934 (/ secs 3600) (% (/ secs 60) 60)) ;; (% secs 60)
935 (format "%d:%02d" (/ secs 60) (% secs 60))))
937 (defvar mpc-tempfiles nil)
938 (defconst mpc-tempfiles-reftable (make-hash-table :weakness 'key))
940 (defun mpc-tempfiles-clean ()
941 (let ((live ()))
942 (maphash (lambda (k v) (push v live)) mpc-tempfiles-reftable)
943 (dolist (f mpc-tempfiles)
944 (unless (member f live) (ignore-errors (delete-file f))))
945 (setq mpc-tempfiles live)))
947 (defun mpc-tempfiles-add (key file)
948 (mpc-tempfiles-clean)
949 (puthash key file mpc-tempfiles-reftable)
950 (push file mpc-tempfiles))
952 (defun mpc-format (format-spec info &optional hscroll)
953 "Format the INFO according to FORMAT-SPEC, inserting the result at point."
954 (let* ((pos 0)
955 (start (point))
956 (col (if hscroll (- hscroll) 0))
957 (insert (lambda (str)
958 (cond
959 ((>= col 0) (insert str))
960 (t (insert (substring str (min (length str) (- col))))))))
961 (pred nil))
962 (while (string-match "%\\(?:%\\|\\(-\\)?\\([0-9]+\\)?{\\([[:alpha:]][[:alnum:]]*\\)\\(?:-\\([^}]+\\)\\)?}\\)" format-spec pos)
963 (let ((pre-text (substring format-spec pos (match-beginning 0))))
964 (funcall insert pre-text)
965 (setq col (+ col (string-width pre-text))))
966 (setq pos (match-end 0))
967 (if (null (match-end 3))
968 (progn
969 (funcall insert "%")
970 (setq col (+ col 1)))
971 (let* ((size (match-string 2 format-spec))
972 (tag (intern (match-string 3 format-spec)))
973 (post (match-string 4 format-spec))
974 (right-align (match-end 1))
975 (text
976 (if (eq info 'self) (symbol-name tag)
977 (case tag
978 ((Time Duration)
979 (let ((time (cdr (or (assq 'time info) (assq 'Time info)))))
980 (setq pred (list nil)) ;Just assume it's never eq.
981 (when time
982 (mpc-secs-to-time (if (and (eq tag 'Duration)
983 (string-match ":" time))
984 (substring time (match-end 0))
985 time)))))
986 (Cover
987 (let* ((dir (file-name-directory (cdr (assq 'file info))))
988 (cover (concat dir "cover.jpg"))
989 (file (condition-case err
990 (mpc-file-local-copy cover)
991 (error (message "MPC: %s" err))))
992 image)
993 ;; (debug)
994 (push `(equal ',dir (file-name-directory (cdr (assq 'file info)))) pred)
995 (if (null file)
996 ;; Make sure we return something on which we can
997 ;; place the `mpc-pred' property, as
998 ;; a negative-cache. We could also use
999 ;; a default cover.
1000 (progn (setq size nil) " ")
1001 (if (null size) (setq image (create-image file))
1002 (let ((tempfile (make-temp-file "mpc" nil ".jpg")))
1003 (call-process "convert" nil nil nil
1004 "-scale" size file tempfile)
1005 (setq image (create-image tempfile))
1006 (mpc-tempfiles-add image tempfile)))
1007 (setq size nil)
1008 (propertize dir 'display image))))
1009 (t (let ((val (cdr (assq tag info))))
1010 ;; For Streaming URLs, there's no other info
1011 ;; than the URL in `file'. Pretend it's in `Title'.
1012 (when (and (null val) (eq tag 'Title))
1013 (setq val (cdr (assq 'file info))))
1014 (push `(equal ',val (cdr (assq ',tag info))) pred)
1015 val)))))
1016 (space (when size
1017 (setq size (string-to-number size))
1018 (propertize " " 'display
1019 (list 'space :align-to (+ col size)))))
1020 (textwidth (if text (string-width text) 0))
1021 (postwidth (if post (string-width post) 0)))
1022 (when text
1023 (let ((display
1024 (if (and size
1025 (> (+ postwidth textwidth) size))
1026 ;; This doesn't even obey double-width chars :-(
1027 (propertize
1028 (if (zerop (- size postwidth 1))
1029 (substring text 0 1)
1030 (concat (substring text 0 (- size postwidth textwidth 1)) "…"))
1031 'help-echo text)
1032 text)))
1033 (when (memq tag '(Artist Album Composer)) ;FIXME: wrong list.
1034 (setq display
1035 (propertize display
1036 'mouse-face 'highlight
1037 'follow-link t
1038 'keymap `(keymap
1039 (mouse-2
1040 . (lambda ()
1041 (interactive)
1042 (mpc-constraints-push 'noerror)
1043 (mpc-constraints-restore
1044 ',(list (list tag text)))))))))
1045 (funcall insert
1046 (concat (when size
1047 (propertize " " 'display
1048 (list 'space :align-to
1049 (+ col
1050 (if (and size right-align)
1051 (- size postwidth textwidth)
1052 0)))))
1053 display post))))
1054 (if (null size) (setq col (+ col textwidth postwidth))
1055 (insert space)
1056 (setq col (+ col size))))))
1057 (put-text-property start (point) 'mpc-pred
1058 `(lambda (info) (and ,@(nreverse pred))))))
1060 ;;; The actual UI code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1062 (defvar mpc-mode-map
1063 (let ((map (make-keymap)))
1064 (suppress-keymap map)
1065 ;; (define-key map "\e" 'mpc-stop)
1066 (define-key map "q" 'mpc-quit)
1067 (define-key map "\r" 'mpc-select)
1068 (define-key map [(shift return)] 'mpc-select-toggle)
1069 (define-key map [mouse-2] 'mpc-select)
1070 (define-key map [S-mouse-2] 'mpc-select-extend)
1071 (define-key map [C-mouse-2] 'mpc-select-toggle)
1072 (define-key map [drag-mouse-2] 'mpc-drag-n-drop)
1073 ;; We use `always' because a binding to t is like a binding to nil.
1074 (define-key map [follow-link] 'always)
1075 ;; Doesn't work because the first click changes the buffer, so the second
1076 ;; is applied elsewhere :-(
1077 ;; (define-key map [(double mouse-2)] 'mpc-play-at-point)
1078 (define-key map "p" 'mpc-pause)
1079 map))
1081 (easy-menu-define mpc-mode-menu mpc-mode-map
1082 "Menu for MPC.el."
1083 '("MPC.el"
1084 ["Add new browser" mpc-tagbrowser]
1085 ["Update DB" mpc-update]
1086 ["Quit" mpc-quit]))
1088 (defvar mpc-tool-bar-map
1089 (let ((map (make-sparse-keymap)))
1090 (tool-bar-local-item "mpc/prev" 'mpc-prev 'prev map
1091 :enable '(not (equal (cdr (assq 'state mpc-status)) "stop")))
1092 ;; FIXME: how can we bind it to the down-event?
1093 (tool-bar-local-item "mpc/rewind" 'mpc-rewind 'rewind map
1094 :enable '(not (equal (cdr (assq 'state mpc-status)) "stop"))
1095 :button '(:toggle . (and mpc--faster-toggle-timer
1096 (not mpc--faster-toggle-forward))))
1097 ;; We could use a single toggle command for pause/play, with 2 different
1098 ;; icons depending on whether or not it's selected, but then it'd have
1099 ;; to be a toggle-button, thus displayed depressed in one of the
1100 ;; two states :-(
1101 (tool-bar-local-item "mpc/pause" 'mpc-pause 'pause map
1102 :visible '(equal (cdr (assq 'state mpc-status)) "play")
1103 :help "Pause/play")
1104 (tool-bar-local-item "mpc/play" 'mpc-play 'play map
1105 :visible '(not (equal (cdr (assq 'state mpc-status)) "play"))
1106 :help "Play/pause")
1107 ;; FIXME: how can we bind it to the down-event?
1108 (tool-bar-local-item "mpc/ffwd" 'mpc-ffwd 'ffwd map
1109 :enable '(not (equal (cdr (assq 'state mpc-status)) "stop"))
1110 :button '(:toggle . (and mpc--faster-toggle-timer
1111 mpc--faster-toggle-forward)))
1112 (tool-bar-local-item "mpc/next" 'mpc-next 'next map
1113 :enable '(not (equal (cdr (assq 'state mpc-status)) "stop")))
1114 (tool-bar-local-item "mpc/stop" 'mpc-stop 'stop map)
1115 (tool-bar-local-item "mpc/add" 'mpc-playlist-add 'add map
1116 :help "Append to the playlist")
1117 map))
1119 (define-derived-mode mpc-mode fundamental-mode "MPC"
1120 "Major mode for the features common to all buffers of MPC."
1121 (buffer-disable-undo)
1122 (setq buffer-read-only t)
1123 (set (make-local-variable 'tool-bar-map) mpc-tool-bar-map)
1124 (set (make-local-variable 'truncate-lines) t))
1126 ;;; The mpc-status-mode buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1128 (define-derived-mode mpc-status-mode mpc-mode "MPC-Status"
1129 "Major mode to display MPC status info."
1130 (set (make-local-variable 'mode-line-format)
1131 '("%e" mode-line-frame-identification mode-line-buffer-identification))
1132 (set (make-local-variable 'window-area-factor) 3)
1133 (set (make-local-variable 'header-line-format) '("MPC " mpc-volume)))
1135 (defvar mpc-status-buffer-format
1136 '("%-5{Time} / %{Duration} %2{Disc--}%4{Track}" "%{Title}" "%{Album}" "%{Artist}" "%128{Cover}"))
1138 (defun mpc-status-buffer-refresh ()
1139 (let ((buf (mpc-proc-buffer (mpc-proc) 'status)))
1140 (when (buffer-live-p buf)
1141 (with-current-buffer buf
1142 (save-excursion
1143 (goto-char (point-min))
1144 (when (assq 'file mpc-status)
1145 (let ((inhibit-read-only t))
1146 (dolist (spec mpc-status-buffer-format)
1147 (let ((pred (get-text-property (point) 'mpc-pred)))
1148 (if (and pred (funcall pred mpc-status))
1149 (forward-line)
1150 (delete-region (point) (line-beginning-position 2))
1151 (ignore-errors (mpc-format spec mpc-status))
1152 (insert "\n"))))
1153 (unless (eobp) (delete-region (point) (point-max))))))))))
1155 (defun mpc-status-buffer-show ()
1156 (interactive)
1157 (let* ((buf (mpc-proc-buffer (mpc-proc) 'status))
1158 (songs-buf (mpc-proc-buffer (mpc-proc) 'songs))
1159 (songs-win (if songs-buf (get-buffer-window songs-buf 0))))
1160 (unless (buffer-live-p buf)
1161 (setq buf (get-buffer-create "*MPC-Status*"))
1162 (with-current-buffer buf
1163 (mpc-status-mode))
1164 (mpc-proc-buffer (mpc-proc) 'status buf))
1165 (if (null songs-win) (pop-to-buffer buf)
1166 (let ((win (split-window songs-win 20 t)))
1167 (set-window-dedicated-p songs-win nil)
1168 (set-window-buffer songs-win buf)
1169 (set-window-dedicated-p songs-win 'soft)))))
1171 ;;; Selection management;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1173 (defvar mpc-separator-ol nil)
1175 (defvar mpc-select nil)
1176 (make-variable-buffer-local 'mpc-select)
1178 (defmacro mpc-select-save (&rest body)
1179 "Execute BODY and restore the selection afterwards."
1180 (declare (indent 0) (debug t))
1181 `(let ((selection (mpc-select-get-selection))
1182 (position (cons (buffer-substring-no-properties
1183 (line-beginning-position) (line-end-position))
1184 (current-column))))
1185 ,@body
1186 (mpc-select-restore selection)
1187 (goto-char (point-min))
1188 (if (re-search-forward
1189 (concat "^" (regexp-quote (car position)) "$")
1190 (if (overlayp mpc-separator-ol)
1191 (overlay-end mpc-separator-ol))
1193 (move-to-column (cdr position)))
1194 (let ((win (get-buffer-window (current-buffer) 0)))
1195 (if win (set-window-point win (point))))))
1197 (defun mpc-select-get-selection ()
1198 (mapcar (lambda (ol)
1199 (buffer-substring-no-properties
1200 (overlay-start ol) (1- (overlay-end ol))))
1201 mpc-select))
1203 (defun mpc-select-restore (selection)
1204 ;; Restore the selection. I.e. move the overlays back to their
1205 ;; corresponding location. Actually which overlay is used for what
1206 ;; doesn't matter.
1207 (mapc 'delete-overlay mpc-select)
1208 (setq mpc-select nil)
1209 (dolist (elem selection)
1210 ;; After an update, some elements may have disappeared.
1211 (goto-char (point-min))
1212 (when (re-search-forward
1213 (concat "^" (regexp-quote elem) "$") nil t)
1214 (mpc-select-make-overlay)))
1215 (when mpc-tag (mpc-tagbrowser-all-select))
1216 (beginning-of-line))
1218 (defun mpc-select-make-overlay ()
1219 (assert (not (get-char-property (point) 'mpc-select)))
1220 (let ((ol (make-overlay
1221 (line-beginning-position) (line-beginning-position 2))))
1222 (overlay-put ol 'mpc-select t)
1223 (overlay-put ol 'face 'region)
1224 (overlay-put ol 'evaporate t)
1225 (push ol mpc-select)))
1227 (defun mpc-select (&optional event)
1228 "Select the tag value at point."
1229 (interactive (list last-nonmenu-event))
1230 (mpc-event-set-point event)
1231 (if (and (bolp) (eobp)) (forward-line -1))
1232 (mapc 'delete-overlay mpc-select)
1233 (setq mpc-select nil)
1234 (if (mpc-tagbrowser-all-p)
1236 (mpc-select-make-overlay))
1237 (when mpc-tag
1238 (mpc-tagbrowser-all-select)
1239 (mpc-selection-refresh)))
1241 (defun mpc-select-toggle (&optional event)
1242 "Toggle the selection of the tag value at point."
1243 (interactive (list last-nonmenu-event))
1244 (mpc-event-set-point event)
1245 (save-excursion
1246 (cond
1247 ;; The line is already selected: deselect it.
1248 ((get-char-property (point) 'mpc-select)
1249 (let ((ols nil))
1250 (dolist (ol mpc-select)
1251 (if (and (<= (overlay-start ol) (point))
1252 (> (overlay-end ol) (point)))
1253 (delete-overlay ol)
1254 (push ol ols)))
1255 (assert (= (1+ (length ols)) (length mpc-select)))
1256 (setq mpc-select ols)))
1257 ;; We're trying to select *ALL* additionally to others.
1258 ((mpc-tagbrowser-all-p) nil)
1259 ;; Select the current line.
1260 (t (mpc-select-make-overlay))))
1261 (when mpc-tag
1262 (mpc-tagbrowser-all-select)
1263 (mpc-selection-refresh)))
1265 (defun mpc-select-extend (&optional event)
1266 "Extend the selection up to point."
1267 (interactive (list last-nonmenu-event))
1268 (mpc-event-set-point event)
1269 (if (null mpc-select)
1270 ;; If nothing's selected yet, fallback to selecting the elem at point.
1271 (mpc-select event)
1272 (save-excursion
1273 (cond
1274 ;; The line is already in a selected area; truncate the area.
1275 ((get-char-property (point) 'mpc-select)
1276 (let ((before 0)
1277 (after 0)
1278 (mid (line-beginning-position))
1279 start end)
1280 (while (and (zerop (forward-line 1))
1281 (get-char-property (point) 'mpc-select))
1282 (setq end (1+ (point)))
1283 (incf after))
1284 (goto-char mid)
1285 (while (and (zerop (forward-line -1))
1286 (get-char-property (point) 'mpc-select))
1287 (setq start (point))
1288 (incf before))
1289 (if (and (= after 0) (= before 0))
1290 ;; Shortening an already minimum-size region: do nothing.
1292 (if (> after before)
1293 (setq end mid)
1294 (setq start (1+ mid)))
1295 (let ((ols '()))
1296 (dolist (ol mpc-select)
1297 (if (and (>= (overlay-start ol) start)
1298 (< (overlay-start ol) end))
1299 (delete-overlay ol)
1300 (push ol ols)))
1301 (setq mpc-select (nreverse ols))))))
1302 ;; Extending a prior area. Look for the closest selection.
1304 (when (mpc-tagbrowser-all-p)
1305 (forward-line 1))
1306 (let ((before 0)
1307 (count 0)
1308 (dir 1)
1309 (start (line-beginning-position)))
1310 (while (and (zerop (forward-line 1))
1311 (not (get-char-property (point) 'mpc-select)))
1312 (incf count))
1313 (unless (get-char-property (point) 'mpc-select)
1314 (setq count nil))
1315 (goto-char start)
1316 (while (and (zerop (forward-line -1))
1317 (not (get-char-property (point) 'mpc-select)))
1318 (incf before))
1319 (unless (get-char-property (point) 'mpc-select)
1320 (setq before nil))
1321 (when (and before (or (null count) (< before count)))
1322 (setq count before)
1323 (setq dir -1))
1324 (goto-char start)
1325 (dotimes (i (1+ (or count 0)))
1326 (mpc-select-make-overlay)
1327 (forward-line dir))))))
1328 (when mpc-tag
1329 (mpc-tagbrowser-all-select)
1330 (mpc-selection-refresh))))
1332 ;;; Constraint sets ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1334 (defvar mpc--song-search nil)
1336 (defun mpc-constraints-get-current (&optional avoid-buf)
1337 "Return currently selected set of constraints.
1338 If AVOID-BUF is non-nil, it specifies a buffer which should be ignored
1339 when constructing the set of constraints."
1340 (let ((constraints (if mpc--song-search `((Search ,mpc--song-search))))
1341 tag select)
1342 (dolist (buf (process-get (mpc-proc) 'buffers))
1343 (setq buf (cdr buf))
1344 (when (and (setq tag (buffer-local-value 'mpc-tag buf))
1345 (not (eq buf avoid-buf))
1346 (setq select
1347 (with-current-buffer buf (mpc-select-get-selection))))
1348 (push (cons tag select) constraints)))
1349 constraints))
1351 (defun mpc-constraints-restore (constraints)
1352 (let ((search (assq 'Search constraints)))
1353 (setq mpc--song-search (cadr search))
1354 (when search (setq constraints (delq search constraints))))
1355 (dolist (buf (process-get (mpc-proc) 'buffers))
1356 (setq buf (cdr buf))
1357 (when (buffer-live-p buf)
1358 (let* ((tag (buffer-local-value 'mpc-tag buf))
1359 (constraint (assq tag constraints)))
1360 (when tag
1361 (with-current-buffer buf
1362 (mpc-select-restore (cdr constraint)))))))
1363 (mpc-selection-refresh))
1365 ;; I don't get the ring.el code. I think it doesn't do what I need, but
1366 ;; then I don't understand when what it does would be useful.
1367 (defun mpc-ring-make (size) (cons 0 (cons 0 (make-vector size nil))))
1368 (defun mpc-ring-push (ring val)
1369 (aset (cddr ring) (car ring) val)
1370 (setcar (cdr ring) (max (cadr ring) (1+ (car ring))))
1371 (setcar ring (mod (1+ (car ring)) (length (cddr ring)))))
1372 (defun mpc-ring-pop (ring)
1373 (setcar ring (mod (1- (car ring)) (cadr ring)))
1374 (aref (cddr ring) (car ring)))
1376 (defvar mpc-constraints-ring (mpc-ring-make 10))
1378 (defun mpc-constraints-push (&optional noerror)
1379 "Push the current selection on the ring for later."
1380 (interactive)
1381 (let ((constraints (mpc-constraints-get-current)))
1382 (if (null constraints)
1383 (unless noerror (error "No selection to push"))
1384 (mpc-ring-push mpc-constraints-ring constraints))))
1386 (defun mpc-constraints-pop ()
1387 "Recall the most recently pushed selection."
1388 (interactive)
1389 (let ((constraints (mpc-ring-pop mpc-constraints-ring)))
1390 (if (null constraints)
1391 (error "No selection to return to")
1392 (mpc-constraints-restore constraints))))
1394 ;;; The TagBrowser mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1396 (defconst mpc-tagbrowser-all-name (propertize "*ALL*" 'face 'italic))
1397 (defvar mpc-tagbrowser-all-ol nil)
1398 (make-variable-buffer-local 'mpc-tagbrowser-all-ol)
1399 (defvar mpc-tag-name nil) (make-variable-buffer-local 'mpc-tag-name)
1400 (defun mpc-tagbrowser-all-p ()
1401 (and (eq (point-min) (line-beginning-position))
1402 (equal mpc-tagbrowser-all-name
1403 (buffer-substring (point-min) (line-end-position)))))
1405 (define-derived-mode mpc-tagbrowser-mode mpc-mode '("MPC-" mpc-tag-name)
1406 (set (make-local-variable 'mode-line-process) '("" mpc-tag-name))
1407 (set (make-local-variable 'mode-line-format) nil)
1408 (set (make-local-variable 'header-line-format) '("" mpc-tag-name ;; "s"
1410 (set (make-local-variable 'buffer-undo-list) t)
1413 (defun mpc-tagbrowser-refresh ()
1414 (mpc-select-save
1415 (widen)
1416 (goto-char (point-min))
1417 (assert (looking-at (regexp-quote mpc-tagbrowser-all-name)))
1418 (forward-line 1)
1419 (let ((inhibit-read-only t))
1420 (delete-region (point) (point-max))
1421 (dolist (val (mpc-cmd-list mpc-tag)) (insert val "\n")))
1422 (set-buffer-modified-p nil))
1423 (mpc-reorder))
1425 (defun mpc-updated-db ()
1426 ;; FIXME: This is not asynchronous, but is run from a process filter.
1427 (unless (assq 'updating_db mpc-status)
1428 (clrhash mpc--find-memoize)
1429 (dolist (buf (process-get (mpc-proc) 'buffers))
1430 (setq buf (cdr buf))
1431 (when (buffer-local-value 'mpc-tag buf)
1432 (with-current-buffer buf (with-local-quit (mpc-tagbrowser-refresh)))))
1433 (with-local-quit (mpc-songs-refresh))))
1435 (defun mpc-tagbrowser-tag-name (tag)
1436 (cond
1437 ((string-match "|" (symbol-name tag))
1438 (let ((tag1 (intern (substring (symbol-name tag)
1439 0 (match-beginning 0))))
1440 (tag2 (intern (substring (symbol-name tag)
1441 (match-end 0)))))
1442 (concat (mpc-tagbrowser-tag-name tag1)
1443 " | "
1444 (mpc-tagbrowser-tag-name tag2))))
1445 ((string-match "y\\'" (symbol-name tag))
1446 (concat (substring (symbol-name tag) 0 -1) "ies"))
1447 (t (concat (symbol-name tag) "s"))))
1449 (defun mpc-tagbrowser-buf (tag)
1450 (let ((buf (mpc-proc-buffer (mpc-proc) tag)))
1451 (if (buffer-live-p buf) buf
1452 (setq buf (get-buffer-create (format "*MPC %ss*" tag)))
1453 (mpc-proc-buffer (mpc-proc) tag buf)
1454 (with-current-buffer buf
1455 (let ((inhibit-read-only t))
1456 (erase-buffer)
1457 (if (member tag '(Directory))
1458 (mpc-tagbrowser-dir-mode)
1459 (mpc-tagbrowser-mode))
1460 (insert mpc-tagbrowser-all-name "\n"))
1461 (forward-line -1)
1462 (setq mpc-tag tag)
1463 (setq mpc-tag-name (mpc-tagbrowser-tag-name tag))
1464 (mpc-tagbrowser-all-select)
1465 (mpc-tagbrowser-refresh)
1466 buf))))
1468 (defvar tag-browser-tagtypes
1469 (lazy-completion-table tag-browser-tagtypes
1470 (lambda ()
1471 (append '("Playlist" "Directory")
1472 (mpc-cmd-tagtypes)))))
1474 (defun mpc-tagbrowser (tag)
1475 "Create a new browser for TAG."
1476 (interactive
1477 (list
1478 (let ((completion-ignore-case t))
1479 (intern
1480 (completing-read "Tag: " tag-browser-tagtypes nil 'require-match)))))
1481 (let* ((newbuf (mpc-tagbrowser-buf tag))
1482 (win (get-buffer-window newbuf 0)))
1483 (if win (select-window win)
1484 (if (with-current-buffer (window-buffer (selected-window))
1485 (derived-mode-p 'mpc-tagbrowser-mode))
1486 (setq win (selected-window))
1487 ;; Find a tagbrowser-mode buffer.
1488 (let ((buffers (process-get (mpc-proc) 'buffers))
1489 buffer)
1490 (while
1491 (and buffers
1492 (not (and (buffer-live-p (setq buffer (cdr (pop buffers))))
1493 (with-current-buffer buffer
1494 (derived-mode-p 'mpc-tagbrowser-mode))
1495 (setq win (get-buffer-window buffer 0))))))))
1496 (if (not win)
1497 (pop-to-buffer newbuf)
1498 (setq win (split-window win nil 'horiz))
1499 (set-window-buffer win newbuf)
1500 (set-window-dedicated-p win 'soft)
1501 (select-window win)
1502 (balance-windows-area)))))
1504 (defun mpc-tagbrowser-all-select ()
1505 "Select the special *ALL* entry if no other is selected."
1506 (if mpc-select
1507 (delete-overlay mpc-tagbrowser-all-ol)
1508 (save-excursion
1509 (goto-char (point-min))
1510 (if mpc-tagbrowser-all-ol
1511 (move-overlay mpc-tagbrowser-all-ol
1512 (point) (line-beginning-position 2))
1513 (let ((ol (make-overlay (point) (line-beginning-position 2))))
1514 (overlay-put ol 'face 'region)
1515 (overlay-put ol 'evaporate t)
1516 (set (make-local-variable 'mpc-tagbrowser-all-ol) ol))))))
1518 ;; (defvar mpc-constraints nil)
1519 (defun mpc-separator (active)
1520 ;; Place a separator mark.
1521 (unless mpc-separator-ol
1522 (set (make-local-variable 'mpc-separator-ol)
1523 (make-overlay (point) (point)))
1524 (overlay-put mpc-separator-ol 'after-string
1525 (propertize "\n"
1526 'face '(:height 0.05 :inverse-video t))))
1527 (goto-char (point-min))
1528 (forward-line 1)
1529 (while
1530 (and (member (buffer-substring-no-properties
1531 (line-beginning-position) (line-end-position))
1532 active)
1533 (zerop (forward-line 1))))
1534 (if (or (eobp) (null active))
1535 (delete-overlay mpc-separator-ol)
1536 (move-overlay mpc-separator-ol (1- (point)) (point))))
1538 (defun mpc-sort (active)
1539 ;; Sort the active elements at the front.
1540 (let ((inhibit-read-only t))
1541 (goto-char (point-min))
1542 (if (mpc-tagbrowser-all-p) (forward-line 1))
1543 (condition-case nil
1544 (sort-subr nil 'forward-line 'end-of-line
1545 nil nil
1546 (lambda (s1 s2)
1547 (setq s1 (buffer-substring-no-properties
1548 (car s1) (cdr s1)))
1549 (setq s2 (buffer-substring-no-properties
1550 (car s2) (cdr s2)))
1551 (cond
1552 ((member s1 active)
1553 (if (member s2 active)
1554 (let ((cmp (mpc-compare-strings s1 s2 t)))
1555 (and (numberp cmp) (< cmp 0)))
1557 ((member s2 active) nil)
1558 (t (let ((cmp (mpc-compare-strings s1 s2 t)))
1559 (and (numberp cmp) (< cmp 0)))))))
1560 ;; The comparison predicate arg is new in Emacs-22.
1561 (wrong-number-of-arguments
1562 (sort-subr nil 'forward-line 'end-of-line
1563 (lambda ()
1564 (let ((name (buffer-substring-no-properties
1565 (point) (line-end-position))))
1566 (cond
1567 ((member name active) (concat "1" name))
1568 (t (concat "2" "name"))))))))))
1570 (defvar mpc--changed-selection)
1572 (defun mpc-reorder (&optional nodeactivate)
1573 "Reorder entries based on thre currently active selections.
1574 I.e. split the current browser buffer into a first part containing the
1575 entries included in the selection, then a separator, and then the entries
1576 not included in the selection.
1577 Return non-nil if a selection was deactivated."
1578 (mpc-select-save
1579 (let ((constraints (mpc-constraints-get-current (current-buffer)))
1580 (active 'all))
1581 ;; (unless (equal constraints mpc-constraints)
1582 ;; (set (make-local-variable 'mpc-constraints) constraints)
1583 (dolist (cst constraints)
1584 (let ((vals (apply 'mpc-union
1585 (mapcar (lambda (val)
1586 (mpc-cmd-list mpc-tag (car cst) val))
1587 (cdr cst)))))
1588 (setq active
1589 (if (listp active) (mpc-intersection active vals) vals))))
1591 (when (and (listp active))
1592 ;; Remove the selections if they are all in conflict with
1593 ;; other constraints.
1594 (let ((deactivate t))
1595 (dolist (sel selection)
1596 (when (member sel active) (setq deactivate nil)))
1597 (when deactivate
1598 ;; Variable declared/used by `mpc-select-save'.
1599 (when selection
1600 (setq mpc--changed-selection t))
1601 (unless nodeactivate
1602 (setq selection nil)
1603 (mapc 'delete-overlay mpc-select)
1604 (setq mpc-select nil)
1605 (mpc-tagbrowser-all-select)))))
1607 ;; FIXME: This `mpc-sort' takes a lot of time. Maybe we should
1608 ;; be more clever and presume the buffer is mostly sorted already.
1609 (mpc-sort (if (listp active) active))
1610 (mpc-separator (if (listp active) active)))))
1612 (defun mpc-selection-refresh ()
1613 (let ((mpc--changed-selection t))
1614 (while mpc--changed-selection
1615 (setq mpc--changed-selection nil)
1616 (dolist (buf (process-get (mpc-proc) 'buffers))
1617 (setq buf (cdr buf))
1618 (when (and (buffer-local-value 'mpc-tag buf)
1619 (not (eq buf (current-buffer))))
1620 (with-current-buffer buf (mpc-reorder)))))
1621 ;; FIXME: reorder the current buffer last and prevent deactivation,
1622 ;; since whatever selection we made here is the most recent one
1623 ;; and should hence take precedence.
1624 (when mpc-tag (mpc-reorder 'nodeactivate))
1625 ;; FIXME: comment?
1626 (if (and mpc--song-search mpc--changed-selection)
1627 (progn
1628 (setq mpc--song-search nil)
1629 (mpc-selection-refresh))
1630 (mpc-songs-refresh))))
1632 ;;; Hierarchical tagbrowser ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1633 ;; Todo:
1634 ;; - Add a button on each dir to open/close it (?)
1635 ;; - add the parent dir on the previous line, greyed-out, if it's not
1636 ;; present (because we're in the non-selected part and the parent is
1637 ;; in the selected part).
1639 (defvar mpc-tagbrowser-dir-mode-map
1640 (let ((map (make-sparse-keymap)))
1641 (set-keymap-parent map mpc-tagbrowser-mode-map)
1642 (define-key map [?\M-\C-m] 'mpc-tagbrowser-dir-toggle)
1643 map))
1645 ;; (defvar mpc-tagbrowser-dir-keywords
1646 ;; '(mpc-tagbrowser-dir-hide-prefix))
1648 (define-derived-mode mpc-tagbrowser-dir-mode mpc-tagbrowser-mode '("MPC-" mpc-tag-name)
1649 ;; (set (make-local-variable 'font-lock-defaults)
1650 ;; '(mpc-tagbrowser-dir-keywords t))
1653 ;; (defun mpc-tagbrowser-dir-hide-prefix (limit)
1654 ;; (while
1655 ;; (let ((prev (buffer-substring (line-beginning-position 0)
1656 ;; (line-end-position 0))))
1657 ;; (
1659 (defun mpc-tagbrowser-dir-toggle (event)
1660 "Open or close the element at point."
1661 (interactive (list last-nonmenu-event))
1662 (mpc-event-set-point event)
1663 (let ((name (buffer-substring (line-beginning-position)
1664 (line-end-position)))
1665 (prop (intern mpc-tag)))
1666 (if (not (member name (process-get (mpc-proc) prop)))
1667 (process-put (mpc-proc) prop
1668 (cons name (process-get (mpc-proc) prop)))
1669 (let ((new (delete name (process-get (mpc-proc) prop))))
1670 (setq name (concat name "/"))
1671 (process-put (mpc-proc) prop
1672 (delq nil
1673 (mapcar (lambda (x)
1674 (if (mpc-string-prefix-p name x)
1675 nil x))
1676 new)))))
1677 (mpc-tagbrowser-refresh)))
1680 ;;; Playlist management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1682 (defvar mpc-songs-playlist nil
1683 "Name of the currently selected playlist, if any.
1684 A value of t means the main playlist.")
1685 (make-variable-buffer-local 'mpc-songs-playlist)
1687 (defun mpc-playlist-create (name)
1688 "Save current playlist under name NAME."
1689 (interactive "sPlaylist name: ")
1690 (mpc-proc-cmd (list "save" name))
1691 (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist)))
1692 (when (buffer-live-p buf)
1693 (with-current-buffer buf (mpc-tagbrowser-refresh)))))
1695 (defun mpc-playlist-destroy (name)
1696 "Delete playlist named NAME."
1697 (interactive
1698 (list (completing-read "Delete playlist: " (mpc-cmd-list 'Playlist)
1699 nil 'require-match)))
1700 (mpc-proc-cmd (list "rm" name))
1701 (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist)))
1702 (when (buffer-live-p buf)
1703 (with-current-buffer buf (mpc-tagbrowser-refresh)))))
1705 (defun mpc-playlist-rename (oldname newname)
1706 "Rename playlist OLDNAME to NEWNAME."
1707 (interactive
1708 (let* ((oldname (if (and (eq mpc-tag 'Playlist) (null current-prefix-arg))
1709 (buffer-substring (line-beginning-position)
1710 (line-end-position))
1711 (completing-read "Rename playlist: "
1712 (mpc-cmd-list 'Playlist)
1713 nil 'require-match)))
1714 (newname (read-string (format "Rename '%s' to: " oldname))))
1715 (if (zerop (length newname))
1716 (error "Aborted")
1717 (list oldname newname))))
1718 (mpc-proc-cmd (list "rename" oldname newname))
1719 (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist)))
1720 (if (buffer-live-p buf)
1721 (with-current-buffer buf (mpc-tagbrowser-refresh)))))
1723 (defun mpc-playlist ()
1724 "Show the current playlist."
1725 (interactive)
1726 (mpc-constraints-push 'noerror)
1727 (mpc-constraints-restore '()))
1729 (defun mpc-playlist-add ()
1730 "Add the selection to the playlist."
1731 (interactive)
1732 (let ((songs (mapcar #'car (mpc-songs-selection))))
1733 (mpc-cmd-add songs)
1734 (message "Appended %d songs" (length songs))
1735 ;; Return the songs added. Used in `mpc-play'.
1736 songs))
1738 (defun mpc-playlist-delete ()
1739 "Remove the selected songs from the playlist."
1740 (interactive)
1741 (unless mpc-songs-playlist
1742 (error "The selected songs aren't part of a playlist"))
1743 (let ((song-poss (mapcar #'cdr (mpc-songs-selection))))
1744 (mpc-cmd-delete song-poss mpc-songs-playlist)
1745 (mpc-songs-refresh)
1746 (message "Deleted %d songs" (length song-poss))))
1748 ;;; Volume management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1750 (defvar mpc-volume-map
1751 (let ((map (make-sparse-keymap)))
1752 (define-key map [down-mouse-1] 'mpc-volume-mouse-set)
1753 (define-key map [mouse-1] 'ignore)
1754 (define-key map [header-line down-mouse-1] 'mpc-volume-mouse-set)
1755 (define-key map [header-line mouse-1] 'ignore)
1756 (define-key map [mode-line down-mouse-1] 'mpc-volume-mouse-set)
1757 (define-key map [mode-line mouse-1] 'ignore)
1758 map))
1760 (defvar mpc-volume nil) (put 'mpc-volume 'risky-local-variable t)
1762 (defun mpc-volume-refresh ()
1763 ;; Maintain the volume.
1764 (setq mpc-volume
1765 (mpc-volume-widget
1766 (string-to-number (cdr (assq 'volume mpc-status))))))
1768 (defvar mpc-volume-step 5)
1770 (defun mpc-volume-mouse-set (&optional event)
1771 "Change volume setting."
1772 (interactive (list last-nonmenu-event))
1773 (let* ((posn (event-start event))
1774 (diff
1775 (if (memq (if (stringp (car-safe (posn-object posn)))
1776 (aref (car (posn-object posn)) (cdr (posn-object posn)))
1777 (with-current-buffer (window-buffer (posn-window posn))
1778 (char-after (posn-point posn))))
1779 '(?◁ ?<))
1780 (- mpc-volume-step) mpc-volume-step))
1781 (newvol (+ (string-to-number (cdr (assq 'volume mpc-status))) diff)))
1782 (mpc-proc-cmd (list "setvol" newvol) 'mpc-status-refresh)
1783 (message "Set MPD volume to %s%%" newvol)))
1785 (defun mpc-volume-widget (vol &optional size)
1786 (unless size (setq size 12.5))
1787 (let ((scaledvol (* (/ vol 100.0) size)))
1788 ;; (message "Volume sizes: %s - %s" (/ vol fact) (/ (- 100 vol) fact))
1789 (list (propertize "<" ;; "◁"
1790 ;; 'face 'default
1791 'keymap mpc-volume-map
1792 'face '(:box (:line-width -2 :style pressed-button))
1793 'mouse-face '(:box (:line-width -2 :style released-button)))
1795 (propertize "a"
1796 'display (list 'space :width scaledvol)
1797 'face '(:inverse-video t
1798 :box (:line-width -2 :style released-button)))
1799 (propertize "a"
1800 'display (list 'space :width (- size scaledvol))
1801 'face '(:box (:line-width -2 :style released-button)))
1803 (propertize ">" ;; "▷"
1804 ;; 'face 'default
1805 'keymap mpc-volume-map
1806 'face '(:box (:line-width -2 :style pressed-button))
1807 'mouse-face '(:box (:line-width -2 :style released-button))))))
1809 ;;; MPC songs mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1811 (defvar mpc-current-song nil) (put 'mpc-current-song 'risky-local-variable t)
1812 (defvar mpc-current-updating nil) (put 'mpc-current-updating 'risky-local-variable t)
1813 (defvar mpc-songs-format-description nil) (put 'mpc-songs-format-description 'risky-local-variable t)
1815 (defvar mpc-previous-window-config nil)
1817 (defvar mpc-songs-mode-map
1818 (let ((map (make-sparse-keymap)))
1819 (set-keymap-parent map mpc-mode-map)
1820 (define-key map [remap mpc-select] 'mpc-songs-jump-to)
1821 map))
1823 (defvar mpc-songpointer-set-visible nil)
1825 (defvar mpc-songs-hashcons (make-hash-table :test 'equal :weakness t)
1826 "Make song file name objects unique via hash consing.
1827 This is used so that they can be compared with `eq', which is needed for
1828 `text-property-any'.")
1829 (defun mpc-songs-hashcons (name)
1830 (or (gethash name mpc-songs-hashcons) (puthash name name mpc-songs-hashcons)))
1831 (defcustom mpc-songs-format "%2{Disc--}%3{Track} %-5{Time} %25{Title} %20{Album} %20{Artist} %10{Date}"
1832 "Format used to display each song in the list of songs."
1833 :type 'string)
1835 (defvar mpc-songs-totaltime)
1837 (defun mpc-songs-refresh ()
1838 (let ((buf (mpc-proc-buffer (mpc-proc) 'songs)))
1839 (when (buffer-live-p buf)
1840 (with-current-buffer buf
1841 (let ((constraints (mpc-constraints-get-current (current-buffer)))
1842 (dontsort nil)
1843 (inhibit-read-only t)
1844 (totaltime 0)
1845 (curline (cons (count-lines (point-min)
1846 (line-beginning-position))
1847 (buffer-substring (line-beginning-position)
1848 (line-end-position))))
1849 active)
1850 (setq mpc-songs-playlist nil)
1851 (if (null constraints)
1852 ;; When there are no constraints, rather than show the list of
1853 ;; all songs (which could take a while to download and
1854 ;; format), we show the current playlist.
1855 ;; FIXME: it would be good to be able to show the complete
1856 ;; list, but that would probably require us to format it
1857 ;; on-the-fly to make it bearable.
1858 (setq dontsort t
1859 mpc-songs-playlist t
1860 active (mpc-proc-buf-to-alists
1861 (mpc-proc-cmd "playlistinfo")))
1862 (dolist (cst constraints)
1863 (if (and (eq (car cst) 'Playlist)
1864 (= 1 (length (cdr cst))))
1865 (setq mpc-songs-playlist (cadr cst)))
1866 ;; We don't do anything really special here for playlists,
1867 ;; because it's unclear what's a correct "union" of playlists.
1868 (let ((vals (apply 'mpc-union
1869 (mapcar (lambda (val)
1870 (mpc-cmd-find (car cst) val))
1871 (cdr cst)))))
1872 (setq active (cond
1873 ((null active)
1874 (if (eq (car cst) 'Playlist)
1875 (setq dontsort t))
1876 vals)
1877 ((or dontsort
1878 ;; Try to preserve ordering and
1879 ;; repetitions from playlists.
1880 (not (eq (car cst) 'Playlist)))
1881 (mpc-intersection active vals
1882 (lambda (x) (assq 'file x))))
1884 (setq dontsort t)
1885 (mpc-intersection vals active
1886 (lambda (x)
1887 (assq 'file x)))))))))
1888 (mpc-select-save
1889 (erase-buffer)
1890 ;; Sorting songs is surprisingly difficult: when comparing two
1891 ;; songs with the same album name but different artist name, you
1892 ;; have to know whether these are two different albums (with the
1893 ;; same name) or a single album (typically a compilation).
1894 ;; I punt on it and just use file-name sorting, which does the
1895 ;; right thing if your library is properly arranged.
1896 (dolist (song (if dontsort active
1897 (sort active
1898 (lambda (song1 song2)
1899 (let ((cmp (mpc-compare-strings
1900 (cdr (assq 'file song1))
1901 (cdr (assq 'file song2)))))
1902 (and (integerp cmp) (< cmp 0)))))))
1903 (incf totaltime (string-to-number (or (cdr (assq 'Time song)) "0")))
1904 (mpc-format mpc-songs-format song)
1905 (delete-char (- (skip-chars-backward " "))) ;Remove trailing space.
1906 (insert "\n")
1907 (put-text-property
1908 (line-beginning-position 0) (line-beginning-position)
1909 'mpc-file (mpc-songs-hashcons (cdr (assq 'file song))))
1910 (let ((pos (assq 'Pos song)))
1911 (if pos
1912 (put-text-property
1913 (line-beginning-position 0) (line-beginning-position)
1914 'mpc-file-pos (string-to-number (cdr pos)))))
1916 (goto-char (point-min))
1917 (forward-line (car curline))
1918 (if (or (search-forward (cdr curline) nil t)
1919 (search-backward (cdr curline) nil t))
1920 (beginning-of-line)
1921 (goto-char (point-min)))
1922 (set (make-local-variable 'mpc-songs-totaltime)
1923 (unless (zerop totaltime)
1924 (list " " (mpc-secs-to-time totaltime))))
1925 ))))
1926 (let ((mpc-songpointer-set-visible t))
1927 (mpc-songpointer-refresh)))
1929 (defun mpc-songs-search (string)
1930 "Filter songs to those who include STRING in their metadata."
1931 (interactive "sSearch for: ")
1932 (setq mpc--song-search
1933 (if (zerop (length string)) nil string))
1934 (let ((mpc--changed-selection t))
1935 (while mpc--changed-selection
1936 (setq mpc--changed-selection nil)
1937 (dolist (buf (process-get (mpc-proc) 'buffers))
1938 (setq buf (cdr buf))
1939 (when (buffer-local-value 'mpc-tag buf)
1940 (with-current-buffer buf (mpc-reorder))))
1941 (mpc-songs-refresh))))
1943 (defun mpc-songs-kill-search ()
1944 "Turn off the current search restriction."
1945 (interactive)
1946 (mpc-songs-search nil))
1948 (defun mpc-songs-selection ()
1949 "Return the list of songs currently selected."
1950 (let ((buf (mpc-proc-buffer (mpc-proc) 'songs)))
1951 (when (buffer-live-p buf)
1952 (with-current-buffer buf
1953 (save-excursion
1954 (let ((files ()))
1955 (if mpc-select
1956 (dolist (ol mpc-select)
1957 (push (cons
1958 (get-text-property (overlay-start ol) 'mpc-file)
1959 (get-text-property (overlay-start ol) 'mpc-file-pos))
1960 files))
1961 (goto-char (point-min))
1962 (while (not (eobp))
1963 (push (cons
1964 (get-text-property (point) 'mpc-file)
1965 (get-text-property (point) 'mpc-file-pos))
1966 files)
1967 (forward-line 1)))
1968 (nreverse files)))))))
1970 (defun mpc-songs-jump-to (song-file &optional posn)
1971 "Jump to song SONG-FILE; interactively, this is the song at point."
1972 (interactive
1973 (let* ((event last-nonmenu-event)
1974 (posn (event-end event)))
1975 (with-selected-window (posn-window posn)
1976 (goto-char (posn-point posn))
1977 (list (get-text-property (point) 'mpc-file)
1978 posn))))
1979 (let* ((plbuf (mpc-proc-cmd "playlist"))
1980 (re (concat "^\\([0-9]+\\):" (regexp-quote song-file) "$"))
1981 (sn (with-current-buffer plbuf
1982 (goto-char (point-min))
1983 (when (re-search-forward re nil t)
1984 (match-string 1)))))
1985 (cond
1986 ((null sn) (error "This song is not in the playlist"))
1987 ((null (with-current-buffer plbuf (re-search-forward re nil t)))
1988 ;; song-file only appears once in the playlist: no ambiguity,
1989 ;; we're good to go!
1990 (mpc-proc-cmd (list "play" sn)))
1992 ;; The song appears multiple times in the playlist. If the current
1993 ;; buffer holds not only the destination song but also the current
1994 ;; song, then we will move in the playlist to the same relative
1995 ;; position as in the buffer. Otherwise, we will simply choose the
1996 ;; song occurrence closest to the current song.
1997 (with-selected-window (posn-window posn)
1998 (let* ((cur (and (markerp overlay-arrow-position)
1999 (marker-position overlay-arrow-position)))
2000 (dest (save-excursion
2001 (goto-char (posn-point posn))
2002 (line-beginning-position)))
2003 (lines (when cur (* (if (< cur dest) 1 -1)
2004 (count-lines cur dest)))))
2005 (with-current-buffer plbuf
2006 (goto-char (point-min))
2007 ;; Start the search from the current song.
2008 (forward-line (string-to-number
2009 (or (cdr (assq 'song mpc-status)) "0")))
2010 ;; If the current song is also displayed in the buffer,
2011 ;; then try to move to the same relative position.
2012 (if lines (forward-line lines))
2013 ;; Now search the closest occurrence.
2014 (let* ((next (save-excursion
2015 (when (re-search-forward re nil t)
2016 (cons (point) (match-string 1)))))
2017 (prev (save-excursion
2018 (when (re-search-backward re nil t)
2019 (cons (point) (match-string 1)))))
2020 (sn (cdr (if (and next prev)
2021 (if (< (- (car next) (point))
2022 (- (point) (car prev)))
2023 next prev)
2024 (or next prev)))))
2025 (assert sn)
2026 (mpc-proc-cmd (concat "play " sn))))))))))
2028 (define-derived-mode mpc-songs-mode mpc-mode "MPC-song"
2029 (setq mpc-songs-format-description
2030 (with-temp-buffer (mpc-format mpc-songs-format 'self) (buffer-string)))
2031 (set (make-local-variable 'header-line-format)
2032 ;; '("MPC " mpc-volume " " mpc-current-song)
2033 (list (propertize " " 'display '(space :align-to 0))
2034 ;; 'mpc-songs-format-description
2035 '(:eval
2036 (let ((hscroll (window-hscroll)))
2037 (with-temp-buffer
2038 (mpc-format mpc-songs-format 'self hscroll)
2039 ;; That would be simpler than the hscroll handling in
2040 ;; mpc-format, but currently move-to-column does not
2041 ;; recognize :space display properties.
2042 ;; (move-to-column hscroll)
2043 ;; (delete-region (point-min) (point))
2044 (buffer-string))))))
2045 (set (make-local-variable 'mode-line-format)
2046 '("%e" mode-line-frame-identification mode-line-buffer-identification
2047 #(" " 0 3
2048 (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
2049 mode-line-position
2050 #(" " 0 2
2051 (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
2052 mpc-songs-totaltime
2053 mpc-current-updating
2054 #(" " 0 2
2055 (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
2056 (mpc--song-search
2057 (:propertize
2058 ("Search=\"" mpc--song-search "\"")
2059 help-echo "mouse-2: kill this search"
2060 follow-link t
2061 mouse-face mode-line-highlight
2062 keymap (keymap (mode-line keymap
2063 (mouse-2 . mpc-songs-kill-search))))
2064 (:propertize "NoSearch"
2065 help-echo "mouse-2: set a search restriction"
2066 follow-link t
2067 mouse-face mode-line-highlight
2068 keymap (keymap (mode-line keymap (mouse-2 . mpc-songs-search)))))))
2070 ;; (set (make-local-variable 'mode-line-process)
2071 ;; '("" ;; mpc-volume " "
2072 ;; mpc-songs-totaltime
2073 ;; mpc-current-updating))
2076 (defun mpc-songpointer-set (pos)
2077 (let* ((win (get-buffer-window (current-buffer) t))
2078 (visible (when win
2079 (or mpc-songpointer-set-visible
2080 (and (markerp overlay-arrow-position)
2081 (eq (marker-buffer overlay-arrow-position)
2082 (current-buffer))
2083 (<= (window-start win) overlay-arrow-position)
2084 (< overlay-arrow-position (window-end win)))))))
2085 (unless (local-variable-p 'overlay-arrow-position)
2086 (set (make-local-variable 'overlay-arrow-position) (make-marker)))
2087 (move-marker overlay-arrow-position pos)
2088 ;; If the arrow was visible, try to keep it that way.
2089 (if (and visible pos
2090 (or (> (window-start win) pos) (>= pos (window-end win t))))
2091 (set-window-point win pos))))
2093 (defun mpc-songpointer-refresh ()
2094 (let ((buf (mpc-proc-buffer (mpc-proc) 'songs)))
2095 (when (buffer-live-p buf)
2096 (with-current-buffer buf
2097 (let* ((pos (text-property-any
2098 (point-min) (point-max)
2099 'mpc-file (mpc-songs-hashcons
2100 (cdr (assq 'file mpc-status)))))
2101 (other (when pos
2102 (save-excursion
2103 (goto-char pos)
2104 (text-property-any
2105 (line-beginning-position 2) (point-max)
2106 'mpc-file (mpc-songs-hashcons
2107 (cdr (assq 'file mpc-status))))))))
2108 (if other
2109 ;; The song appears multiple times in the buffer.
2110 ;; We need to be careful to choose the right occurrence.
2111 (mpc-proc-cmd "playlist" 'mpc-songpointer-refresh-hairy)
2112 (mpc-songpointer-set pos)))))))
2114 (defun mpc-songpointer-context (size plbuf)
2115 (with-current-buffer plbuf
2116 (goto-char (point-min))
2117 (forward-line (string-to-number (or (cdr (assq 'song mpc-status)) "0")))
2118 (let ((context-before '())
2119 (context-after '()))
2120 (save-excursion
2121 (dotimes (i size)
2122 (when (re-search-backward "^[0-9]+:\\(.*\\)" nil t)
2123 (push (mpc-songs-hashcons (match-string 1)) context-before))))
2124 ;; Skip the actual current song.
2125 (forward-line 1)
2126 (dotimes (i size)
2127 (when (re-search-forward "^[0-9]+:\\(.*\\)" nil t)
2128 (push (mpc-songs-hashcons (match-string 1)) context-after)))
2129 ;; If there isn't `size' context, then return nil.
2130 (unless (and (< (length context-before) size)
2131 (< (length context-after) size))
2132 (cons (nreverse context-before) (nreverse context-after))))))
2134 (defun mpc-songpointer-score (context pos)
2135 (let ((count 0))
2136 (goto-char pos)
2137 (dolist (song (car context))
2138 (and (zerop (forward-line -1))
2139 (eq (get-text-property (point) 'mpc-file) song)
2140 (incf count)))
2141 (goto-char pos)
2142 (dolist (song (cdr context))
2143 (and (zerop (forward-line 1))
2144 (eq (get-text-property (point) 'mpc-file) song)
2145 (incf count)))
2146 count))
2148 (defun mpc-songpointer-refresh-hairy ()
2149 ;; Based on the complete playlist, we should figure out where in the
2150 ;; song buffer is the currently playing song.
2151 (let ((plbuf (current-buffer))
2152 (buf (mpc-proc-buffer (mpc-proc) 'songs)))
2153 (when (buffer-live-p buf)
2154 (with-current-buffer buf
2155 (let* ((context-size 0)
2156 (context '(() . ()))
2157 (pos (text-property-any
2158 (point-min) (point-max)
2159 'mpc-file (mpc-songs-hashcons
2160 (cdr (assq 'file mpc-status)))))
2161 (score 0)
2162 (other pos))
2163 (while
2164 (setq other
2165 (save-excursion
2166 (goto-char other)
2167 (text-property-any
2168 (line-beginning-position 2) (point-max)
2169 'mpc-file (mpc-songs-hashcons
2170 (cdr (assq 'file mpc-status))))))
2171 ;; There is an `other' contestant.
2172 (let ((other-score (mpc-songpointer-score context other)))
2173 (cond
2174 ;; `other' is worse: try the next one.
2175 ((< other-score score) nil)
2176 ;; `other' is better: remember it and then search further.
2177 ((> other-score score)
2178 (setq pos other)
2179 (setq score other-score))
2180 ;; Both are equal and increasing the context size won't help.
2181 ;; Arbitrarily choose one of the two and keep looking
2182 ;; for a better match.
2183 ((< score context-size) nil)
2185 ;; Score is equal and increasing context might help: try it.
2186 (incf context-size)
2187 (let ((new-context
2188 (mpc-songpointer-context context-size plbuf)))
2189 (if (null new-context)
2190 ;; There isn't more context: choose one arbitrarily
2191 ;; and keep looking for a better match elsewhere.
2192 (decf context-size)
2193 (setq context new-context)
2194 (setq score (mpc-songpointer-score context pos))
2195 (save-excursion
2196 (goto-char other)
2197 ;; Go back one line so we find `other' again.
2198 (setq other (line-beginning-position 0)))))))))
2199 (mpc-songpointer-set pos))))))
2201 (defun mpc-current-refresh ()
2202 ;; Maintain the current data.
2203 (mpc-status-buffer-refresh)
2204 (setq mpc-current-updating
2205 (if (assq 'updating_db mpc-status) " Updating-DB"))
2206 (ignore-errors
2207 (setq mpc-current-song
2208 (when (assq 'file mpc-status)
2209 (concat " "
2210 (mpc-secs-to-time (cdr (assq 'time mpc-status)))
2212 (cdr (assq 'Title mpc-status))
2213 " ("
2214 (cdr (assq 'Artist mpc-status))
2215 " / "
2216 (cdr (assq 'Album mpc-status))
2217 ")"))))
2218 (force-mode-line-update t))
2220 (defun mpc-songs-buf ()
2221 (let ((buf (mpc-proc-buffer (mpc-proc) 'songs)))
2222 (if (buffer-live-p buf) buf
2223 (with-current-buffer (setq buf (get-buffer-create "*MPC-Songs*"))
2224 (mpc-proc-buffer (mpc-proc) 'songs buf)
2225 (mpc-songs-mode)
2226 buf))))
2228 (defun mpc-update ()
2229 "Tell MPD to refresh its database."
2230 (interactive)
2231 (mpc-cmd-update))
2233 (defun mpc-quit ()
2234 "Quit Music Player Daemon."
2235 (interactive)
2236 (let* ((proc mpc-proc)
2237 (bufs (mapcar 'cdr (if proc (process-get proc 'buffers))))
2238 (wins (mapcar (lambda (buf) (get-buffer-window buf 0)) bufs))
2239 (song-buf (mpc-songs-buf))
2240 frames)
2241 ;; Collect all the frames where MPC buffers appear.
2242 (dolist (win wins)
2243 (when (and win (not (memq (window-frame win) frames)))
2244 (push (window-frame win) frames)))
2245 (if (and frames song-buf
2246 (with-current-buffer song-buf mpc-previous-window-config))
2247 (progn
2248 (select-frame (car frames))
2249 (set-window-configuration
2250 (with-current-buffer song-buf mpc-previous-window-config)))
2251 ;; Now delete the ones that show nothing else than MPC buffers.
2252 (dolist (frame frames)
2253 (let ((delete t))
2254 (dolist (win (window-list frame))
2255 (unless (memq (window-buffer win) bufs) (setq delete nil)))
2256 (if delete (ignore-errors (delete-frame frame))))))
2257 ;; Then kill the buffers.
2258 (mapc 'kill-buffer bufs)
2259 (mpc-status-stop)
2260 (if proc (delete-process proc))))
2262 (defun mpc-stop ()
2263 "Stop playing the current queue of songs."
2264 (interactive)
2265 (mpc-cmd-stop)
2266 (mpc-cmd-clear)
2267 (mpc-status-refresh))
2269 (defun mpc-pause ()
2270 "Pause playing."
2271 (interactive)
2272 (mpc-cmd-pause "1"))
2274 (defun mpc-resume ()
2275 "Resume playing."
2276 (interactive)
2277 (mpc-cmd-pause "0"))
2279 (defun mpc-play ()
2280 "Start playing whatever is selected."
2281 (interactive)
2282 (if (member (cdr (assq 'state (mpc-cmd-status))) '("pause"))
2283 (mpc-resume)
2284 ;; When playing the playlist ends, the playlist isn't cleared, but the
2285 ;; user probably doesn't want to re-listen to it before getting to
2286 ;; listen to what he just selected.
2287 ;; (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop"))
2288 ;; (mpc-cmd-clear))
2289 ;; Actually, we don't use mpc-play to append to the playlist any more,
2290 ;; so we can just always empty the playlist.
2291 (mpc-cmd-clear)
2292 (if (mpc-playlist-add)
2293 (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop"))
2294 (mpc-cmd-play))
2295 (error "Don't know what to play"))))
2297 (defun mpc-next ()
2298 "Jump to the next song in the queue."
2299 (interactive)
2300 (mpc-proc-cmd "next")
2301 (mpc-status-refresh))
2303 (defun mpc-prev ()
2304 "Jump to the beginning of the current song, or to the previous song."
2305 (interactive)
2306 (let ((time (cdr (assq 'time mpc-status))))
2307 ;; Here we rely on the fact that string-to-number silently ignores
2308 ;; everything after a non-digit char.
2309 (cond
2310 ;; Go back to the beginning of current song.
2311 ((and time (> (string-to-number time) 0))
2312 (mpc-proc-cmd (list "seekid" (cdr (assq 'songid mpc-status)) 0)))
2313 ;; We're at the beginning of the first song of the playlist.
2314 ;; Fetch the previous one from `mpc-queue-back'.
2315 ;; ((and (zerop (string-to-number (cdr (assq 'song mpc-status))))
2316 ;; mpc-queue-back)
2317 ;; ;; Because we use cmd-list rather than cmd-play, the queue is not
2318 ;; ;; automatically updated.
2319 ;; (let ((prev (pop mpc-queue-back)))
2320 ;; (push prev mpc-queue)
2321 ;; (mpc-proc-cmd
2322 ;; (mpc-proc-cmd-list
2323 ;; (list (list "add" prev)
2324 ;; (list "move" (cdr (assq 'playlistlength mpc-status)) "0")
2325 ;; "previous")))))
2326 ;; We're at the beginning of a song, but not the first one.
2327 (t (mpc-proc-cmd "previous")))
2328 (mpc-status-refresh)))
2330 (defvar mpc-last-seek-time '(0 . 0))
2332 (defun mpc--faster (event speedup step)
2333 "Fast forward."
2334 (interactive (list last-nonmenu-event))
2335 (let ((repeat-delay (/ (abs (float step)) speedup)))
2336 (if (not (memq 'down (event-modifiers event)))
2337 (let* ((currenttime (float-time))
2338 (last-time (- currenttime (car mpc-last-seek-time))))
2339 (if (< last-time (* 0.9 repeat-delay))
2340 nil ;; Trottle
2341 (let* ((status (if (< last-time 1.0)
2342 mpc-status (mpc-cmd-status)))
2343 (songid (cdr (assq 'songid status)))
2344 (time (if songid
2345 (if (< last-time 1.0)
2346 (cdr mpc-last-seek-time)
2347 (string-to-number
2348 (cdr (assq 'time status)))))))
2349 (setq mpc-last-seek-time
2350 (cons currenttime (setq time (+ time step))))
2351 (mpc-proc-cmd (list "seekid" songid time)
2352 'mpc-status-refresh))))
2353 (let ((status (mpc-cmd-status)))
2354 (lexical-let* ((songid (cdr (assq 'songid status)))
2355 (step step)
2356 (time (if songid (string-to-number
2357 (cdr (assq 'time status))))))
2358 (let ((timer (run-with-timer
2359 t repeat-delay
2360 (lambda ()
2361 (mpc-proc-cmd (list "seekid" songid
2362 (setq time (+ time step)))
2363 'mpc-status-refresh)))))
2364 (while (mouse-movement-p
2365 (event-basic-type (setq event (read-event)))))
2366 (cancel-timer timer)))))))
2368 (defvar mpc--faster-toggle-timer nil)
2369 (defun mpc--faster-stop ()
2370 (when mpc--faster-toggle-timer
2371 (cancel-timer mpc--faster-toggle-timer)
2372 (setq mpc--faster-toggle-timer nil)))
2374 (defun mpc--faster-toggle-refresh ()
2375 (if (equal (cdr (assq 'state mpc-status)) "stop")
2376 (mpc--faster-stop)))
2378 (defun mpc--songduration ()
2379 (string-to-number
2380 (let ((s (cdr (assq 'time mpc-status))))
2381 (if (not (string-match ":" s))
2382 (error "Unexpected time format %S" s)
2383 (substring s (match-end 0))))))
2385 (defvar mpc--faster-toggle-forward nil)
2386 (defvar mpc--faster-acceleration 0.5)
2387 (defun mpc--faster-toggle (speedup step)
2388 (setq speedup (float speedup))
2389 (if mpc--faster-toggle-timer
2390 (mpc--faster-stop)
2391 (mpc-status-refresh) (mpc-proc-sync)
2392 (lexical-let* ((speedup speedup)
2393 songid ;The ID of the currently ffwd/rewinding song.
2394 songnb ;The position of that song in the playlist.
2395 songduration ;The duration of that song.
2396 songtime ;The time of the song last time we ran.
2397 oldtime ;The timeoftheday last time we ran.
2398 prevsongid) ;The song we're in the process leaving.
2399 (let ((fun
2400 (lambda ()
2401 (let ((newsongid (cdr (assq 'songid mpc-status)))
2402 (newsongnb (cdr (assq 'song mpc-status))))
2404 (if (and (equal prevsongid newsongid)
2405 (not (equal prevsongid songid)))
2406 ;; We left prevsongid and came back to it. Pretend it
2407 ;; didn't happen.
2408 (setq newsongid songid))
2410 (cond
2411 ((null newsongid) (mpc--faster-stop))
2412 ((not (equal songid newsongid))
2413 ;; We jumped to another song: reset.
2414 (setq songid newsongid)
2415 (setq songtime (string-to-number
2416 (cdr (assq 'time mpc-status))))
2417 (setq songduration (mpc--songduration))
2418 (setq oldtime (float-time)))
2419 ((and (>= songtime songduration) mpc--faster-toggle-forward)
2420 ;; Skip to the beginning of the next song.
2421 (if (not (equal (cdr (assq 'state mpc-status)) "play"))
2422 (mpc-proc-cmd "next" 'mpc-status-refresh)
2423 ;; If we're playing, this is done automatically, so we
2424 ;; don't need to do anything, or rather we *shouldn't*
2425 ;; do anything otherwise there's a race condition where
2426 ;; we could skip straight to the next next song.
2427 nil))
2428 ((and (<= songtime 0) (not mpc--faster-toggle-forward))
2429 ;; Skip to the end of the previous song.
2430 (setq prevsongid songid)
2431 (mpc-proc-cmd "previous"
2432 (lambda ()
2433 (mpc-status-refresh
2434 (lambda ()
2435 (setq songid (cdr (assq 'songid mpc-status)))
2436 (setq songtime (setq songduration (mpc--songduration)))
2437 (setq oldtime (float-time))
2438 (mpc-proc-cmd (list "seekid" songid songtime)))))))
2440 (setq speedup (+ speedup mpc--faster-acceleration))
2441 (let ((newstep
2442 (truncate (* speedup (- (float-time) oldtime)))))
2443 (if (<= newstep 1) (setq newstep 1))
2444 (setq oldtime (+ oldtime (/ newstep speedup)))
2445 (if (not mpc--faster-toggle-forward)
2446 (setq newstep (- newstep)))
2447 (setq songtime (min songduration (+ songtime newstep)))
2448 (unless (>= songtime songduration)
2449 (condition-case nil
2450 (mpc-proc-cmd
2451 (list "seekid" songid songtime)
2452 'mpc-status-refresh)
2453 (mpc-proc-error (mpc-status-refresh)))))))
2454 (setq songnb newsongnb)))))
2455 (setq mpc--faster-toggle-forward (> step 0))
2456 (funcall fun) ;Initialize values.
2457 (setq mpc--faster-toggle-timer
2458 (run-with-timer t 0.3 fun))))))
2462 (defvar mpc-faster-speedup 8)
2464 (defun mpc-ffwd (event)
2465 "Fast forward."
2466 (interactive (list last-nonmenu-event))
2467 ;; (mpc--faster event 4.0 1)
2468 (mpc--faster-toggle mpc-faster-speedup 1))
2470 (defun mpc-rewind (event)
2471 "Fast rewind."
2472 (interactive (list last-nonmenu-event))
2473 ;; (mpc--faster event 4.0 -1)
2474 (mpc--faster-toggle mpc-faster-speedup -1))
2477 (defun mpc-play-at-point (&optional event)
2478 (interactive (list last-nonmenu-event))
2479 (mpc-select event)
2480 (mpc-play))
2482 ;; (defun mpc-play-tagval ()
2483 ;; "Play all the songs of the tag at point."
2484 ;; (interactive)
2485 ;; (let* ((val (buffer-substring (line-beginning-position) (line-end-position)))
2486 ;; (songs (mapcar 'cdar
2487 ;; (mpc-proc-buf-to-alists
2488 ;; (mpc-proc-cmd (list "find" mpc-tag val))))))
2489 ;; (mpc-cmd-add songs)
2490 ;; (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop"))
2491 ;; (mpc-cmd-play))))
2493 ;;; Drag'n'drop support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2494 ;; Todo:
2495 ;; the main thing to do here, is to provide visual feedback during the drag:
2496 ;; - change the mouse-cursor.
2497 ;; - highlight/select the source and the current destination.
2499 (defun mpc-drag-n-drop (event)
2500 "DWIM for a drag EVENT."
2501 (interactive "e")
2502 (let* ((start (event-start event))
2503 (end (event-end event))
2504 (start-buf (window-buffer (posn-window start)))
2505 (end-buf (window-buffer (posn-window end)))
2506 (songs
2507 (with-current-buffer start-buf
2508 (goto-char (posn-point start))
2509 (if (get-text-property (point) 'mpc-select)
2510 ;; FIXME: actually we should only consider the constraints
2511 ;; corresponding to the selection in this particular buffer.
2512 (mpc-songs-selection)
2513 (cond
2514 ((and (derived-mode-p 'mpc-songs-mode)
2515 (get-text-property (point) 'mpc-file))
2516 (list (cons (get-text-property (point) 'mpc-file)
2517 (get-text-property (point) 'mpc-file-pos))))
2518 ((and mpc-tag (not (mpc-tagbrowser-all-p)))
2519 (mapcar (lambda (song)
2520 (list (cdr (assq 'file song))))
2521 (mpc-cmd-find
2522 mpc-tag
2523 (buffer-substring (line-beginning-position)
2524 (line-end-position)))))
2526 (error "Unsupported starting position for drag'n'drop gesture")))))))
2527 (with-current-buffer end-buf
2528 (goto-char (posn-point end))
2529 (cond
2530 ((eq mpc-tag 'Playlist)
2531 ;; Adding elements to a named playlist.
2532 (let ((playlist (if (or (mpc-tagbrowser-all-p)
2533 (and (bolp) (eolp)))
2534 (error "Not a playlist")
2535 (buffer-substring (line-beginning-position)
2536 (line-end-position)))))
2537 (mpc-cmd-add (mapcar 'car songs) playlist)
2538 (message "Added %d songs to %s" (length songs) playlist)
2539 (if (member playlist
2540 (cdr (assq 'Playlist (mpc-constraints-get-current))))
2541 (mpc-songs-refresh))))
2542 ((derived-mode-p 'mpc-songs-mode)
2543 (cond
2544 ((null mpc-songs-playlist)
2545 (error "The songs shown do not belong to a playlist"))
2546 ((eq start-buf end-buf)
2547 ;; Moving songs within the shown playlist.
2548 (let ((dest-pos (get-text-property (point) 'mpc-file-pos)))
2549 (mpc-cmd-move (mapcar 'cdr songs) dest-pos mpc-songs-playlist)
2550 (message "Moved %d songs" (length songs))))
2552 ;; Adding songs to the shown playlist.
2553 (let ((dest-pos (get-text-property (point) 'mpc-file-pos))
2554 (pl (if (stringp mpc-songs-playlist)
2555 (mpc-cmd-find 'Playlist mpc-songs-playlist)
2556 (mpc-proc-cmd-to-alist "playlist"))))
2557 ;; MPD's protocol does not let us add songs at a particular
2558 ;; position in a playlist, so we first have to add them to the
2559 ;; end, and then move them to their final destination.
2560 (mpc-cmd-add (mapcar 'car songs) mpc-songs-playlist)
2561 (mpc-cmd-move (let ((poss '()))
2562 (dotimes (i (length songs))
2563 (push (+ i (length pl)) poss))
2564 (nreverse poss)) dest-pos mpc-songs-playlist)
2565 (message "Added %d songs" (length songs)))))
2566 (mpc-songs-refresh))
2568 (error "Unsupported drag'n'drop gesture"))))))
2570 ;;; Toplevel ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2572 (defcustom mpc-frame-alist '((name . "MPC") (tool-bar-lines . 1)
2573 (font . "Sans"))
2574 "Alist of frame parameters for the MPC frame."
2575 :type 'alist)
2577 ;;;###autoload
2578 (defun mpc ()
2579 "Main entry point for MPC."
2580 (interactive
2581 (progn
2582 (if current-prefix-arg
2583 (setq mpc-host (read-string "MPD host and port: " nil nil mpc-host)))
2584 nil))
2585 (let* ((song-buf (mpc-songs-buf))
2586 (song-win (get-buffer-window song-buf 0)))
2587 (if song-win
2588 (select-window song-win)
2589 (if (or (window-dedicated-p (selected-window))
2590 (window-minibuffer-p))
2591 (ignore-errors (select-frame (make-frame mpc-frame-alist)))
2592 (with-current-buffer song-buf
2593 (set (make-local-variable 'mpc-previous-window-config)
2594 (current-window-configuration))))
2595 (let* ((win1 (selected-window))
2596 (win2 (split-window))
2597 (tags mpc-browser-tags))
2598 (unless tags (error "Need at least one entry in `mpc-browser-tags'"))
2599 (set-window-buffer win2 song-buf)
2600 (set-window-dedicated-p win2 'soft)
2601 (mpc-status-buffer-show)
2602 (while
2603 (progn
2604 (set-window-buffer win1 (mpc-tagbrowser-buf (pop tags)))
2605 (set-window-dedicated-p win1 'soft)
2606 tags)
2607 (setq win1 (split-window win1 nil 'horiz)))))
2608 (balance-windows-area))
2609 (mpc-songs-refresh)
2610 (mpc-status-refresh))
2612 (provide 'mpc)
2614 ;;; mpc.el ends here