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