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