1 ;;; mpc.el --- A client for the Music Player Daemon -*- lexical-binding: t -*-
3 ;; Copyright (C) 2006-2015 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/>.
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.
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.
42 ;; - add bindings/buttons/menuentries for the various commands.
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 ;; - fetch album covers and lyrics from the web?
48 ;; - improve MPC-Status: better volume control, add a way to show/hide the
49 ;; rest, plus add the buttons currently in the toolbar.
50 ;; - improve mpc-songs-mode's header-line column-headings so they can be
52 ;; - allow selecting several entries by drag-mouse.
54 ;; - use the `idle' command
55 ;; - do the time-ticking locally (and sync every once in a while)
56 ;; - look at the end of play time to make sure we notice the end
57 ;; as soon as possible
58 ;; - better volume widget.
59 ;; - add synthesized tags.
60 ;; e.g. pseudo-artist = artist + composer + performer.
61 ;; e.g. pseudo-performer = performer or artist
62 ;; e.g. rewrite artist "Foo bar & baz" to "Foo bar".
63 ;; e.g. filename regexp -> compilation flag
64 ;; - window/buffer management.
65 ;; - menubar, tooltips, ...
66 ;; - add mpc-describe-song, mpc-describe-album, ...
67 ;; - add import/export commands (especially export to an MP3 player).
68 ;; - add a real notion of album (as opposed to just album-name):
69 ;; if all songs with same album-name have same artist -> it's an album
70 ;; else it's either several albums or a compilation album (or both),
71 ;; in which case we could use heuristics or user provided info:
72 ;; - if the user followed the 1-album = 1-dir idea, then we can group songs
73 ;; by their directory to create albums.
74 ;; - if a `compilation' flag is available, and if <=1 of the songs have it
75 ;; set, then we can group songs by their artist to create albums.
76 ;; - if two songs have the same track-nb and disk-nb, they're not in the
77 ;; same album. So from the set of songs with identical album names, we
78 ;; can get a lower bound on the number of albums involved, and then see
79 ;; which of those may be non-compilations, etc...
80 ;; - use a special directory name for compilations.
85 ;; Prefixes used in this code:
86 ;; mpc-proc : management of connection (in/out formatting, ...)
87 ;; mpc-status : auto-updated status info
88 ;; mpc-volume : stuff handling the volume widget
89 ;; mpc-cmd : mpdlib abstraction
99 "Client for the Music Player Daemon (mpd)."
102 :group
'applications
)
104 (defcustom mpc-browser-tags
'(Genre Artist|Composer|Performer
106 "Tags for which a browser buffer should be created by default."
107 ;; FIXME: provide a list of tags, for completion.
108 :type
'(repeat symbol
))
110 ;;; Misc utils ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
112 (defun mpc-assq-all (key alist
)
115 (if (and (eq (car elem
) key
)
116 (not (member (setq val
(cdr elem
)) res
)))
120 (defun mpc-union (&rest lists
)
121 (let ((res (nreverse (pop lists
))))
123 (let ((seen res
)) ;Don't remove duplicates within each list.
125 (unless (member elem seen
) (push elem res
)))))
128 (defun mpc-intersection (l1 l2
&optional selectfun
)
129 "Return L1 after removing all elements not found in L2.
130 If SELECTFUN is non-nil, elements aren't compared directly, but instead
131 they are passed through SELECTFUN before comparison."
133 (if selectfun
(setq l2
(mapcar selectfun l2
)))
135 (when (member (if selectfun
(funcall selectfun elem
) elem
) l2
)
139 (defun mpc-event-set-point (event)
140 (condition-case nil
(posn-set-point (event-end event
))
141 (error (condition-case nil
(mouse-set-point event
)
144 (defun mpc-compare-strings (str1 str2
&optional ignore-case
)
145 "Compare strings STR1 and STR2.
146 Contrary to `compare-strings', this tries to get numbers sorted
147 numerically rather than lexicographically."
148 (let ((res (compare-strings str1 nil nil str2 nil nil ignore-case
)))
149 (if (not (integerp res
)) res
150 (let ((index (1- (abs res
))))
151 (if (or (>= index
(length str1
)) (>= index
(length str2
)))
153 (let ((digit1 (memq (aref str1 index
)
154 '(?
0 ?
1 ?
2 ?
3 ?
4 ?
5 ?
6 ?
7 ?
8 ?
9)))
155 (digit2 (memq (aref str2 index
)
156 '(?
0 ?
1 ?
2 ?
3 ?
4 ?
5 ?
6 ?
7 ?
8 ?
9))))
159 (let ((num1 (progn (string-match "[0-9]+" str1 index
)
160 (match-string 0 str1
)))
161 (num2 (progn (string-match "[0-9]+" str2 index
)
162 (match-string 0 str2
))))
164 ;; Here we presume that leading zeroes are only used
165 ;; for same-length numbers. So we'll incorrectly
166 ;; consider that "000" comes after "01", but I don't
168 ((< (length num1
) (length num2
)) (- (abs res
)))
169 ((> (length num1
) (length num2
)) (abs res
))
170 ((< (string-to-number num1
) (string-to-number num2
))
173 ;; "1a" comes before "10", but "0" comes before "a".
174 (if (and (not (zerop index
))
175 (memq (aref str1
(1- index
))
176 '(?
0 ?
1 ?
2 ?
3 ?
4 ?
5 ?
6 ?
7 ?
8 ?
9)))
180 ;; "1a" comes before "10", but "0" comes before "a".
181 (if (and (not (zerop index
))
182 (memq (aref str1
(1- index
))
183 '(?
0 ?
1 ?
2 ?
3 ?
4 ?
5 ?
6 ?
7 ?
8 ?
9)))
188 (define-obsolete-function-alias 'mpc-string-prefix-p
'string-prefix-p
"24.3")
190 ;; This can speed up mpc--song-search significantly. The table may grow
191 ;; very large, tho. It's only bounded by the fact that it gets flushed
192 ;; whenever the connection is established; which seems to work OK thanks
193 ;; to the fact that MPD tends to disconnect fairly often, although our
194 ;; constant polling often prevents disconnection.
195 (defvar mpc--find-memoize
(make-hash-table :test
'equal
)) ;; :weakness t
196 (defvar-local mpc-tag nil
)
198 ;;; Support for the actual connection and MPD command execution ;;;;;;;;;;;;
201 (concat (or (getenv "MPD_HOST") "localhost")
202 (if (getenv "MPD_PORT") (concat ":" (getenv "MPD_PORT"))))
203 "Host (and port) where the Music Player Daemon is running. The
204 format is \"HOST\", \"HOST:PORT\", \"PASSWORD@HOST\" or
205 \"PASSWORD@HOST:PORT\" where PASSWORD defaults to no password, PORT
206 defaults to 6600 and HOST defaults to localhost."
209 (defvar mpc-proc nil
)
211 (defconst mpc--proc-end-re
"^\\(?:OK\\(?: MPD .*\\)?\\|ACK \\(.*\\)\\)\n")
213 (define-error 'mpc-proc-error
"MPD error")
215 (defun mpc--debug (format &rest args
)
216 (if (get-buffer "*MPC-debug*")
217 (with-current-buffer "*MPC-debug*"
218 (goto-char (point-max))
219 (insert-before-markers ;So it scrolls.
220 (replace-regexp-in-string "\n" "\n "
221 (apply #'format-message format args
))
224 (defun mpc--proc-filter (proc string
)
225 (mpc--debug "Receive \"%s\"" string
)
226 (with-current-buffer (process-buffer proc
)
227 (if (process-get proc
'ready
)
228 (if nil
;; (string-match "\\`\\(OK\n\\)+\\'" string)
229 ;; I haven't figured out yet why I get those extraneous OKs,
230 ;; so I'll just ignore them for now.
232 (delete-process proc
)
233 (set-process-buffer proc nil
)
234 (pop-to-buffer (clone-buffer))
235 (error "MPD output while idle!?"))
237 (let ((start (or (marker-position (process-mark proc
)) (point-min))))
240 (move-marker (process-mark proc
) (point))
242 (when (and (< start
(point))
243 (re-search-backward mpc--proc-end-re start t
))
244 (process-put proc
'ready t
)
245 (unless (eq (match-end 0) (point-max))
246 (error "Unexpected trailing text"))
247 (let ((error-text (match-string 1)))
248 (delete-region (point) (point-max))
249 (let ((callback (process-get proc
'callback
)))
250 (process-put proc
'callback nil
)
252 (process-put proc
'mpc-proc-error error-text
))
253 (funcall callback
)))))))))
255 (defun mpc--proc-connect (host)
260 (when (string-match "\\`\\(?:\\(.*\\)@\\)?\\(.*?\\)\\(?::\\(.*\\)\\)?\\'"
262 (let ((v (match-string 1 host
)))
263 (when (and (stringp v
) (not (string= "" v
)))
265 (let ((v (match-string 3 host
)))
266 (setq host
(match-string 2 host
))
267 (when (and (stringp v
) (not (string= "" v
)))
269 (if (string-match "[^[:digit:]]" v
)
272 (when (file-name-absolute-p host
)
273 ;; Expand file name because `file-name-absolute-p'
274 ;; considers paths beginning with "~" as absolute
275 (setq host
(expand-file-name host
))
278 (mpc--debug "Connecting to %s:%s..." host port
)
279 (with-current-buffer (get-buffer-create (format " *mpc-%s:%s*" host port
))
280 ;; (pop-to-buffer (current-buffer))
282 (while (and (setq proc
(get-buffer-process (current-buffer)))
284 (delete-process proc
)))))
286 (let* ((coding-system-for-read 'utf-8-unix
)
287 (coding-system-for-write 'utf-8-unix
)
288 (proc (condition-case err
289 (make-network-process :name
"MPC" :buffer
(current-buffer)
290 :host
(unless local host
)
291 :service
(if local host port
)
292 :family
(if local
'local
))
293 (error (user-error (error-message-string err
))))))
294 (when (processp mpc-proc
)
295 ;; Inherit the properties of the previous connection.
296 (let ((plist (process-plist mpc-proc
)))
297 (while plist
(process-put proc
(pop plist
) (pop plist
)))))
298 (mpc-proc-buffer proc
'mpd-commands
(current-buffer))
299 (process-put proc
'callback
'ignore
)
300 (process-put proc
'ready nil
)
301 (clrhash mpc--find-memoize
)
302 (set-process-filter proc
'mpc--proc-filter
)
303 (set-process-sentinel proc
'ignore
)
304 (set-process-query-on-exit-flag proc nil
)
305 ;; This may be called within a process filter ;-(
306 (with-local-quit (mpc-proc-sync proc
))
309 (mpc-proc-cmd (list "password" pass
) nil
))))))
311 (defun mpc--proc-quote-string (s)
312 (if (numberp s
) (number-to-string s
)
313 (setq s
(replace-regexp-in-string "[\"\\]" "\\\\\\&" s
))
314 (if (string-match " " s
) (concat "\"" s
"\"") s
)))
316 (defconst mpc--proc-alist-to-alists-starters
'(file directory
))
318 (defun mpc--proc-alist-to-alists (alist)
319 (cl-assert (or (null alist
)
320 (memq (caar alist
) mpc--proc-alist-to-alists-starters
)))
321 (let ((starter (caar alist
))
325 (when (eq (car pair
) starter
)
326 (if tmp
(push (nreverse tmp
) alists
))
329 (if tmp
(push (nreverse tmp
) alists
))
332 (defun mpc-proc (&optional restart
)
333 (unless (and mpc-proc
334 (buffer-live-p (process-buffer mpc-proc
))
336 (memq (process-status mpc-proc
) '(closed)))))
337 (mpc--proc-connect mpc-host
))
340 (defun mpc-proc-check (proc)
341 (let ((error-text (process-get proc
'mpc-proc-error
)))
343 (process-put proc
'mpc-proc-error nil
)
344 (signal 'mpc-proc-error error-text
))))
346 (defun mpc-proc-sync (&optional proc
)
347 "Wait for MPC process until it is idle again.
348 Return the buffer in which the process is/was running."
349 (unless proc
(setq proc
(mpc-proc)))
352 (while (and (not (process-get proc
'ready
))
353 (accept-process-output proc
)))
354 (mpc-proc-check proc
)
355 (if (process-get proc
'ready
) (process-buffer proc
)
356 (error "No response from MPD")))
357 (unless (process-get proc
'ready
)
359 (message "Killing hung process")
360 (delete-process proc
))))
362 (defun mpc-proc-cmd (cmd &optional callback
)
363 "Send command CMD to the MPD server.
364 If CALLBACK is nil, wait for the command to finish before returning,
365 otherwise return immediately and call CALLBACK with no argument
366 when the command terminates.
367 CMD can be a string which is passed as-is to MPD or a list of strings
368 which will be concatenated with proper quoting before passing them to MPD."
369 (let ((proc (mpc-proc 'restart
)))
370 (if (and callback
(not (process-get proc
'ready
)))
371 (let ((old (process-get proc
'callback
)))
372 (process-put proc
'callback
375 (mpc-proc-cmd cmd callback
))))
376 ;; Wait for any pending async command to terminate.
378 (process-put proc
'ready nil
)
379 (with-current-buffer (process-buffer proc
)
381 (mpc--debug "Send \"%s\"" cmd
)
383 proc
(concat (if (stringp cmd
) cmd
384 (mapconcat 'mpc--proc-quote-string cmd
" "))
387 ;; (let ((buf (current-buffer)))
388 (process-put proc
'callback
392 ;; (prog1 (current-buffer)
393 ;; (set-buffer buf)))))
395 ;; If `callback' is nil, we're executing synchronously.
396 (process-put proc
'callback
'ignore
)
397 ;; This returns the process's buffer.
398 (mpc-proc-sync proc
)))))
400 ;; This function doesn't exist in Emacs-21.
401 ;; (put 'mpc-proc-cmd-list 'byte-optimizer 'byte-optimize-pure-func)
402 (defun mpc-proc-cmd-list (cmds)
403 (concat "command_list_begin\n"
404 (mapconcat (lambda (cmd)
405 (if (stringp cmd
) cmd
406 (mapconcat 'mpc--proc-quote-string cmd
" ")))
409 "\ncommand_list_end"))
411 (defun mpc-proc-cmd-list-ok ()
412 ;; To implement this, we'll need to tweak the process filter since we'd
413 ;; then sometimes get "trailing" text after "OK\n".
414 (error "Not implemented yet"))
416 (defun mpc-proc-buf-to-alist (&optional buf
)
417 (with-current-buffer (or buf
(current-buffer))
419 (goto-char (point-min))
420 (while (re-search-forward "^\\([^:]+\\): \\(.*\\)\n" nil t
)
421 (push (cons (intern (match-string 1)) (match-string 2)) res
))
424 (defun mpc-proc-buf-to-alists (buf)
425 (mpc--proc-alist-to-alists (mpc-proc-buf-to-alist buf
)))
427 (defun mpc-proc-cmd-to-alist (cmd &optional callback
)
429 (let ((buf (current-buffer)))
430 (mpc-proc-cmd cmd
(lambda ()
431 (funcall callback
(prog1 (mpc-proc-buf-to-alist
433 (set-buffer buf
))))))
435 ;; (mpc-proc-cmd-to-alist cmd (lambda (alist) (setq res alist)))
438 (mpc-proc-buf-to-alist (mpc-proc-cmd cmd
))))
440 (defun mpc-proc-tag-string-to-sym (tag)
441 (intern (capitalize tag
)))
443 (defun mpc-proc-buffer (proc use
&optional buffer
)
444 (let* ((bufs (process-get proc
'buffers
))
445 (buf (cdr (assoc use bufs
))))
447 ((and buffer
(buffer-live-p buf
) (not (eq buffer buf
)))
448 (error "Duplicate MPC buffer for %s" use
))
451 (setcdr (assoc use bufs
) buffer
)
452 (process-put proc
'buffers
(cons (cons use buffer
) bufs
))))
455 ;;; Support for regularly updated current status information ;;;;;;;;;;;;;;;
457 ;; Exported elements:
458 ;; `mpc-status' holds the uptodate data.
459 ;; `mpc-status-callbacks' holds the registered callback functions.
460 ;; `mpc-status-refresh' forces a refresh of the data.
461 ;; `mpc-status-stop' stops the automatic updating.
463 (defvar mpc-status nil
)
464 (defvar mpc-status-callbacks
465 '((state . mpc--status-timers-refresh
)
466 ;; (song . mpc--queue-refresh)
467 ;; (state . mpc--queue-refresh) ;To detect the end of the last song.
468 (state . mpc--faster-toggle-refresh
) ;Only ffwd/rewind while play/pause.
469 (volume . mpc-volume-refresh
)
470 (file . mpc-songpointer-refresh
)
471 ;; The song pointer may need updating even if the file doesn't change,
472 ;; if the same song appears multiple times in a row.
473 (song . mpc-songpointer-refresh
)
474 (updating_db . mpc-updated-db
)
475 (updating_db . mpc--status-timers-refresh
)
476 (t . mpc-current-refresh
))
477 "Alist associating properties to the functions that care about them.
478 Each entry has the form (PROP . FUN) where PROP can be t to mean
479 to call FUN for any change whatsoever.")
481 (defun mpc--status-callback ()
482 (let ((old-status mpc-status
))
484 (setq mpc-status
(mpc-proc-buf-to-alist))
485 (cl-assert mpc-status
)
486 (unless (equal old-status mpc-status
)
487 ;; Run the relevant refresher functions.
488 (dolist (pair mpc-status-callbacks
)
489 (when (or (eq t
(car pair
))
490 (not (equal (cdr (assq (car pair
) old-status
))
491 (cdr (assq (car pair
) mpc-status
)))))
492 (funcall (cdr pair
)))))))
494 (defvar mpc--status-timer nil
)
495 (defun mpc--status-timer-start ()
496 (add-hook 'pre-command-hook
'mpc--status-timer-stop
)
497 (unless mpc--status-timer
498 (setq mpc--status-timer
(run-with-timer 1 1 'mpc--status-timer-run
))))
499 (defun mpc--status-timer-stop ()
500 (when mpc--status-timer
501 (cancel-timer mpc--status-timer
)
502 (setq mpc--status-timer nil
)))
503 (defun mpc--status-timer-run ()
504 (with-demoted-errors "MPC: %S"
505 (when (process-get (mpc-proc) 'ready
)
506 (let* ((buf (mpc-proc-buffer (mpc-proc) 'status
))
507 (win (get-buffer-window buf t
)))
509 (mpc--status-timer-stop)
510 (with-local-quit (mpc-status-refresh)))))))
512 (defvar mpc--status-idle-timer nil
)
513 (defun mpc--status-idle-timer-start ()
514 (when mpc--status-idle-timer
515 ;; Turn it off even if we'll start it again, in case it changes the delay.
516 (cancel-timer mpc--status-idle-timer
))
517 (setq mpc--status-idle-timer
518 (run-with-idle-timer 1 t
'mpc--status-idle-timer-run
))
519 ;; Typically, the idle timer is started from the mpc--status-callback,
520 ;; which is run asynchronously while we're already idle (we typically
521 ;; just started idling), so the timer itself will only be run the next
523 ;; To work around that, we immediately start the repeat timer.
524 (mpc--status-timer-start))
525 (defun mpc--status-idle-timer-stop (&optional really
)
526 (when mpc--status-idle-timer
527 ;; Turn it off even if we'll start it again, in case it changes the delay.
528 (cancel-timer mpc--status-idle-timer
))
529 (setq mpc--status-idle-timer
531 ;; We don't completely stop the timer, so that if some other MPD
532 ;; client starts playback, we may get a chance to notice it.
533 (run-with-idle-timer 10 t
'mpc--status-idle-timer-run
))))
534 (defun mpc--status-idle-timer-run ()
535 (mpc--status-timer-start)
536 (mpc--status-timer-run))
538 (defun mpc--status-timers-refresh ()
539 "Start/stop the timers according to whether a song is playing."
540 (if (or (member (cdr (assq 'state mpc-status
)) '("play"))
541 (cdr (assq 'updating_db mpc-status
)))
542 (mpc--status-idle-timer-start)
543 (mpc--status-idle-timer-stop)
544 (mpc--status-timer-stop)))
546 (defun mpc-status-refresh (&optional callback
)
547 "Refresh `mpc-status'."
549 (mpc-proc-cmd (mpc-proc-cmd-list '("status" "currentsong"))
551 (mpc--status-callback)
552 (if cb
(funcall cb
))))))
554 (defun mpc-status-stop ()
555 "Stop the autorefresh of `mpc-status'.
556 This is normally used only when quitting MPC.
557 Any call to `mpc-status-refresh' may cause it to be restarted."
558 (setq mpc-status nil
)
559 (mpc--status-idle-timer-stop 'really
)
560 (mpc--status-timer-stop))
562 ;;; A thin layer above the raw protocol commands ;;;;;;;;;;;;;;;;;;;;;;;;;;;
564 ;; (defvar mpc-queue nil)
565 ;; (defvar mpc-queue-back nil)
567 ;; (defun mpc--queue-head ()
568 ;; (if (stringp (car mpc-queue)) (car mpc-queue) (cadar mpc-queue)))
569 ;; (defun mpc--queue-pop ()
570 ;; (when mpc-queue ;Can be nil if out of sync.
571 ;; (let ((song (car mpc-queue)))
573 ;; (push (if (and (consp song) (cddr song))
574 ;; ;; The queue's first element is itself a list of
575 ;; ;; songs, where the first element isn't itself a song
576 ;; ;; but a description of the list.
577 ;; (prog1 (cadr song) (setcdr song (cddr song)))
578 ;; (prog1 (if (consp song) (cadr song) song)
579 ;; (setq mpc-queue (cdr mpc-queue))))
581 ;; (cl-assert (stringp (car mpc-queue-back))))))
583 ;; (defun mpc--queue-refresh ()
584 ;; ;; Maintain the queue.
585 ;; (mpc--debug "mpc--queue-refresh")
586 ;; (let ((pos (cdr (or (assq 'Pos mpc-status) (assq 'song mpc-status)))))
589 ;; (mpc-cmd-clear 'ignore))
590 ;; ((or (not (member pos '("0" nil)))
591 ;; ;; There's only one song in the playlist and we've stopped.
592 ;; ;; Maybe it's because of some external client that set the
593 ;; ;; playlist like that and/or manually stopped the playback, but
594 ;; ;; it's more likely that we've simply reached the end of
595 ;; ;; the song. So remove it.
596 ;; (and (equal (assq 'state mpc-status) "stop")
597 ;; (equal (assq 'playlistlength mpc-status) "1")
599 ;; ;; We're not playing the first song in the queue/playlist any
600 ;; ;; more, so update the queue.
601 ;; (dotimes (i (string-to-number pos)) (mpc--queue-pop))
602 ;; (mpc-proc-cmd (mpc-proc-cmd-list
603 ;; (make-list (string-to-number pos) "delete 0"))
605 ;; (if (not (equal (cdr (assq 'file mpc-status))
606 ;; (mpc--queue-head)))
607 ;; (message "MPC's queue is out of sync"))))))
609 (defvar mpc--find-memoize-union-tags nil
)
611 (defun mpc-cmd-flush (tag value
)
612 (puthash (cons tag value
) nil mpc--find-memoize
)
613 (dolist (uniontag mpc--find-memoize-union-tags
)
614 (if (member (symbol-name tag
) (split-string (symbol-name uniontag
) "|"))
615 (puthash (cons uniontag value
) nil mpc--find-memoize
))))
618 (defun mpc-cmd-special-tag-p (tag)
619 (or (memq tag
'(Playlist Search Directory
))
620 (string-match "|" (symbol-name tag
))))
622 (defun mpc-cmd-find (tag value
)
623 "Return a list of all songs whose tag TAG has value VALUE.
624 The songs are returned as alists."
625 (or (gethash (cons tag value
) mpc--find-memoize
)
626 (puthash (cons tag value
)
629 ;; Special case for pseudo-tag playlist.
630 (let ((l (condition-case nil
631 (mpc-proc-buf-to-alists
632 (mpc-proc-cmd (list "listplaylistinfo" value
)))
634 ;; "[50@0] {listplaylistinfo} No such playlist"
638 (prog1 (cons (cons 'Pos
(number-to-string i
)) s
)
642 (mpc-proc-buf-to-alists
643 (mpc-proc-cmd (list "search" "any" value
))))
646 (mpc-proc-buf-to-alist
647 (mpc-proc-cmd (list "listallinfo" value
)))))
648 (mpc--proc-alist-to-alists
649 ;; Strip away the `directory' entries.
650 (delq nil
(mapcar (lambda (pair)
651 (if (eq (car pair
) 'directory
)
654 ((string-match "|" (symbol-name tag
))
655 (add-to-list 'mpc--find-memoize-union-tags tag
)
656 (let ((tag1 (intern (substring (symbol-name tag
)
657 0 (match-beginning 0))))
658 (tag2 (intern (substring (symbol-name tag
)
660 (mpc-union (mpc-cmd-find tag1 value
)
661 (mpc-cmd-find tag2 value
))))
664 (mpc-proc-buf-to-alists
665 (mpc-proc-cmd (list "find" (symbol-name tag
) value
)))
667 ;; If `tag' is not one of the expected tags, MPD burps
668 ;; about not having the relevant table. FIXME: check
669 ;; the kind of error.
670 (error "Unknown tag %s" tag
)
672 (setq value
(cons tag value
))
673 (dolist (song (mpc-proc-buf-to-alists
674 (mpc-proc-cmd "listallinfo")))
675 (if (member value song
) (push song res
)))
679 (defun mpc-cmd-list (tag &optional other-tag value
)
680 ;; FIXME: we could also provide a `mpc-cmd-list' alternative which
681 ;; doesn't take an "other-tag value" constraint but a "song-list" instead.
682 ;; That might be more efficient in some cases.
685 (let ((pls (mpc-assq-all 'playlist
(mpc-proc-cmd-to-alist "lsinfo"))))
687 (dolist (pl (prog1 pls
(setq pls nil
)))
688 (let ((plsongs (mpc-cmd-find 'Playlist pl
)))
689 (if (not (mpc-cmd-special-tag-p other-tag
))
690 (when (member (cons other-tag value
)
691 (apply 'append plsongs
))
693 ;; Problem N°2: we compute the intersection whereas all
694 ;; we care about is whether it's empty. So we could
695 ;; speed this up significantly.
696 ;; We only compare file names, because the full song-entries
697 ;; are slightly different (the ones in plsongs include
698 ;; position and id info specific to the playlist), and it's
699 ;; good enough because this is only used with "search", which
700 ;; doesn't pay attention to playlists and URLs anyway.
701 (let* ((osongs (mpc-cmd-find other-tag value
))
702 (ofiles (mpc-assq-all 'file
(apply 'append osongs
)))
703 (plfiles (mpc-assq-all 'file
(apply 'append plsongs
))))
704 (when (mpc-intersection plfiles ofiles
)
711 (mpc-assq-all 'directory
712 (mpc-proc-buf-to-alist
713 (mpc-proc-cmd "lsinfo")))
714 (mapcar (lambda (dir)
716 (if (get-text-property 0 'display dir
)
718 (get-text-property 0 'display dir
))
721 (mpc-assq-all 'directory
722 (mpc-proc-buf-to-alist
723 (mpc-proc-cmd (list "lsinfo" dir
))))))
724 (dolist (subdir subdirs
)
725 (put-text-property 0 (1+ (length dir
))
729 (process-get (mpc-proc) 'Directory
)))
730 ;; If there's an other-tag, then just extract the dir info from the
731 ;; list of other-tag's songs.
732 (let* ((other-songs (mpc-cmd-find other-tag value
))
733 (files (mpc-assq-all 'file
(apply 'append other-songs
)))
736 (let ((dir (file-name-directory file
)))
737 (if (and dir
(setq dir
(directory-file-name dir
))
738 (not (equal dir
(car dirs
))))
740 ;; Dirs might have duplicates still.
741 (setq dirs
(delete-dups dirs
))
742 (let ((newdirs dirs
))
744 (let ((dir (file-name-directory (pop newdirs
))))
745 (when (and dir
(setq dir
(directory-file-name dir
))
746 (not (member dir dirs
)))
751 ;; The UI should not provide access to such a thing anyway currently.
752 ;; But I could imagine adding in the future a browser for the "search"
753 ;; tag, which would provide things like previous searches. Not sure how
754 ;; useful that would be tho.
755 ((eq tag
'Search
) (error "Not supported"))
757 ((string-match "|" (symbol-name tag
))
758 (let ((tag1 (intern (substring (symbol-name tag
)
759 0 (match-beginning 0))))
760 (tag2 (intern (substring (symbol-name tag
)
762 (mpc-union (mpc-cmd-list tag1 other-tag value
)
763 (mpc-cmd-list tag2 other-tag value
))))
767 (mapcar 'cdr
(mpc-proc-cmd-to-alist (list "list" (symbol-name tag
))))
769 ;; If `tag' is not one of the expected tags, MPD burps about not
770 ;; having the relevant table.
771 ;; FIXME: check the kind of error.
772 (error "MPD does not know this tag %s" tag
)
773 (mpc-assq-all tag
(mpc-proc-cmd-to-alist "listallinfo")))))
776 (if (mpc-cmd-special-tag-p other-tag
)
777 (signal 'mpc-proc-error
"Not implemented")
779 (mpc-proc-cmd-to-alist
780 (list "list" (symbol-name tag
)
781 (symbol-name other-tag
) value
))))
783 ;; DAMN!! the 3-arg form of `list' is new in 0.12 !!
784 ;; FIXME: check the kind of error.
785 (let ((other-songs (mpc-cmd-find other-tag value
)))
787 ;; Don't use `nconc' now that mpc-cmd-find may
788 ;; return a memoized result.
789 (apply 'append other-songs
))))))))
791 (defun mpc-cmd-stop (&optional callback
)
792 (mpc-proc-cmd "stop" callback
))
794 (defun mpc-cmd-clear (&optional callback
)
795 (mpc-proc-cmd "clear" callback
)
796 ;; (setq mpc-queue-back nil mpc-queue nil)
799 (defun mpc-cmd-pause (&optional arg callback
)
800 "Pause or resume playback of the queue of songs."
802 (mpc-proc-cmd (list "pause" arg
)
803 (lambda () (mpc-status-refresh) (if cb
(funcall cb
))))
804 (unless callback
(mpc-proc-sync))))
806 (defun mpc-cmd-status ()
807 (mpc-proc-cmd-to-alist "status"))
809 (defun mpc-cmd-play ()
810 (mpc-proc-cmd "play")
811 (mpc-status-refresh))
813 (defun mpc-cmd-add (files &optional playlist
)
814 "Add the songs FILES to PLAYLIST.
815 If PLAYLIST is t or nil or missing, use the main playlist."
816 (mpc-proc-cmd (mpc-proc-cmd-list
817 (mapcar (lambda (file)
818 (if (stringp playlist
)
819 (list "playlistadd" playlist file
)
822 (if (stringp playlist
)
823 (mpc-cmd-flush 'Playlist playlist
)))
825 (defun mpc-cmd-delete (song-poss &optional playlist
)
826 "Delete the songs at positions SONG-POSS from PLAYLIST.
827 If PLAYLIST is t or nil or missing, use the main playlist."
828 (mpc-proc-cmd (mpc-proc-cmd-list
829 (mapcar (lambda (song-pos)
830 (if (stringp playlist
)
831 (list "playlistdelete" playlist song-pos
)
832 (list "delete" song-pos
)))
833 ;; Sort them from last to first, so the renumbering
834 ;; caused by the earlier deletions don't affect
836 (sort song-poss
'>))))
837 (if (stringp playlist
)
838 (puthash (cons 'Playlist playlist
) nil mpc--find-memoize
)))
841 (defun mpc-cmd-move (song-poss dest-pos
&optional playlist
)
845 (mapcar (lambda (song-pos)
846 (if (>= song-pos dest-pos
)
847 ;; positions past dest-pos have been
849 (setq song-pos
(+ song-pos i
)))
850 (prog1 (if (stringp playlist
)
851 (list "playlistmove" playlist song-pos dest-pos
)
852 (list "move" song-pos dest-pos
))
853 (if (< song-pos dest-pos
)
854 ;; This move has shifted dest-pos by 1.
857 ;; Sort them from last to first, so the renumbering
858 ;; caused by the earlier deletions affect
859 ;; later ones a bit less.
860 (sort song-poss
'>))))
861 (if (stringp playlist
)
862 (puthash (cons 'Playlist playlist
) nil mpc--find-memoize
))))
864 (defun mpc-cmd-update (&optional arg callback
)
866 (mpc-proc-cmd (if arg
(list "update" arg
) "update")
867 (lambda () (mpc-status-refresh) (if cb
(funcall cb
))))
868 (unless callback
(mpc-proc-sync))))
870 (defun mpc-cmd-tagtypes ()
871 (mapcar 'cdr
(mpc-proc-cmd-to-alist "tagtypes")))
873 ;; This was never integrated into MPD.
874 ;; (defun mpc-cmd-download (file)
875 ;; (with-current-buffer (generate-new-buffer " *mpc download*")
876 ;; (set-buffer-multibyte nil)
877 ;; (let* ((proc (mpc-proc))
878 ;; (stdbuf (process-buffer proc))
879 ;; (markpos (marker-position (process-mark proc)))
880 ;; (stdcoding (process-coding-system proc)))
883 ;; (set-process-buffer proc (current-buffer))
884 ;; (set-process-coding-system proc 'binary (cdr stdcoding))
885 ;; (set-marker (process-mark proc) (point))
886 ;; (mpc-proc-cmd (list "download" file)))
887 ;; (set-process-buffer proc stdbuf)
888 ;; (set-marker (process-mark proc) markpos stdbuf)
889 ;; (set-process-coding-system proc (car stdcoding) (cdr stdcoding)))
890 ;; ;; The command has completed, let's decode.
891 ;; (goto-char (point-max))
892 ;; (delete-char -1) ;Delete final newline.
893 ;; (while (re-search-backward "^>" nil t)
895 ;; (current-buffer))))
897 ;;; Misc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
899 (defcustom mpc-mpd-music-directory nil
900 "Location of MPD's music directory."
901 :type
'(choice (const nil
) directory
))
903 (defcustom mpc-data-directory
904 (locate-user-emacs-file "mpc" ".mpc")
905 "Directory where MPC.el stores auxiliary data."
908 (defun mpc-data-directory ()
909 (unless (file-directory-p mpc-data-directory
)
910 (make-directory mpc-data-directory
))
913 (defun mpc-file-local-copy (file)
914 ;; Try to set mpc-mpd-music-directory.
915 (when (and (null mpc-mpd-music-directory
)
916 (or (string-match "\\`localhost" mpc-host
)
917 (file-name-absolute-p mpc-host
)))
918 (let ((files `(,(let ((xdg (getenv "XDG_CONFIG_HOME")))
919 (concat (if (and xdg
(file-name-absolute-p xdg
))
922 "~/.mpdconf" "~/.mpd/mpd.conf" "/etc/mpd.conf"))
924 (while (and files
(not file
))
925 (if (file-exists-p (car files
)) (setq file
(car files
)))
926 (setq files
(cdr files
)))
928 (ignore-errors (insert-file-contents file
))
929 (goto-char (point-min))
930 (if (re-search-forward "^music_directory[ ]+\"\\([^\"]+\\)\"")
931 (setq mpc-mpd-music-directory
932 (match-string 1))))))
933 ;; Use mpc-mpd-music-directory if applicable, or else try to use the
934 ;; `download' command, although it's never been accepted in `mpd' :-(
935 (if (and mpc-mpd-music-directory
936 (file-exists-p (expand-file-name file mpc-mpd-music-directory
)))
937 (expand-file-name file mpc-mpd-music-directory
)
938 ;; (let ((aux (expand-file-name (replace-regexp-in-string "[/]" "|" file)
939 ;; (mpc-data-directory))))
940 ;; (unless (file-exists-p aux)
941 ;; (condition-case err
943 ;; (with-current-buffer (mpc-cmd-download file)
944 ;; (write-region (point-min) (point-max) aux)
945 ;; (kill-buffer (current-buffer))))
946 ;; (mpc-proc-error (message "Download error: %s" err) (setq aux nil))))
950 ;;; Formatter ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
952 (defun mpc-secs-to-time (secs)
953 ;; We could use `format-seconds', but it doesn't seem worth the trouble
954 ;; because we'd still need to check (>= secs (* 60 100)) since the special
955 ;; %z only allows us to drop the large units for small values but
956 ;; not to drop the small units for large values.
957 (if (stringp secs
) (setq secs
(string-to-number secs
)))
958 (if (>= secs
(* 60 100)) ;More than 100 minutes.
959 (format "%dh%02d" ;"%d:%02d:%02d"
960 (/ secs
3600) (%
(/ secs
60) 60)) ;; (% secs 60)
961 (format "%d:%02d" (/ secs
60) (% secs
60))))
963 (defvar mpc-tempfiles nil
)
964 (defconst mpc-tempfiles-reftable
(make-hash-table :weakness
'key
))
966 (defun mpc-tempfiles-clean ()
968 (maphash (lambda (_k v
) (push v live
)) mpc-tempfiles-reftable
)
969 (dolist (f mpc-tempfiles
)
970 (unless (member f live
) (ignore-errors (delete-file f
))))
971 (setq mpc-tempfiles live
)))
973 (defun mpc-tempfiles-add (key file
)
974 (mpc-tempfiles-clean)
975 (puthash key file mpc-tempfiles-reftable
)
976 (push file mpc-tempfiles
))
978 (defun mpc-format (format-spec info
&optional hscroll
)
979 "Format the INFO according to FORMAT-SPEC, inserting the result at point."
982 (col (if hscroll
(- hscroll
) 0))
983 (insert (lambda (str)
985 ((>= col
0) (insert str
))
986 (t (insert (substring str
(min (length str
) (- col
))))))))
988 (while (string-match "%\\(?:%\\|\\(-\\)?\\([0-9]+\\)?{\\([[:alpha:]][[:alnum:]]*\\)\\(?:-\\([^}]+\\)\\)?}\\)" format-spec pos
)
989 (let ((pre-text (substring format-spec pos
(match-beginning 0))))
990 (funcall insert pre-text
)
991 (setq col
(+ col
(string-width pre-text
))))
992 (setq pos
(match-end 0))
993 (if (null (match-end 3))
996 (setq col
(+ col
1)))
997 (let* ((size (match-string 2 format-spec
))
998 (tag (intern (match-string 3 format-spec
)))
999 (post (match-string 4 format-spec
))
1000 (right-align (match-end 1))
1002 (if (eq info
'self
) (symbol-name tag
)
1004 ((or `Time
`Duration
)
1005 (let ((time (cdr (or (assq 'time info
) (assq 'Time info
)))))
1006 (setq pred
(list nil
)) ;Just assume it's never eq.
1008 (mpc-secs-to-time (if (and (eq tag
'Duration
)
1009 (string-match ":" time
))
1010 (substring time
(match-end 0))
1013 (if-let ((dir (file-name-directory
1014 (mpc-file-local-copy (cdr (assq 'file info
)))))
1015 (covers '(".folder.png" "cover.jpg" "folder.jpg"))
1016 (cover (cl-loop for file in
(directory-files dir
)
1017 if
(member (downcase file
) covers
)
1018 return
(concat dir file
)))
1019 (file (with-demoted-errors "MPC: %s"
1020 (mpc-file-local-copy cover
))))
1023 (push `(equal ',dir
(file-name-directory (cdr (assq 'file info
)))) pred
)
1024 (if (null size
) (setq image
(create-image file
))
1025 (let ((tempfile (make-temp-file "mpc" nil
".jpg")))
1026 (call-process "convert" nil nil nil
1027 "-scale" size file tempfile
)
1028 (setq image
(create-image tempfile
))
1029 (mpc-tempfiles-add image tempfile
)))
1031 (propertize dir
'display image
))
1032 ;; Make sure we return something on which we can
1033 ;; place the `mpc-pred' property, as
1034 ;; a negative-cache. We could also use
1036 (progn (setq size nil
) " ")))
1037 (_ (let ((val (cdr (assq tag info
))))
1038 ;; For Streaming URLs, there's no other info
1039 ;; than the URL in `file'. Pretend it's in `Title'.
1040 (when (and (null val
) (eq tag
'Title
))
1041 (setq val
(cdr (assq 'file info
))))
1042 (push `(equal ',val
(cdr (assq ',tag info
))) pred
)
1044 ((not (and (eq tag
'Date
) (stringp val
))) val
)
1045 ;; For "date", only keep the year!
1046 ((string-match "[0-9]\\{4\\}" val
)
1047 (match-string 0 val
))
1050 (setq size
(string-to-number size
))
1051 (propertize " " 'display
1052 (list 'space
:align-to
(+ col size
)))))
1053 (textwidth (if text
(string-width text
) 0))
1054 (postwidth (if post
(string-width post
) 0)))
1058 (> (+ postwidth textwidth
) size
))
1060 (truncate-string-to-width text size nil nil
"…")
1063 (when (memq tag
'(Artist Album Composer
)) ;FIXME: wrong list.
1066 'mouse-face
'highlight
1072 (mpc-constraints-push 'noerror
)
1073 (mpc-constraints-restore
1074 ',(list (list tag text
)))))))))
1077 (propertize " " 'display
1078 (list 'space
:align-to
1080 (if (and size right-align
)
1081 (- size postwidth textwidth
)
1084 (if (null size
) (setq col
(+ col textwidth postwidth
))
1086 (setq col
(+ col size
))))))
1087 (put-text-property start
(point) 'mpc-pred
1088 `(lambda (info) (and ,@(nreverse pred
))))))
1090 ;;; The actual UI code ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1092 (defvar mpc-mode-map
1093 (let ((map (make-sparse-keymap)))
1094 ;; (define-key map "\e" 'mpc-stop)
1095 (define-key map
"q" 'mpc-quit
)
1096 (define-key map
"\r" 'mpc-select
)
1097 (define-key map
[(shift return
)] 'mpc-select-toggle
)
1098 (define-key map
[mouse-2
] 'mpc-select
)
1099 (define-key map
[S-mouse-2
] 'mpc-select-extend
)
1100 (define-key map
[C-mouse-2
] 'mpc-select-toggle
)
1101 (define-key map
[drag-mouse-2
] 'mpc-drag-n-drop
)
1102 ;; We use `always' because a binding to t is like a binding to nil.
1103 (define-key map
[follow-link
] :always
)
1104 ;; But follow-link doesn't apply blindly to header-line and
1105 ;; mode-line clicks.
1106 (define-key map
[header-line follow-link
] 'ignore
)
1107 (define-key map
[mode-line follow-link
] 'ignore
)
1108 ;; Doesn't work because the first click changes the buffer, so the second
1109 ;; is applied elsewhere :-(
1110 ;; (define-key map [(double mouse-2)] 'mpc-play-at-point)
1111 (define-key map
"p" 'mpc-pause
)
1112 (define-key map
"s" 'mpc-toggle-play
)
1113 (define-key map
">" 'mpc-next
)
1114 (define-key map
"<" 'mpc-prev
)
1115 (define-key map
"g" nil
)
1118 (easy-menu-define mpc-mode-menu mpc-mode-map
1121 ["Play/Pause" mpc-toggle-play
]
1122 ["Next track" mpc-next
]
1123 ["Previous track" mpc-prev
]
1124 ["Add new browser" mpc-tagbrowser
]
1125 ["Update DB" mpc-update
]
1128 (defvar mpc-tool-bar-map
1129 (let ((map (make-sparse-keymap)))
1130 (tool-bar-local-item "mpc/prev" 'mpc-prev
'prev map
1131 :enable
'(not (equal (cdr (assq 'state mpc-status
)) "stop"))
1132 :label
"Prev" :vert-only t
)
1133 ;; FIXME: how can we bind it to the down-event?
1134 (tool-bar-local-item "mpc/rewind" 'mpc-rewind
'rewind map
1135 :enable
'(not (equal (cdr (assq 'state mpc-status
)) "stop"))
1136 :label
"Rew" :vert-only t
1137 :button
'(:toggle .
(and mpc--faster-toggle-timer
1138 (not mpc--faster-toggle-forward
))))
1139 ;; We could use a single toggle command for pause/play, with 2 different
1140 ;; icons depending on whether or not it's selected, but then it'd have
1141 ;; to be a toggle-button, thus displayed depressed in one of the
1143 (tool-bar-local-item "mpc/pause" 'mpc-pause
'pause map
1144 :label
"Pause" :vert-only t
1145 :visible
'(equal (cdr (assq 'state mpc-status
)) "play")
1147 (tool-bar-local-item "mpc/play" 'mpc-play
'play map
1148 :label
"Play" :vert-only t
1149 :visible
'(not (equal (cdr (assq 'state mpc-status
)) "play"))
1151 ;; FIXME: how can we bind it to the down-event?
1152 (tool-bar-local-item "mpc/ffwd" 'mpc-ffwd
'ffwd map
1153 :enable
'(not (equal (cdr (assq 'state mpc-status
)) "stop"))
1154 :label
"Ffwd" :vert-only t
1155 :button
'(:toggle .
(and mpc--faster-toggle-timer
1156 mpc--faster-toggle-forward
)))
1157 (tool-bar-local-item "mpc/next" 'mpc-next
'next map
1158 :label
"Next" :vert-only t
1159 :enable
'(not (equal (cdr (assq 'state mpc-status
)) "stop")))
1160 (tool-bar-local-item "mpc/stop" 'mpc-stop
'stop map
1161 :label
"Stop" :vert-only t
)
1162 (tool-bar-local-item "mpc/add" 'mpc-playlist-add
'add map
1163 :label
"Add" :vert-only t
1164 :help
"Append to the playlist")
1167 (define-derived-mode mpc-mode special-mode
"MPC"
1168 "Major mode for the features common to all buffers of MPC."
1169 (buffer-disable-undo)
1170 (if (boundp 'tool-bar-map
) ; not if --without-x
1171 (setq-local tool-bar-map mpc-tool-bar-map
))
1172 (setq-local truncate-lines t
))
1174 ;;; The mpc-status-mode buffer ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1176 (define-derived-mode mpc-status-mode mpc-mode
"MPC-Status"
1177 "Major mode to display MPC status info."
1178 (setq-local mode-line-format
1179 '("%e" mode-line-frame-identification
1180 mode-line-buffer-identification
))
1181 (setq-local window-area-factor
3)
1182 (setq-local header-line-format
'("MPC " mpc-volume
)))
1184 (defvar mpc-status-buffer-format
1185 '("%-5{Time} / %{Duration} %2{Disc--}%4{Track}" "%{Title}" "%{Album}" "%{Artist}" "%128{Cover}"))
1187 (defun mpc-status-buffer-refresh ()
1188 (let ((buf (mpc-proc-buffer (mpc-proc) 'status
)))
1189 (when (buffer-live-p buf
)
1190 (with-current-buffer buf
1192 (goto-char (point-min))
1193 (when (assq 'file mpc-status
)
1194 (let ((inhibit-read-only t
))
1195 (dolist (spec mpc-status-buffer-format
)
1196 (let ((pred (get-text-property (point) 'mpc-pred
)))
1197 (if (and pred
(funcall pred mpc-status
))
1199 (delete-region (point) (line-beginning-position 2))
1200 (ignore-errors (mpc-format spec mpc-status
))
1202 (unless (eobp) (delete-region (point) (point-max))))))))))
1204 (defun mpc-status-buffer-show ()
1206 (let* ((proc (mpc-proc))
1207 (buf (mpc-proc-buffer proc
'status
))
1208 (songs-buf (mpc-proc-buffer proc
'songs
))
1209 (songs-win (if songs-buf
(get-buffer-window songs-buf
0))))
1210 (unless (buffer-live-p buf
)
1211 (setq buf
(get-buffer-create "*MPC-Status*"))
1212 (with-current-buffer buf
1214 (mpc-proc-buffer proc
'status buf
))
1215 (if (null songs-win
) (pop-to-buffer buf
)
1216 (let ((_win (split-window songs-win
20 t
)))
1217 (set-window-dedicated-p songs-win nil
)
1218 (set-window-buffer songs-win buf
)
1219 (set-window-dedicated-p songs-win
'soft
)))))
1221 ;;; Selection management;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1223 (defvar mpc-separator-ol nil
)
1225 (defvar-local mpc-select nil
)
1227 (defmacro mpc-select-save
(&rest body
)
1228 "Execute BODY and restore the selection afterwards."
1229 (declare (indent 0) (debug t
))
1230 `(let ((selection (mpc-select-get-selection))
1231 (position (cons (buffer-substring-no-properties
1232 (line-beginning-position) (line-end-position))
1235 (mpc-select-restore selection
)
1236 (goto-char (point-min))
1237 (if (re-search-forward
1238 (concat "^" (regexp-quote (car position
)) "$")
1239 (if (overlayp mpc-separator-ol
)
1240 (overlay-end mpc-separator-ol
))
1242 (move-to-column (cdr position
)))
1243 (let ((win (get-buffer-window (current-buffer) 0)))
1244 (if win
(set-window-point win
(point))))))
1246 (defun mpc-select-get-selection ()
1247 (mapcar (lambda (ol)
1248 (buffer-substring-no-properties
1249 (overlay-start ol
) (1- (overlay-end ol
))))
1252 (defun mpc-select-restore (selection)
1253 ;; Restore the selection. I.e. move the overlays back to their
1254 ;; corresponding location. Actually which overlay is used for what
1256 (mapc 'delete-overlay mpc-select
)
1257 (setq mpc-select nil
)
1258 (dolist (elem selection
)
1259 ;; After an update, some elements may have disappeared.
1260 (goto-char (point-min))
1261 (when (re-search-forward
1262 (concat "^" (regexp-quote elem
) "$") nil t
)
1263 (mpc-select-make-overlay)))
1264 (when mpc-tag
(mpc-tagbrowser-all-select))
1265 (beginning-of-line))
1267 (defun mpc-select-make-overlay ()
1268 (cl-assert (not (get-char-property (point) 'mpc-select
)))
1269 (let ((ol (make-overlay
1270 (line-beginning-position) (line-beginning-position 2))))
1271 (overlay-put ol
'mpc-select t
)
1272 (overlay-put ol
'face
'highlight
)
1273 (overlay-put ol
'evaporate t
)
1274 (push ol mpc-select
)))
1276 (defun mpc-select (&optional event
)
1277 "Select the tag value at point."
1278 (interactive (list last-nonmenu-event
))
1279 (mpc-event-set-point event
)
1280 (if (and (bolp) (eobp)) (forward-line -
1))
1281 (mapc 'delete-overlay mpc-select
)
1282 (setq mpc-select nil
)
1283 (if (mpc-tagbrowser-all-p)
1285 (mpc-select-make-overlay))
1287 (mpc-tagbrowser-all-select)
1288 (mpc-selection-refresh)))
1290 (defun mpc-select-toggle (&optional event
)
1291 "Toggle the selection of the tag value at point."
1292 (interactive (list last-nonmenu-event
))
1293 (mpc-event-set-point event
)
1296 ;; The line is already selected: deselect it.
1297 ((get-char-property (point) 'mpc-select
)
1299 (dolist (ol mpc-select
)
1300 (if (and (<= (overlay-start ol
) (point))
1301 (> (overlay-end ol
) (point)))
1304 (cl-assert (= (1+ (length ols
)) (length mpc-select
)))
1305 (setq mpc-select ols
)))
1306 ;; We're trying to select *ALL* additionally to others.
1307 ((mpc-tagbrowser-all-p) nil
)
1308 ;; Select the current line.
1309 (t (mpc-select-make-overlay))))
1311 (mpc-tagbrowser-all-select)
1312 (mpc-selection-refresh)))
1314 (defun mpc-select-extend (&optional event
)
1315 "Extend the selection up to point."
1316 (interactive (list last-nonmenu-event
))
1317 (mpc-event-set-point event
)
1318 (if (null mpc-select
)
1319 ;; If nothing's selected yet, fallback to selecting the elem at point.
1323 ;; The line is already in a selected area; truncate the area.
1324 ((get-char-property (point) 'mpc-select
)
1327 (mid (line-beginning-position))
1329 (while (and (zerop (forward-line 1))
1330 (get-char-property (point) 'mpc-select
))
1331 (setq end
(1+ (point)))
1334 (while (and (zerop (forward-line -
1))
1335 (get-char-property (point) 'mpc-select
))
1336 (setq start
(point))
1338 (if (and (= after
0) (= before
0))
1339 ;; Shortening an already minimum-size region: do nothing.
1341 (if (> after before
)
1343 (setq start
(1+ mid
)))
1345 (dolist (ol mpc-select
)
1346 (if (and (>= (overlay-start ol
) start
)
1347 (< (overlay-start ol
) end
))
1350 (setq mpc-select
(nreverse ols
))))))
1351 ;; Extending a prior area. Look for the closest selection.
1353 (when (mpc-tagbrowser-all-p)
1358 (start (line-beginning-position)))
1359 (while (and (zerop (forward-line 1))
1360 (not (get-char-property (point) 'mpc-select
)))
1362 (unless (get-char-property (point) 'mpc-select
)
1365 (while (and (zerop (forward-line -
1))
1366 (not (get-char-property (point) 'mpc-select
)))
1368 (unless (get-char-property (point) 'mpc-select
)
1370 (when (and before
(or (null count
) (< before count
)))
1374 (dotimes (_i (1+ (or count
0)))
1375 (mpc-select-make-overlay)
1376 (forward-line dir
))))))
1378 (mpc-tagbrowser-all-select)
1379 (mpc-selection-refresh))))
1381 ;;; Constraint sets ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1383 (defvar mpc--song-search nil
)
1385 (defun mpc-constraints-get-current (&optional avoid-buf
)
1386 "Return currently selected set of constraints.
1387 If AVOID-BUF is non-nil, it specifies a buffer which should be ignored
1388 when constructing the set of constraints."
1389 (let ((constraints (if mpc--song-search
`((Search ,mpc--song-search
))))
1391 (dolist (buf (process-get (mpc-proc) 'buffers
))
1392 (setq buf
(cdr buf
))
1393 (when (and (setq tag
(buffer-local-value 'mpc-tag buf
))
1394 (not (eq buf avoid-buf
))
1396 (with-current-buffer buf
(mpc-select-get-selection))))
1397 (push (cons tag select
) constraints
)))
1400 (defun mpc-constraints-tag-lookup (buffer-tag constraints
)
1402 (dolist (constraint constraints
)
1403 (when (or (eq (car constraint
) buffer-tag
)
1404 (and (string-match "|" (symbol-name buffer-tag
))
1405 (member (symbol-name (car constraint
))
1406 (split-string (symbol-name buffer-tag
) "|"))))
1407 (setq res
(cdr constraint
))))
1410 (defun mpc-constraints-restore (constraints)
1411 (let ((search (assq 'Search constraints
)))
1412 (setq mpc--song-search
(cadr search
))
1413 (when search
(setq constraints
(delq search constraints
))))
1414 (dolist (buf (process-get (mpc-proc) 'buffers
))
1415 (setq buf
(cdr buf
))
1416 (when (buffer-live-p buf
)
1417 (let* ((tag (buffer-local-value 'mpc-tag buf
))
1418 (constraint (mpc-constraints-tag-lookup tag constraints
)))
1420 (with-current-buffer buf
1421 (mpc-select-restore constraint
))))))
1422 (mpc-selection-refresh))
1424 ;; I don't get the ring.el code. I think it doesn't do what I need, but
1425 ;; then I don't understand when what it does would be useful.
1426 (defun mpc-ring-make (size) (cons 0 (cons 0 (make-vector size nil
))))
1427 (defun mpc-ring-push (ring val
)
1428 (aset (cddr ring
) (car ring
) val
)
1429 (setcar (cdr ring
) (max (cadr ring
) (1+ (car ring
))))
1430 (setcar ring
(mod (1+ (car ring
)) (length (cddr ring
)))))
1431 (defun mpc-ring-pop (ring)
1432 (setcar ring
(mod (1- (car ring
)) (cadr ring
)))
1433 (aref (cddr ring
) (car ring
)))
1435 (defvar mpc-constraints-ring
(mpc-ring-make 10))
1437 (defun mpc-constraints-push (&optional noerror
)
1438 "Push the current selection on the ring for later."
1440 (let ((constraints (mpc-constraints-get-current)))
1441 (if (null constraints
)
1442 (unless noerror
(error "No selection to push"))
1443 (mpc-ring-push mpc-constraints-ring constraints
))))
1445 (defun mpc-constraints-pop ()
1446 "Recall the most recently pushed selection."
1448 (let ((constraints (mpc-ring-pop mpc-constraints-ring
)))
1449 (if (null constraints
)
1450 (error "No selection to return to")
1451 (mpc-constraints-restore constraints
))))
1453 ;;; The TagBrowser mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1455 (defconst mpc-tagbrowser-all-name
(propertize "*ALL*" 'face
'italic
))
1456 (defvar-local mpc-tagbrowser-all-ol nil
)
1457 (defvar-local mpc-tag-name nil
)
1458 (defun mpc-tagbrowser-all-p ()
1459 (and (eq (point-min) (line-beginning-position))
1460 (equal mpc-tagbrowser-all-name
1461 (buffer-substring (point-min) (line-end-position)))))
1463 (define-derived-mode mpc-tagbrowser-mode mpc-mode
'("MPC-" mpc-tag-name
)
1464 (setq-local mode-line-process
'("" mpc-tag-name
))
1465 (setq-local mode-line-format nil
)
1466 (setq-local header-line-format
'("" mpc-tag-name
)) ;; "s"
1467 (setq-local buffer-undo-list t
)
1470 (defun mpc-tagbrowser-refresh ()
1473 (goto-char (point-min))
1474 (cl-assert (looking-at (regexp-quote mpc-tagbrowser-all-name
)))
1476 (let ((inhibit-read-only t
))
1477 (delete-region (point) (point-max))
1478 (dolist (val (mpc-cmd-list mpc-tag
)) (insert val
"\n")))
1479 (set-buffer-modified-p nil
))
1482 (defun mpc-updated-db ()
1483 ;; FIXME: This is not asynchronous, but is run from a process filter.
1484 (unless (assq 'updating_db mpc-status
)
1485 (clrhash mpc--find-memoize
)
1486 (dolist (buf (process-get (mpc-proc) 'buffers
))
1487 (setq buf
(cdr buf
))
1488 (when (buffer-local-value 'mpc-tag buf
)
1489 (with-current-buffer buf
(with-local-quit (mpc-tagbrowser-refresh)))))
1490 (with-local-quit (mpc-songs-refresh))))
1492 (defun mpc-tagbrowser-tag-name (tag)
1494 ((string-match "|" (symbol-name tag
))
1495 (let ((tag1 (intern (substring (symbol-name tag
)
1496 0 (match-beginning 0))))
1497 (tag2 (intern (substring (symbol-name tag
)
1499 (concat (mpc-tagbrowser-tag-name tag1
)
1501 (mpc-tagbrowser-tag-name tag2
))))
1502 ((string-match "y\\'" (symbol-name tag
))
1503 (concat (substring (symbol-name tag
) 0 -
1) "ies"))
1504 (t (concat (symbol-name tag
) "s"))))
1506 (defun mpc-tagbrowser-buf (tag)
1507 (let ((buf (mpc-proc-buffer (mpc-proc) tag
)))
1508 (if (buffer-live-p buf
) buf
1509 (setq buf
(get-buffer-create (format "*MPC %ss*" tag
)))
1510 (mpc-proc-buffer (mpc-proc) tag buf
)
1511 (with-current-buffer buf
1512 (let ((inhibit-read-only t
))
1514 (if (member tag
'(Directory))
1515 (mpc-tagbrowser-dir-mode)
1516 (mpc-tagbrowser-mode))
1517 (insert mpc-tagbrowser-all-name
"\n"))
1520 (setq mpc-tag-name
(mpc-tagbrowser-tag-name tag
))
1521 (mpc-tagbrowser-all-select)
1522 (mpc-tagbrowser-refresh)
1525 (defvar tag-browser-tagtypes
1526 (lazy-completion-table tag-browser-tagtypes
1528 (append '("Playlist" "Directory")
1529 (mpc-cmd-tagtypes)))))
1531 (defun mpc-tagbrowser (tag)
1532 "Create a new browser for TAG."
1535 (let ((completion-ignore-case t
))
1537 (completing-read "Tag: " tag-browser-tagtypes nil
'require-match
)))))
1538 (let* ((newbuf (mpc-tagbrowser-buf tag
))
1539 (win (get-buffer-window newbuf
0)))
1540 (if win
(select-window win
)
1541 (if (with-current-buffer (window-buffer)
1542 (derived-mode-p 'mpc-tagbrowser-mode
))
1543 (setq win
(selected-window))
1544 ;; Find a tagbrowser-mode buffer.
1545 (let ((buffers (process-get (mpc-proc) 'buffers
))
1549 (not (and (buffer-live-p (setq buffer
(cdr (pop buffers
))))
1550 (with-current-buffer buffer
1551 (derived-mode-p 'mpc-tagbrowser-mode
))
1552 (setq win
(get-buffer-window buffer
0))))))))
1554 (pop-to-buffer newbuf
)
1555 (setq win
(split-window win nil
'horiz
))
1556 (set-window-buffer win newbuf
)
1557 (set-window-dedicated-p win
'soft
)
1559 (balance-windows-area)))))
1561 (defun mpc-tagbrowser-all-select ()
1562 "Select the special *ALL* entry if no other is selected."
1564 (delete-overlay mpc-tagbrowser-all-ol
)
1566 (goto-char (point-min))
1567 (if mpc-tagbrowser-all-ol
1568 (move-overlay mpc-tagbrowser-all-ol
1569 (point) (line-beginning-position 2))
1570 (let ((ol (make-overlay (point) (line-beginning-position 2))))
1571 (overlay-put ol
'face
'highlight
)
1572 (overlay-put ol
'evaporate t
)
1573 (setq-local mpc-tagbrowser-all-ol ol
))))))
1575 ;; (defvar mpc-constraints nil)
1576 (defun mpc-separator (active)
1577 ;; Place a separator mark.
1578 (unless mpc-separator-ol
1579 (setq-local mpc-separator-ol
1580 (make-overlay (point) (point)))
1581 (overlay-put mpc-separator-ol
'after-string
1583 'face
'(:height
0.05 :inverse-video t
))))
1584 (goto-char (point-min))
1587 (and (member (buffer-substring-no-properties
1588 (line-beginning-position) (line-end-position))
1590 (zerop (forward-line 1))))
1591 (if (or (eobp) (null active
))
1592 (delete-overlay mpc-separator-ol
)
1593 (move-overlay mpc-separator-ol
(1- (point)) (point))))
1595 (defun mpc-sort (active)
1596 ;; Sort the active elements at the front.
1597 (let ((inhibit-read-only t
))
1598 (goto-char (point-min))
1599 (if (mpc-tagbrowser-all-p) (forward-line 1))
1601 (sort-subr nil
'forward-line
'end-of-line
1604 (setq s1
(buffer-substring-no-properties
1606 (setq s2
(buffer-substring-no-properties
1610 (if (member s2 active
)
1611 (let ((cmp (mpc-compare-strings s1 s2 t
)))
1612 (and (numberp cmp
) (< cmp
0)))
1614 ((member s2 active
) nil
)
1615 (t (let ((cmp (mpc-compare-strings s1 s2 t
)))
1616 (and (numberp cmp
) (< cmp
0)))))))
1617 ;; The comparison predicate arg is new in Emacs-22.
1618 (wrong-number-of-arguments
1619 (sort-subr nil
'forward-line
'end-of-line
1621 (let ((name (buffer-substring-no-properties
1622 (point) (line-end-position))))
1624 ((member name active
) (concat "1" name
))
1625 (t (concat "2" "name"))))))))))
1627 (defvar mpc--changed-selection
)
1629 (defun mpc-reorder (&optional nodeactivate
)
1630 "Reorder entries based on the currently active selections.
1631 I.e. split the current browser buffer into a first part containing the
1632 entries included in the selection, then a separator, and then the entries
1633 not included in the selection.
1634 Return non-nil if a selection was deactivated."
1636 (let ((constraints (mpc-constraints-get-current (current-buffer)))
1638 ;; (unless (equal constraints mpc-constraints)
1639 ;; (setq-local mpc-constraints constraints)
1640 (dolist (cst constraints
)
1641 (let ((vals (apply 'mpc-union
1642 (mapcar (lambda (val)
1643 (mpc-cmd-list mpc-tag
(car cst
) val
))
1646 (if (listp active
) (mpc-intersection active vals
) vals
))))
1648 (when (listp active
)
1649 ;; Remove the selections if they are all in conflict with
1650 ;; other constraints.
1651 (let ((deactivate t
))
1652 (dolist (sel selection
)
1653 (when (member sel active
) (setq deactivate nil
)))
1655 ;; Variable declared/used by `mpc-select-save'.
1657 (setq mpc--changed-selection t
))
1658 (unless nodeactivate
1659 (setq selection nil
)
1660 (mapc 'delete-overlay mpc-select
)
1661 (setq mpc-select nil
)
1662 (mpc-tagbrowser-all-select))))
1664 ;; Don't bother splitting the "active" elements to the first part if
1665 ;; they're the same as the selection.
1666 (when (equal (sort (copy-sequence active
) #'string-lessp
)
1667 (sort (copy-sequence selection
) #'string-lessp
))
1668 (setq active
'all
)))
1670 ;; FIXME: This `mpc-sort' takes a lot of time. Maybe we should
1671 ;; be more clever and presume the buffer is mostly sorted already.
1672 (mpc-sort (if (listp active
) active
))
1673 (mpc-separator (if (listp active
) active
)))))
1675 (defun mpc-selection-refresh ()
1676 (let ((mpc--changed-selection t
))
1677 (while mpc--changed-selection
1678 (setq mpc--changed-selection nil
)
1679 (dolist (buf (process-get (mpc-proc) 'buffers
))
1680 (setq buf
(cdr buf
))
1681 (when (and (buffer-local-value 'mpc-tag buf
)
1682 (not (eq buf
(current-buffer))))
1683 (with-current-buffer buf
(mpc-reorder)))))
1684 ;; FIXME: reorder the current buffer last and prevent deactivation,
1685 ;; since whatever selection we made here is the most recent one
1686 ;; and should hence take precedence.
1687 (when mpc-tag
(mpc-reorder 'nodeactivate
))
1689 (if (and mpc--song-search mpc--changed-selection
)
1691 (setq mpc--song-search nil
)
1692 (mpc-selection-refresh))
1693 (mpc-songs-refresh))))
1695 ;;; Hierarchical tagbrowser ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1697 ;; - Add a button on each dir to open/close it (?)
1698 ;; - add the parent dir on the previous line, grayed-out, if it's not
1699 ;; present (because we're in the non-selected part and the parent is
1700 ;; in the selected part).
1702 (defvar mpc-tagbrowser-dir-mode-map
1703 (let ((map (make-sparse-keymap)))
1704 (set-keymap-parent map mpc-tagbrowser-mode-map
)
1705 (define-key map
[?\M-\C-m
] 'mpc-tagbrowser-dir-toggle
)
1708 ;; (defvar mpc-tagbrowser-dir-keywords
1709 ;; '(mpc-tagbrowser-dir-hide-prefix))
1711 (define-derived-mode mpc-tagbrowser-dir-mode mpc-tagbrowser-mode
'("MPC-" mpc-tag-name
)
1712 ;; (setq-local font-lock-defaults
1713 ;; '(mpc-tagbrowser-dir-keywords t))
1716 ;; (defun mpc-tagbrowser-dir-hide-prefix (limit)
1718 ;; (let ((prev (buffer-substring (line-beginning-position 0)
1719 ;; (line-end-position 0))))
1722 (defun mpc-tagbrowser-dir-toggle (event)
1723 "Open or close the element at point."
1724 (interactive (list last-nonmenu-event
))
1725 (mpc-event-set-point event
)
1726 (let ((name (buffer-substring (line-beginning-position)
1727 (line-end-position)))
1728 (prop (intern mpc-tag
))
1730 (if (not (member name
(process-get proc prop
)))
1731 (process-put proc prop
1732 (cons name
(process-get proc prop
)))
1733 (let ((new (delete name
(process-get proc prop
))))
1734 (setq name
(concat name
"/"))
1735 (process-put proc prop
1738 (if (string-prefix-p name x
)
1741 (mpc-tagbrowser-refresh)))
1744 ;;; Playlist management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1746 (defvar-local mpc-songs-playlist nil
1747 "Name of the currently selected playlist, if any.
1748 A value of t means the main playlist.")
1750 (defun mpc-playlist-create (name)
1751 "Save current playlist under name NAME."
1752 (interactive "sPlaylist name: ")
1753 (mpc-proc-cmd (list "save" name
))
1754 (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist
)))
1755 (when (buffer-live-p buf
)
1756 (with-current-buffer buf
(mpc-tagbrowser-refresh)))))
1758 (defun mpc-playlist-destroy (name)
1759 "Delete playlist named NAME."
1761 (list (completing-read "Delete playlist: " (mpc-cmd-list 'Playlist
)
1762 nil
'require-match
)))
1763 (mpc-proc-cmd (list "rm" name
))
1764 (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist
)))
1765 (when (buffer-live-p buf
)
1766 (with-current-buffer buf
(mpc-tagbrowser-refresh)))))
1768 (defun mpc-playlist-rename (oldname newname
)
1769 "Rename playlist OLDNAME to NEWNAME."
1771 (let* ((oldname (if (and (eq mpc-tag
'Playlist
) (null current-prefix-arg
))
1772 (buffer-substring (line-beginning-position)
1773 (line-end-position))
1774 (completing-read "Rename playlist: "
1775 (mpc-cmd-list 'Playlist
)
1776 nil
'require-match
)))
1777 (newname (read-string (format-message "Rename `%s' to: " oldname
))))
1778 (if (zerop (length newname
))
1780 (list oldname newname
))))
1781 (mpc-proc-cmd (list "rename" oldname newname
))
1782 (let ((buf (mpc-proc-buffer (mpc-proc) 'Playlist
)))
1783 (if (buffer-live-p buf
)
1784 (with-current-buffer buf
(mpc-tagbrowser-refresh)))))
1786 (defun mpc-playlist ()
1787 "Show the current playlist."
1789 (mpc-constraints-push 'noerror
)
1790 (mpc-constraints-restore '()))
1792 (defun mpc-playlist-add ()
1793 "Add the selection to the playlist."
1795 (let ((songs (mapcar #'car
(mpc-songs-selection))))
1797 (message "Appended %d songs" (length songs
))
1798 ;; Return the songs added. Used in `mpc-play'.
1801 (defun mpc-playlist-delete ()
1802 "Remove the selected songs from the playlist."
1804 (unless mpc-songs-playlist
1805 (error "The selected songs aren't part of a playlist"))
1806 (let ((song-poss (mapcar #'cdr
(mpc-songs-selection))))
1807 (mpc-cmd-delete song-poss mpc-songs-playlist
)
1809 (message "Deleted %d songs" (length song-poss
))))
1811 ;;; Volume management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1813 (defvar mpc-volume-map
1814 (let ((map (make-sparse-keymap)))
1815 ;; Bind the up-events rather than the down-event, so the
1816 ;; `message' isn't canceled by the subsequent up-event binding.
1817 (define-key map
[down-mouse-1
] 'ignore
)
1818 (define-key map
[mouse-1
] 'mpc-volume-mouse-set
)
1819 (define-key map
[header-line mouse-1
] 'mpc-volume-mouse-set
)
1820 (define-key map
[header-line down-mouse-1
] 'ignore
)
1821 (define-key map
[mode-line mouse-1
] 'mpc-volume-mouse-set
)
1822 (define-key map
[mode-line down-mouse-1
] 'ignore
)
1825 (defvar mpc-volume nil
) (put 'mpc-volume
'risky-local-variable t
)
1827 (defun mpc-volume-refresh ()
1828 ;; Maintain the volume.
1831 (string-to-number (cdr (assq 'volume mpc-status
)))))
1832 (let ((status-buf (mpc-proc-buffer (mpc-proc) 'status
)))
1833 (when (buffer-live-p status-buf
)
1834 (with-current-buffer status-buf
(force-mode-line-update)))))
1836 (defvar mpc-volume-step
5)
1838 (defun mpc-volume-mouse-set (&optional event
)
1839 "Change volume setting."
1840 (interactive (list last-nonmenu-event
))
1841 (let* ((posn (event-start event
))
1843 (if (memq (if (stringp (car-safe (posn-object posn
)))
1844 (aref (car (posn-object posn
)) (cdr (posn-object posn
)))
1845 (with-current-buffer (window-buffer (posn-window posn
))
1846 (char-after (posn-point posn
))))
1848 (- mpc-volume-step
) mpc-volume-step
))
1849 (curvol (string-to-number (cdr (assq 'volume mpc-status
))))
1850 (newvol (max 0 (min 100 (+ curvol diff
)))))
1851 (if (= newvol curvol
)
1853 (message "MPD volume already at %s%%" newvol
)
1855 (mpc-proc-cmd (list "setvol" newvol
) 'mpc-status-refresh
)
1856 (message "Set MPD volume to %s%%" newvol
))))
1858 (defun mpc-volume-widget (vol &optional size
)
1859 (unless size
(setq size
12.5))
1860 (let ((scaledvol (* (/ vol
100.0) size
)))
1861 ;; (message "Volume sizes: %s - %s" (/ vol fact) (/ (- 100 vol) fact))
1862 (list (propertize "<" ;; "◁"
1864 'keymap mpc-volume-map
1865 'face
'(:box
(:line-width -
2 :style pressed-button
))
1866 'mouse-face
'(:box
(:line-width -
2 :style released-button
)))
1869 'display
(list 'space
:width scaledvol
)
1870 'face
'(:inverse-video t
1871 :box
(:line-width -
2 :style released-button
)))
1873 'display
(list 'space
:width
(- size scaledvol
))
1874 'face
'(:box
(:line-width -
2 :style released-button
)))
1876 (propertize ">" ;; "▷"
1878 'keymap mpc-volume-map
1879 'face
'(:box
(:line-width -
2 :style pressed-button
))
1880 'mouse-face
'(:box
(:line-width -
2 :style released-button
))))))
1882 ;;; MPC songs mode ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1884 (defvar mpc-current-song nil
) (put 'mpc-current-song
'risky-local-variable t
)
1885 (defvar mpc-current-updating nil
) (put 'mpc-current-updating
'risky-local-variable t
)
1886 (defvar mpc-songs-format-description nil
) (put 'mpc-songs-format-description
'risky-local-variable t
)
1888 (defvar mpc-previous-window-config nil
)
1890 (defvar mpc-songs-mode-map
1891 (let ((map (make-sparse-keymap)))
1892 (define-key map
[remap mpc-select
] 'mpc-songs-jump-to
)
1895 (defvar mpc-songpointer-set-visible nil
)
1897 (defvar mpc-songs-hashcons
(make-hash-table :test
'equal
:weakness t
)
1898 "Make song file name objects unique via hash consing.
1899 This is used so that they can be compared with `eq', which is needed for
1900 `text-property-any'.")
1901 (defun mpc-songs-hashcons (name)
1902 (or (gethash name mpc-songs-hashcons
) (puthash name name mpc-songs-hashcons
)))
1903 (defcustom mpc-songs-format
"%2{Disc--}%3{Track} %-5{Time} %25{Title} %20{Album} %20{Artist} %5{Date}"
1904 "Format used to display each song in the list of songs."
1907 (defvar mpc-songs-totaltime
)
1909 (defun mpc-songs-refresh ()
1910 (let ((buf (mpc-proc-buffer (mpc-proc) 'songs
)))
1911 (when (buffer-live-p buf
)
1912 (with-current-buffer buf
1913 (let ((constraints (mpc-constraints-get-current (current-buffer)))
1915 (inhibit-read-only t
)
1917 (curline (cons (count-lines (point-min)
1918 (line-beginning-position))
1919 (buffer-substring (line-beginning-position)
1920 (line-end-position))))
1922 (setq mpc-songs-playlist nil
)
1923 (if (null constraints
)
1924 ;; When there are no constraints, rather than show the list of
1925 ;; all songs (which could take a while to download and
1926 ;; format), we show the current playlist.
1927 ;; FIXME: it would be good to be able to show the complete
1928 ;; list, but that would probably require us to format it
1929 ;; on-the-fly to make it bearable.
1931 mpc-songs-playlist t
1932 active
(mpc-proc-buf-to-alists
1933 (mpc-proc-cmd "playlistinfo")))
1934 (dolist (cst constraints
)
1935 (if (and (eq (car cst
) 'Playlist
)
1936 (= 1 (length (cdr cst
))))
1937 (setq mpc-songs-playlist
(cadr cst
)))
1938 ;; We don't do anything really special here for playlists,
1939 ;; because it's unclear what's a correct "union" of playlists.
1940 (let ((vals (apply 'mpc-union
1941 (mapcar (lambda (val)
1942 (mpc-cmd-find (car cst
) val
))
1946 (if (eq (car cst
) 'Playlist
)
1950 ;; Try to preserve ordering and
1951 ;; repetitions from playlists.
1952 (not (eq (car cst
) 'Playlist
)))
1953 (mpc-intersection active vals
1954 (lambda (x) (assq 'file x
))))
1957 (mpc-intersection vals active
1959 (assq 'file x
)))))))))
1962 ;; Sorting songs is surprisingly difficult: when comparing two
1963 ;; songs with the same album name but different artist name, you
1964 ;; have to know whether these are two different albums (with the
1965 ;; same name) or a single album (typically a compilation).
1966 ;; I punt on it and just use file-name sorting, which does the
1967 ;; right thing if your library is properly arranged.
1968 (dolist (song (if dontsort active
1969 (sort (copy-sequence active
)
1970 (lambda (song1 song2
)
1971 (let ((cmp (mpc-compare-strings
1972 (cdr (assq 'file song1
))
1973 (cdr (assq 'file song2
)))))
1974 (and (integerp cmp
) (< cmp
0)))))))
1975 (cl-incf totaltime
(string-to-number (or (cdr (assq 'Time song
)) "0")))
1976 (mpc-format mpc-songs-format song
)
1977 (delete-char (- (skip-chars-backward " "))) ;Remove trailing space.
1980 (line-beginning-position 0) (line-beginning-position)
1981 'mpc-file
(mpc-songs-hashcons (cdr (assq 'file song
))))
1982 (let ((pos (assq 'Pos song
)))
1985 (line-beginning-position 0) (line-beginning-position)
1986 'mpc-file-pos
(string-to-number (cdr pos
)))))
1988 (goto-char (point-min))
1989 (forward-line (car curline
))
1990 (if (or (search-forward (cdr curline
) nil t
)
1991 (search-backward (cdr curline
) nil t
))
1993 (goto-char (point-min)))
1994 (setq-local mpc-songs-totaltime
1995 (unless (zerop totaltime
)
1996 (list " " (mpc-secs-to-time totaltime
))))
1998 (let ((mpc-songpointer-set-visible t
))
1999 (mpc-songpointer-refresh)))
2001 (defun mpc-songs-search (string)
2002 "Filter songs to those who include STRING in their metadata."
2003 (interactive "sSearch for: ")
2004 (setq mpc--song-search
2005 (if (zerop (length string
)) nil string
))
2006 (let ((mpc--changed-selection t
))
2007 (while mpc--changed-selection
2008 (setq mpc--changed-selection nil
)
2009 (dolist (buf (process-get (mpc-proc) 'buffers
))
2010 (setq buf
(cdr buf
))
2011 (when (buffer-local-value 'mpc-tag buf
)
2012 (with-current-buffer buf
(mpc-reorder))))
2013 (mpc-songs-refresh))))
2015 (defun mpc-songs-kill-search ()
2016 "Turn off the current search restriction."
2018 (mpc-songs-search nil
))
2020 (defun mpc-songs-selection ()
2021 "Return the list of songs currently selected."
2022 (let ((buf (mpc-proc-buffer (mpc-proc) 'songs
)))
2023 (when (buffer-live-p buf
)
2024 (with-current-buffer buf
2028 (dolist (ol mpc-select
)
2030 (get-text-property (overlay-start ol
) 'mpc-file
)
2031 (get-text-property (overlay-start ol
) 'mpc-file-pos
))
2033 (goto-char (point-min))
2036 (get-text-property (point) 'mpc-file
)
2037 (get-text-property (point) 'mpc-file-pos
))
2040 (nreverse files
)))))))
2042 (defun mpc-songs-jump-to (song-file &optional posn
)
2043 "Jump to song SONG-FILE; interactively, this is the song at point."
2045 (let* ((event last-nonmenu-event
)
2046 (posn (event-end event
)))
2047 (with-selected-window (posn-window posn
)
2048 (goto-char (posn-point posn
))
2049 (list (get-text-property (point) 'mpc-file
)
2051 (let* ((plbuf (mpc-proc-cmd "playlist"))
2053 ;; Newer MPCs apparently include "file: " in the buffer.
2054 (concat "^\\([0-9]+\\):\\(?:file: \\)?"
2055 (regexp-quote song-file
) "$")))
2056 (sn (with-current-buffer plbuf
2057 (goto-char (point-min))
2058 (when (and re
(re-search-forward re nil t
))
2059 (match-string 1)))))
2061 ((null re
) (posn-set-point posn
))
2062 ((null sn
) (user-error "This song is not in the playlist"))
2063 ((null (with-current-buffer plbuf
(re-search-forward re nil t
)))
2064 ;; song-file only appears once in the playlist: no ambiguity,
2065 ;; we're good to go!
2066 (mpc-proc-cmd (list "play" sn
)))
2068 ;; The song appears multiple times in the playlist. If the current
2069 ;; buffer holds not only the destination song but also the current
2070 ;; song, then we will move in the playlist to the same relative
2071 ;; position as in the buffer. Otherwise, we will simply choose the
2072 ;; song occurrence closest to the current song.
2073 (with-selected-window (posn-window posn
)
2074 (let* ((cur (and (markerp overlay-arrow-position
)
2075 (marker-position overlay-arrow-position
)))
2076 (dest (save-excursion
2077 (goto-char (posn-point posn
))
2078 (line-beginning-position)))
2079 (lines (when cur
(* (if (< cur dest
) 1 -
1)
2080 (count-lines cur dest
)))))
2081 (with-current-buffer plbuf
2082 (goto-char (point-min))
2083 ;; Start the search from the current song.
2084 (forward-line (string-to-number
2085 (or (cdr (assq 'song mpc-status
)) "0")))
2086 ;; If the current song is also displayed in the buffer,
2087 ;; then try to move to the same relative position.
2088 (if lines
(forward-line lines
))
2089 ;; Now search the closest occurrence.
2090 (let* ((next (save-excursion
2091 (when (re-search-forward re nil t
)
2092 (cons (point) (match-string 1)))))
2093 (prev (save-excursion
2094 (when (re-search-backward re nil t
)
2095 (cons (point) (match-string 1)))))
2096 (sn (cdr (if (and next prev
)
2097 (if (< (- (car next
) (point))
2098 (- (point) (car prev
)))
2102 (mpc-proc-cmd (concat "play " sn
))))))))))
2104 (define-derived-mode mpc-songs-mode mpc-mode
"MPC-song"
2105 (setq mpc-songs-format-description
2106 (with-temp-buffer (mpc-format mpc-songs-format
'self
) (buffer-string)))
2107 (setq-local header-line-format
2108 ;; '("MPC " mpc-volume " " mpc-current-song)
2109 (list (propertize " " 'display
'(space :align-to
0))
2110 ;; 'mpc-songs-format-description
2112 (let ((hscroll (window-hscroll)))
2114 (mpc-format mpc-songs-format
'self hscroll
)
2115 ;; That would be simpler than the hscroll handling in
2116 ;; mpc-format, but currently move-to-column does not
2117 ;; recognize :space display properties.
2118 ;; (move-to-column hscroll)
2119 ;; (delete-region (point-min) (point))
2120 (buffer-string))))))
2123 '("%e" mode-line-frame-identification mode-line-buffer-identification
2125 (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
2128 (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
2130 mpc-current-updating
2132 (help-echo "mouse-1: Select (drag to resize)\nmouse-2: Make current window occupy the whole frame\nmouse-3: Remove current window from display"))
2135 ("Search=\"" mpc--song-search
"\"")
2136 help-echo
"mouse-2: kill this search"
2138 mouse-face mode-line-highlight
2139 keymap
(keymap (mode-line keymap
2140 (mouse-2 . mpc-songs-kill-search
))))
2141 (:propertize
"NoSearch"
2142 help-echo
"mouse-2: set a search restriction"
2144 mouse-face mode-line-highlight
2145 keymap
(keymap (mode-line keymap
(mouse-2 . mpc-songs-search
)))))))
2147 ;; (setq-local mode-line-process
2148 ;; '("" ;; mpc-volume " "
2149 ;; mpc-songs-totaltime
2150 ;; mpc-current-updating))
2153 (defun mpc-songpointer-set (pos)
2154 (let* ((win (get-buffer-window (current-buffer) t
))
2156 (or mpc-songpointer-set-visible
2157 (and (markerp overlay-arrow-position
)
2158 (eq (marker-buffer overlay-arrow-position
)
2160 (<= (window-start win
) overlay-arrow-position
)
2161 (< overlay-arrow-position
(window-end win
)))))))
2162 (unless (local-variable-p 'overlay-arrow-position
)
2163 (setq-local overlay-arrow-position
(make-marker)))
2164 (move-marker overlay-arrow-position pos
)
2165 ;; If the arrow was visible, try to keep it that way.
2166 (if (and visible pos
2167 (or (> (window-start win
) pos
) (>= pos
(window-end win t
))))
2168 (set-window-point win pos
))))
2170 (defun mpc-songpointer-refresh ()
2171 (let ((buf (mpc-proc-buffer (mpc-proc) 'songs
)))
2172 (when (buffer-live-p buf
)
2173 (with-current-buffer buf
2174 (let* ((pos (text-property-any
2175 (point-min) (point-max)
2176 'mpc-file
(mpc-songs-hashcons
2177 (cdr (assq 'file mpc-status
)))))
2182 (line-beginning-position 2) (point-max)
2183 'mpc-file
(mpc-songs-hashcons
2184 (cdr (assq 'file mpc-status
))))))))
2186 ;; The song appears multiple times in the buffer.
2187 ;; We need to be careful to choose the right occurrence.
2188 (mpc-proc-cmd "playlist" 'mpc-songpointer-refresh-hairy
)
2189 (mpc-songpointer-set pos
)))))))
2191 (defun mpc-songpointer-context (size plbuf
)
2192 (with-current-buffer plbuf
2193 (goto-char (point-min))
2194 (forward-line (string-to-number (or (cdr (assq 'song mpc-status
)) "0")))
2195 (let ((context-before '())
2196 (context-after '()))
2199 (when (re-search-backward "^[0-9]+:\\(.*\\)" nil t
)
2200 (push (mpc-songs-hashcons (match-string 1)) context-before
))))
2201 ;; Skip the actual current song.
2204 (when (re-search-forward "^[0-9]+:\\(.*\\)" nil t
)
2205 (push (mpc-songs-hashcons (match-string 1)) context-after
)))
2206 ;; If there isn't `size' context, then return nil.
2207 (unless (and (< (length context-before
) size
)
2208 (< (length context-after
) size
))
2209 (cons (nreverse context-before
) (nreverse context-after
))))))
2211 (defun mpc-songpointer-score (context pos
)
2214 (dolist (song (car context
))
2215 (and (zerop (forward-line -
1))
2216 (eq (get-text-property (point) 'mpc-file
) song
)
2219 (dolist (song (cdr context
))
2220 (and (zerop (forward-line 1))
2221 (eq (get-text-property (point) 'mpc-file
) song
)
2225 (defun mpc-songpointer-refresh-hairy ()
2226 ;; Based on the complete playlist, we should figure out where in the
2227 ;; song buffer is the currently playing song.
2228 (let ((plbuf (current-buffer))
2229 (buf (mpc-proc-buffer (mpc-proc) 'songs
)))
2230 (when (buffer-live-p buf
)
2231 (with-current-buffer buf
2232 (let* ((context-size 0)
2233 (context '(() .
()))
2234 (pos (text-property-any
2235 (point-min) (point-max)
2236 'mpc-file
(mpc-songs-hashcons
2237 (cdr (assq 'file mpc-status
)))))
2245 (line-beginning-position 2) (point-max)
2246 'mpc-file
(mpc-songs-hashcons
2247 (cdr (assq 'file mpc-status
))))))
2248 ;; There is an `other' contestant.
2249 (let ((other-score (mpc-songpointer-score context other
)))
2251 ;; `other' is worse: try the next one.
2252 ((< other-score score
) nil
)
2253 ;; `other' is better: remember it and then search further.
2254 ((> other-score score
)
2256 (setq score other-score
))
2257 ;; Both are equal and increasing the context size won't help.
2258 ;; Arbitrarily choose one of the two and keep looking
2259 ;; for a better match.
2260 ((< score context-size
) nil
)
2262 ;; Score is equal and increasing context might help: try it.
2263 (cl-incf context-size
)
2265 (mpc-songpointer-context context-size plbuf
)))
2266 (if (null new-context
)
2267 ;; There isn't more context: choose one arbitrarily
2268 ;; and keep looking for a better match elsewhere.
2269 (cl-decf context-size
)
2270 (setq context new-context
)
2271 (setq score
(mpc-songpointer-score context pos
))
2274 ;; Go back one line so we find `other' again.
2275 (setq other
(line-beginning-position 0)))))))))
2276 (mpc-songpointer-set pos
))))))
2278 (defun mpc-current-refresh ()
2279 ;; Maintain the current data.
2280 (mpc-status-buffer-refresh)
2281 (setq mpc-current-updating
2282 (if (assq 'updating_db mpc-status
) " Updating-DB"))
2284 (setq mpc-current-song
2285 (when (assq 'file mpc-status
)
2287 (mpc-secs-to-time (cdr (assq 'time mpc-status
)))
2289 (cdr (assq 'Title mpc-status
))
2291 (cdr (assq 'Artist mpc-status
))
2293 (cdr (assq 'Album mpc-status
))
2295 (force-mode-line-update t
))
2297 (defun mpc-songs-buf ()
2298 (let ((buf (mpc-proc-buffer (mpc-proc) 'songs
)))
2299 (if (buffer-live-p buf
) buf
2300 (with-current-buffer (setq buf
(get-buffer-create "*MPC-Songs*"))
2301 (mpc-proc-buffer (mpc-proc) 'songs buf
)
2305 (defun mpc-update ()
2306 "Tell MPD to refresh its database."
2311 "Quit Music Player Daemon."
2313 (let* ((proc mpc-proc
)
2314 (bufs (mapcar 'cdr
(if proc
(process-get proc
'buffers
))))
2315 (wins (mapcar (lambda (buf) (get-buffer-window buf
0)) bufs
))
2316 (song-buf (mpc-songs-buf))
2318 ;; Collect all the frames where MPC buffers appear.
2320 (when (and win
(not (memq (window-frame win
) frames
)))
2321 (push (window-frame win
) frames
)))
2322 (if (and frames song-buf
2323 (with-current-buffer song-buf mpc-previous-window-config
))
2325 (select-frame (car frames
))
2326 (set-window-configuration
2327 (with-current-buffer song-buf mpc-previous-window-config
)))
2328 ;; Now delete the ones that show nothing else than MPC buffers.
2329 (dolist (frame frames
)
2331 (dolist (win (window-list frame
))
2332 (unless (memq (window-buffer win
) bufs
) (setq delete nil
)))
2333 (if delete
(ignore-errors (delete-frame frame
))))))
2334 ;; Then kill the buffers.
2335 (mapc 'kill-buffer bufs
)
2337 (if proc
(delete-process proc
))))
2340 "Stop playing the current queue of songs."
2344 (mpc-status-refresh))
2349 (mpc-cmd-pause "1"))
2351 (defun mpc-resume ()
2354 (mpc-cmd-pause "0"))
2356 (defun mpc-toggle-play ()
2357 "Toggles between play and pause.
2358 If stopped, start playback."
2360 (if (member (cdr (assq 'state
(mpc-cmd-status))) '("stop"))
2362 (if (member (cdr (assq 'state
(mpc-cmd-status))) '("pause"))
2367 "Start playing whatever is selected."
2369 (if (member (cdr (assq 'state
(mpc-cmd-status))) '("pause"))
2371 ;; When playing the playlist ends, the playlist isn't cleared, but the
2372 ;; user probably doesn't want to re-listen to it before getting to
2373 ;; listen to what he just selected.
2374 ;; (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop"))
2376 ;; Actually, we don't use mpc-play to append to the playlist any more,
2377 ;; so we can just always empty the playlist.
2379 (if (mpc-playlist-add)
2380 (if (member (cdr (assq 'state
(mpc-cmd-status))) '("stop"))
2382 (user-error "Don't know what to play"))))
2385 "Jump to the next song in the queue."
2387 (mpc-proc-cmd "next")
2388 (mpc-status-refresh))
2391 "Jump to the beginning of the current song, or to the previous song."
2393 (let ((time (cdr (assq 'time mpc-status
))))
2394 ;; Here we rely on the fact that string-to-number silently ignores
2395 ;; everything after a non-digit char.
2397 ;; Go back to the beginning of current song.
2398 ((and time
(> (string-to-number time
) 0))
2399 (mpc-proc-cmd (list "seekid" (cdr (assq 'songid mpc-status
)) 0)))
2400 ;; We're at the beginning of the first song of the playlist.
2401 ;; Fetch the previous one from `mpc-queue-back'.
2402 ;; ((and (zerop (string-to-number (cdr (assq 'song mpc-status))))
2404 ;; ;; Because we use cmd-list rather than cmd-play, the queue is not
2405 ;; ;; automatically updated.
2406 ;; (let ((prev (pop mpc-queue-back)))
2407 ;; (push prev mpc-queue)
2409 ;; (mpc-proc-cmd-list
2410 ;; (list (list "add" prev)
2411 ;; (list "move" (cdr (assq 'playlistlength mpc-status)) "0")
2413 ;; We're at the beginning of a song, but not the first one.
2414 (t (mpc-proc-cmd "previous")))
2415 (mpc-status-refresh)))
2417 (defvar mpc-last-seek-time
'(0 .
0))
2419 (defun mpc--faster (event speedup step
)
2421 (interactive (list last-nonmenu-event
))
2422 (let ((repeat-delay (/ (abs (float step
)) speedup
)))
2423 (if (not (memq 'down
(event-modifiers event
)))
2424 (let* ((currenttime (float-time))
2425 (last-time (- currenttime
(car mpc-last-seek-time
))))
2426 (if (< last-time
(* 0.9 repeat-delay
))
2428 (let* ((status (if (< last-time
1.0)
2429 mpc-status
(mpc-cmd-status)))
2430 (songid (cdr (assq 'songid status
)))
2432 (if (< last-time
1.0)
2433 (cdr mpc-last-seek-time
)
2435 (cdr (assq 'time status
)))))))
2436 (setq mpc-last-seek-time
2437 (cons currenttime
(setq time
(+ time step
))))
2438 (mpc-proc-cmd (list "seekid" songid time
)
2439 'mpc-status-refresh
))))
2440 (let ((status (mpc-cmd-status)))
2441 (let* ((songid (cdr (assq 'songid status
)))
2442 (time (if songid
(string-to-number
2443 (cdr (assq 'time status
))))))
2444 (let ((timer (run-with-timer
2447 (mpc-proc-cmd (list "seekid" songid
2448 (setq time
(+ time step
)))
2449 'mpc-status-refresh
)))))
2450 (while (mouse-movement-p
2451 (event-basic-type (setq event
(read-event)))))
2452 (cancel-timer timer
)))))))
2454 (defvar mpc--faster-toggle-timer nil
)
2455 (defun mpc--faster-stop ()
2456 (when mpc--faster-toggle-timer
2457 (cancel-timer mpc--faster-toggle-timer
)
2458 (setq mpc--faster-toggle-timer nil
)))
2460 (defun mpc--faster-toggle-refresh ()
2461 (if (equal (cdr (assq 'state mpc-status
)) "stop")
2462 (mpc--faster-stop)))
2464 (defun mpc--songduration ()
2466 (let ((s (cdr (assq 'time mpc-status
))))
2467 (if (not (string-match ":" s
))
2468 (error "Unexpected time format %S" s
)
2469 (substring s
(match-end 0))))))
2471 (defvar mpc--faster-toggle-forward nil
)
2472 (defvar mpc--faster-acceleration
0.5)
2473 (defun mpc--faster-toggle (speedup step
)
2474 (setq speedup
(float speedup
))
2475 (if mpc--faster-toggle-timer
2477 (mpc-status-refresh) (mpc-proc-sync)
2478 (let* (songid ;The ID of the currently ffwd/rewinding song.
2479 songduration
;The duration of that song.
2480 songtime
;The time of the song last time we ran.
2481 oldtime
;The time of day last time we ran.
2482 prevsongid
) ;The song we're in the process leaving.
2485 (let ((newsongid (cdr (assq 'songid mpc-status
))))
2487 (if (and (equal prevsongid newsongid
)
2488 (not (equal prevsongid songid
)))
2489 ;; We left prevsongid and came back to it. Pretend it
2491 (setq newsongid songid
))
2494 ((null newsongid
) (mpc--faster-stop))
2495 ((not (equal songid newsongid
))
2496 ;; We jumped to another song: reset.
2497 (setq songid newsongid
)
2498 (setq songtime
(string-to-number
2499 (cdr (assq 'time mpc-status
))))
2500 (setq songduration
(mpc--songduration))
2501 (setq oldtime
(float-time)))
2502 ((and (>= songtime songduration
) mpc--faster-toggle-forward
)
2503 ;; Skip to the beginning of the next song.
2504 (if (not (equal (cdr (assq 'state mpc-status
)) "play"))
2505 (mpc-proc-cmd "next" 'mpc-status-refresh
)
2506 ;; If we're playing, this is done automatically, so we
2507 ;; don't need to do anything, or rather we *shouldn't*
2508 ;; do anything otherwise there's a race condition where
2509 ;; we could skip straight to the next next song.
2511 ((and (<= songtime
0) (not mpc--faster-toggle-forward
))
2512 ;; Skip to the end of the previous song.
2513 (setq prevsongid songid
)
2514 (mpc-proc-cmd "previous"
2518 (setq songid
(cdr (assq 'songid mpc-status
)))
2519 (setq songtime
(setq songduration
(mpc--songduration)))
2520 (setq oldtime
(float-time))
2521 (mpc-proc-cmd (list "seekid" songid songtime
)))))))
2523 (setq speedup
(+ speedup mpc--faster-acceleration
))
2525 (truncate (* speedup
(- (float-time) oldtime
)))))
2526 (if (<= newstep
1) (setq newstep
1))
2527 (setq oldtime
(+ oldtime
(/ newstep speedup
)))
2528 (if (not mpc--faster-toggle-forward
)
2529 (setq newstep
(- newstep
)))
2530 (setq songtime
(min songduration
(+ songtime newstep
)))
2531 (unless (>= songtime songduration
)
2534 (list "seekid" songid songtime
)
2535 'mpc-status-refresh
)
2536 (mpc-proc-error (mpc-status-refresh)))))))))))
2537 (setq mpc--faster-toggle-forward
(> step
0))
2538 (funcall fun
) ;Initialize values.
2539 (setq mpc--faster-toggle-timer
2540 (run-with-timer t
0.3 fun
))))))
2544 (defvar mpc-faster-speedup
8)
2546 (defun mpc-ffwd (_event)
2548 (interactive (list last-nonmenu-event
))
2549 ;; (mpc--faster event 4.0 1)
2550 (mpc--faster-toggle mpc-faster-speedup
1))
2552 (defun mpc-rewind (_event)
2554 (interactive (list last-nonmenu-event
))
2555 ;; (mpc--faster event 4.0 -1)
2556 (mpc--faster-toggle mpc-faster-speedup -
1))
2559 (defun mpc-play-at-point (&optional event
)
2560 (interactive (list last-nonmenu-event
))
2564 ;; (defun mpc-play-tagval ()
2565 ;; "Play all the songs of the tag at point."
2567 ;; (let* ((val (buffer-substring (line-beginning-position) (line-end-position)))
2568 ;; (songs (mapcar 'cdar
2569 ;; (mpc-proc-buf-to-alists
2570 ;; (mpc-proc-cmd (list "find" mpc-tag val))))))
2571 ;; (mpc-cmd-add songs)
2572 ;; (if (member (cdr (assq 'state (mpc-cmd-status))) '("stop"))
2573 ;; (mpc-cmd-play))))
2575 ;;; Drag'n'drop support ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2577 ;; the main thing to do here, is to provide visual feedback during the drag:
2578 ;; - change the mouse-cursor.
2579 ;; - highlight/select the source and the current destination.
2581 (defun mpc-drag-n-drop (event)
2582 "DWIM for a drag EVENT."
2584 (let* ((start (event-start event
))
2585 (end (event-end event
))
2586 (start-buf (window-buffer (posn-window start
)))
2587 (end-buf (window-buffer (posn-window end
)))
2589 (with-current-buffer start-buf
2590 (goto-char (posn-point start
))
2591 (if (get-text-property (point) 'mpc-select
)
2592 ;; FIXME: actually we should only consider the constraints
2593 ;; corresponding to the selection in this particular buffer.
2594 (mpc-songs-selection)
2596 ((and (derived-mode-p 'mpc-songs-mode
)
2597 (get-text-property (point) 'mpc-file
))
2598 (list (cons (get-text-property (point) 'mpc-file
)
2599 (get-text-property (point) 'mpc-file-pos
))))
2600 ((and mpc-tag
(not (mpc-tagbrowser-all-p)))
2601 (mapcar (lambda (song)
2602 (list (cdr (assq 'file song
))))
2605 (buffer-substring (line-beginning-position)
2606 (line-end-position)))))
2608 (error "Unsupported starting position for drag'n'drop gesture")))))))
2609 (with-current-buffer end-buf
2610 (goto-char (posn-point end
))
2612 ((eq mpc-tag
'Playlist
)
2613 ;; Adding elements to a named playlist.
2614 (let ((playlist (if (or (mpc-tagbrowser-all-p)
2615 (and (bolp) (eolp)))
2616 (error "Not a playlist")
2617 (buffer-substring (line-beginning-position)
2618 (line-end-position)))))
2619 (mpc-cmd-add (mapcar 'car songs
) playlist
)
2620 (message "Added %d songs to %s" (length songs
) playlist
)
2621 (if (member playlist
2622 (cdr (assq 'Playlist
(mpc-constraints-get-current))))
2623 (mpc-songs-refresh))))
2624 ((derived-mode-p 'mpc-songs-mode
)
2626 ((null mpc-songs-playlist
)
2627 (error "The songs shown do not belong to a playlist"))
2628 ((eq start-buf end-buf
)
2629 ;; Moving songs within the shown playlist.
2630 (let ((dest-pos (get-text-property (point) 'mpc-file-pos
)))
2631 (mpc-cmd-move (mapcar 'cdr songs
) dest-pos mpc-songs-playlist
)
2632 (message "Moved %d songs" (length songs
))))
2634 ;; Adding songs to the shown playlist.
2635 (let ((dest-pos (get-text-property (point) 'mpc-file-pos
))
2636 (pl (if (stringp mpc-songs-playlist
)
2637 (mpc-cmd-find 'Playlist mpc-songs-playlist
)
2638 (mpc-proc-cmd-to-alist "playlist"))))
2639 ;; MPD's protocol does not let us add songs at a particular
2640 ;; position in a playlist, so we first have to add them to the
2641 ;; end, and then move them to their final destination.
2642 (mpc-cmd-add (mapcar 'car songs
) mpc-songs-playlist
)
2643 (mpc-cmd-move (let ((poss '()))
2644 (dotimes (i (length songs
))
2645 (push (+ i
(length pl
)) poss
))
2647 dest-pos mpc-songs-playlist
)
2648 (message "Added %d songs" (length songs
)))))
2649 (mpc-songs-refresh))
2651 (error "Unsupported drag'n'drop gesture"))))))
2653 ;;; Toplevel ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2655 (defcustom mpc-frame-alist
'((name .
"MPC") (tool-bar-lines .
1)
2657 "Alist of frame parameters for the MPC frame."
2662 "Main entry point for MPC."
2665 (if current-prefix-arg
2666 ;; FIXME: We should provide some completion here, especially for the
2667 ;; case where the user specifies a local socket/file name.
2668 (setq mpc-host
(read-string "MPD host and port: " nil nil mpc-host
)))
2670 (let* ((song-buf (mpc-songs-buf))
2671 (song-win (get-buffer-window song-buf
0)))
2673 (select-window song-win
)
2674 (if (or (window-dedicated-p) (window-minibuffer-p))
2675 (ignore-errors (select-frame (make-frame mpc-frame-alist
)))
2676 (with-current-buffer song-buf
2677 (setq-local mpc-previous-window-config
2678 (current-window-configuration))))
2679 (let* ((win1 (selected-window))
2680 (win2 (split-window))
2681 (tags mpc-browser-tags
))
2682 (unless tags
(error "Need at least one entry in `mpc-browser-tags'"))
2683 (set-window-buffer win2 song-buf
)
2684 (set-window-dedicated-p win2
'soft
)
2685 (mpc-status-buffer-show)
2688 (set-window-buffer win1
(mpc-tagbrowser-buf (pop tags
)))
2689 (set-window-dedicated-p win1
'soft
)
2691 (setq win1
(split-window win1 nil
'horiz
)))))
2692 (balance-windows-area))
2694 (mpc-status-refresh))
2698 ;;; mpc.el ends here