aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorStefan Monnier2009-12-01 04:04:33 +0000
committerStefan Monnier2009-12-01 04:04:33 +0000
commite1ada2225c15dd39d36f57b0f655c41e7c438f01 (patch)
tree10eab0ddff38d36f95a7752338d9196e7366f336
parent3689984f0081b32ceae6668974a1e04231f6d728 (diff)
downloademacs-e1ada2225c15dd39d36f57b0f655c41e7c438f01.tar.gz
emacs-e1ada2225c15dd39d36f57b0f655c41e7c438f01.zip
* mpc.el: New file.
Diffstat
-rw-r--r--etc/NEWS1
-rw-r--r--etc/images/mpc/add.xpm31
-rw-r--r--etc/images/mpc/ffwd.xpm34
-rw-r--r--etc/images/mpc/next.xpm34
-rw-r--r--etc/images/mpc/pause.xpm33
-rw-r--r--etc/images/mpc/play.xpm34
-rw-r--r--etc/images/mpc/prev.xpm33
-rw-r--r--etc/images/mpc/rewind.xpm33
-rw-r--r--etc/images/mpc/stop.xpm33
-rw-r--r--lisp/ChangeLog4
-rw-r--r--lisp/mpc.el2601
11 files changed, 2871 insertions, 0 deletions
diff --git a/etc/NEWS b/etc/NEWS
index da58ebebaac..367c2fe0728 100644
--- a/etc/NEWS
+++ b/etc/NEWS
@@ -323,6 +323,7 @@ and let commands run under that user permissions. It works even when
323 323
324* New Modes and Packages in Emacs 23.2 324* New Modes and Packages in Emacs 23.2
325 325
326** mpc.el is a front end for the Music Player Daemon. Run it with M-x mpc.
326** htmlfontify.el turns a fontified Emacs buffer into an HTML page. 327** htmlfontify.el turns a fontified Emacs buffer into an HTML page.
327 328
328** FIXME CEDET 329** FIXME CEDET
diff --git a/etc/images/mpc/add.xpm b/etc/images/mpc/add.xpm
new file mode 100644
index 00000000000..02893c92399
--- /dev/null
+++ b/etc/images/mpc/add.xpm
@@ -0,0 +1,31 @@
1/* XPM */
2static char * stop_xpm[] = {
3"24 24 4 1",
4" c None",
5". s light1 c grey90",
6"X s main c grey70",
7"o s shadow c grey50",
8" ",
9" ...................... ",
10" .XXXXXXXXXXXXXXXXXXXXo ",
11" .XXXXXXXXXXXXXXXXXXXXo ",
12" .XXXXXXXXXXXXXXXXXXXXo ",
13" .XXXXXXXX....XXXXXXXXo ",
14" .XXXXXXXX.XXoXXXXXXXXo ",
15" .XXXXXXXX.XXoXXXXXXXXo ",
16" .XXXXXXXX.XXoXXXXXXXXo ",
17" .XXXXXXXX.XXoXXXXXXXXo ",
18" .XXX......XXo.....XXXo ",
19" .XXX.XXXXXXXXXXXXoXXXo ",
20" .XXX.XXXXXXXXXXXXoXXXo ",
21" .XXX.oooooXXooooooXXXo ",
22" .XXXXXXXX.XXoXXXXXXXXo ",
23" .XXXXXXXX.XXoXXXXXXXXo ",
24" .XXXXXXXX.XXoXXXXXXXXo ",
25" .XXXXXXXX.XXoXXXXXXXXo ",
26" .XXXXXXXX.oooXXXXXXXXo ",
27" .XXXXXXXXXXXXXXXXXXXXo ",
28" .XXXXXXXXXXXXXXXXXXXXo ",
29" .XXXXXXXXXXXXXXXXXXXXo ",
30" .ooooooooooooooooooooo ",
31" "};
diff --git a/etc/images/mpc/ffwd.xpm b/etc/images/mpc/ffwd.xpm
new file mode 100644
index 00000000000..c0b5a91a735
--- /dev/null
+++ b/etc/images/mpc/ffwd.xpm
@@ -0,0 +1,34 @@
1/* XPM */
2static char * ffwd_xpm[] = {
3"24 24 5 1",
4" c None",
5". s light1 c grey90",
6"X s main c grey70",
7"o s shadow c grey50",
8"O s light2 c grey80",
9" ",
10" ...................... ",
11" .XXXXXXXXXXXXXXXXXXXXo ",
12" .XXXXXXXXXXXXXXXXXXXXo ",
13" .XXXXXXXXXXXXXXXXXXXXo ",
14" .XXX.OXXX.OXXXXXXXXXXo ",
15" .XXX.XOXX.XOXXXXXXXXXo ",
16" .XXX.XXOO.XXOOXXXXXXXo ",
17" .XXX.XXXX.XXXXOXXXXXXo ",
18" .XXX.XXXX.XXXXXOXXXXXo ",
19" .XXX.XXXX.XXXXXXOOXXXo ",
20" .XXX.XXXX.XXXXXXXXOXXo ",
21" .XXX.XXXX.XXXXXXXXoXXo ",
22" .XXX.XXXX.XXXXXXooXXXo ",
23" .XXX.XXXX.XXXXXoXXXXXo ",
24" .XXX.XXXX.XXXXoXXXXXXo ",
25" .XXX.XXoo.XXooXXXXXXXo ",
26" .XXX.XoXX.XoXXXXXXXXXo ",
27" .XXX.oXXX.oXXXXXXXXXXo ",
28" .XXXXXXXXXXXXXXXXXXXXo ",
29" .XXXXXXXXXXXXXXXXXXXXo ",
30" .XXXXXXXXXXXXXXXXXXXXo ",
31" .ooooooooooooooooooooo ",
32" "};
33
34/* arch-tag: 9b0fa3cf-1e36-4c20-ac68-948c2ae86b62 */
diff --git a/etc/images/mpc/next.xpm b/etc/images/mpc/next.xpm
new file mode 100644
index 00000000000..e94b6388a4f
--- /dev/null
+++ b/etc/images/mpc/next.xpm
@@ -0,0 +1,34 @@
1/* XPM */
2static char * next_xpm[] = {
3"24 24 5 1",
4" c None",
5". s light1 c grey90",
6"X s main c grey70",
7"o s shadow c grey50",
8"O s light2 c grey80",
9" ",
10" ...................... ",
11" .XXXXXXXXXXXXXXXXXXXXo ",
12" .XXXXXXXXXXXXXXXXXXXXo ",
13" .XXXXXXXXXXXXXXXXXXXXo ",
14" .XXX.OXXXXXXXXX...XXXo ",
15" .XXX.XOXXXXXXXX.XoXXXo ",
16" .XXX.XXOOXXXXXX.XoXXXo ",
17" .XXX.XXXXOXXXXX.XoXXXo ",
18" .XXX.XXXXXOXXXX.XoXXXo ",
19" .XXX.XXXXXXOOXX.XoXXXo ",
20" .XXX.XXXXXXXXOX.XoXXXo ",
21" .XXX.XXXXXXXXoX.XoXXXo ",
22" .XXX.XXXXXXooXX.XoXXXo ",
23" .XXX.XXXXXoXXXX.XoXXXo ",
24" .XXX.XXXXoXXXXX.XoXXXo ",
25" .XXX.XXooXXXXXX.XoXXXo ",
26" .XXX.XoXXXXXXXX.XoXXXo ",
27" .XXX.oXXXXXXXXX.ooXXXo ",
28" .XXXXXXXXXXXXXXXXXXXXo ",
29" .XXXXXXXXXXXXXXXXXXXXo ",
30" .XXXXXXXXXXXXXXXXXXXXo ",
31" .ooooooooooooooooooooo ",
32" "};
33
34/* arch-tag: 69a2ee4e-e71f-432d-b17b-ac8055dacc93 */
diff --git a/etc/images/mpc/pause.xpm b/etc/images/mpc/pause.xpm
new file mode 100644
index 00000000000..5a5d977c6f5
--- /dev/null
+++ b/etc/images/mpc/pause.xpm
@@ -0,0 +1,33 @@
1/* XPM */
2static char * pause_xpm[] = {
3"24 24 4 1",
4" c None",
5". s light1 c grey90",
6"X s main c grey70",
7"o s shadow c grey50",
8" ",
9" ...................... ",
10" .XXXXXXXXXXXXXXXXXXXXo ",
11" .XXXXXXXXXXXXXXXXXXXXo ",
12" .XXXXXXXXXXXXXXXXXXXXo ",
13" .XXXX.....XX.....XXXXo ",
14" .XXXX.XXXoXX.XXXoXXXXo ",
15" .XXXX.XXXoXX.XXXoXXXXo ",
16" .XXXX.XXXoXX.XXXoXXXXo ",
17" .XXXX.XXXoXX.XXXoXXXXo ",
18" .XXXX.XXXoXX.XXXoXXXXo ",
19" .XXXX.XXXoXX.XXXoXXXXo ",
20" .XXXX.XXXoXX.XXXoXXXXo ",
21" .XXXX.XXXoXX.XXXoXXXXo ",
22" .XXXX.XXXoXX.XXXoXXXXo ",
23" .XXXX.XXXoXX.XXXoXXXXo ",
24" .XXXX.XXXoXX.XXXoXXXXo ",
25" .XXXX.XXXoXX.XXXoXXXXo ",
26" .XXXX.ooooXX.ooooXXXXo ",
27" .XXXXXXXXXXXXXXXXXXXXo ",
28" .XXXXXXXXXXXXXXXXXXXXo ",
29" .XXXXXXXXXXXXXXXXXXXXo ",
30" .ooooooooooooooooooooo ",
31" "};
32
33/* arch-tag: 3fe99afb-7dfd-49dd-b5b3-d8eedf14b362 */
diff --git a/etc/images/mpc/play.xpm b/etc/images/mpc/play.xpm
new file mode 100644
index 00000000000..0f9b6905d74
--- /dev/null
+++ b/etc/images/mpc/play.xpm
@@ -0,0 +1,34 @@
1/* XPM */
2static char * play_xpm[] = {
3"24 24 5 1",
4" c None",
5". s light1 c grey90",
6"X s main c grey70",
7"o s shadow c grey50",
8"O s light2 c grey80",
9" ",
10" ...................... ",
11" .XXXXXXXXXXXXXXXXXXXXo ",
12" .XXXXXXXXXXXXXXXXXXXXo ",
13" .XXXXXXXXXXXXXXXXXXXXo ",
14" .XXX.OOXXXXXXXXXXXXXXo ",
15" .XXX.XXOOXXXXXXXXXXXXo ",
16" .XXX.XXXXOOXXXXXXXXXXo ",
17" .XXX.XXXXXXOOXXXXXXXXo ",
18" .XXX.XXXXXXXXOOXXXXXXo ",
19" .XXX.XXXXXXXXXXOOXXXXo ",
20" .XXX.XXXXXXXXXXXXOXXXo ",
21" .XXX.XXXXXXXXXXXXoXXXo ",
22" .XXX.XXXXXXXXXXooXXXXo ",
23" .XXX.XXXXXXXXooXXXXXXo ",
24" .XXX.XXXXXXooXXXXXXXXo ",
25" .XXX.XXXXooXXXXXXXXXXo ",
26" .XXX.XXooXXXXXXXXXXXXo ",
27" .XXX.ooXXXXXXXXXXXXXXo ",
28" .XXXXXXXXXXXXXXXXXXXXo ",
29" .XXXXXXXXXXXXXXXXXXXXo ",
30" .XXXXXXXXXXXXXXXXXXXXo ",
31" .ooooooooooooooooooooo ",
32" "};
33
34/* arch-tag: 318eb8de-b126-48bd-818b-bb293df74ec8 */
diff --git a/etc/images/mpc/prev.xpm b/etc/images/mpc/prev.xpm
new file mode 100644
index 00000000000..aa973706fe9
--- /dev/null
+++ b/etc/images/mpc/prev.xpm
@@ -0,0 +1,33 @@
1/* XPM */
2static char * prev_xpm[] = {
3"24 24 4 1",
4" c None",
5". s light1 c grey90",
6"X s main c grey70",
7"o s shadow c grey50",
8" ",
9" ...................... ",
10" .XXXXXXXXXXXXXXXXXXXXo ",
11" .XXXXXXXXXXXXXXXXXXXXo ",
12" .XXXXXXXXXXXXXXXXXXXXo ",
13" .XXX...XXXXXXXXX..XXXo ",
14" .XXX.XoXXXXXXXX.XoXXXo ",
15" .XXX.XoXXXXXX..XXoXXXo ",
16" .XXX.XoXXXXX.XXXXoXXXo ",
17" .XXX.XoXXXX.XXXXXoXXXo ",
18" .XXX.XoXX..XXXXXXoXXXo ",
19" .XXX.XoX.XXXXXXXXoXXXo ",
20" .XXX.XoXoXXXXXXXXoXXXo ",
21" .XXX.XoXXooXXXXXXoXXXo ",
22" .XXX.XoXXXXoXXXXXoXXXo ",
23" .XXX.XoXXXXXoXXXXoXXXo ",
24" .XXX.XoXXXXXXooXXoXXXo ",
25" .XXX.XoXXXXXXXXoXoXXXo ",
26" .XXX.ooXXXXXXXXXooXXXo ",
27" .XXXXXXXXXXXXXXXXXXXXo ",
28" .XXXXXXXXXXXXXXXXXXXXo ",
29" .XXXXXXXXXXXXXXXXXXXXo ",
30" .ooooooooooooooooooooo ",
31" "};
32
33/* arch-tag: 284e0591-6e14-4dae-9cc3-c722fa0b9099 */
diff --git a/etc/images/mpc/rewind.xpm b/etc/images/mpc/rewind.xpm
new file mode 100644
index 00000000000..3dd285a9a76
--- /dev/null
+++ b/etc/images/mpc/rewind.xpm
@@ -0,0 +1,33 @@
1/* XPM */
2static char * rewind_xpm[] = {
3"24 24 4 1",
4" c None",
5". s light1 c grey90",
6"X s main c grey70",
7"o s shadow c grey50",
8" ",
9" ...................... ",
10" .XXXXXXXXXXXXXXXXXXXXo ",
11" .XXXXXXXXXXXXXXXXXXXXo ",
12" .XXXXXXXXXXXXXXXXXXXXo ",
13" .XXXXXXXXXX..XXX..XXXo ",
14" .XXXXXXXXX.XoXX.XoXXXo ",
15" .XXXXXXX..XXo..XXoXXXo ",
16" .XXXXXX.XXXXoXXXXoXXXo ",
17" .XXXXX.XXXXXoXXXXoXXXo ",
18" .XXX..XXXXXXoXXXXoXXXo ",
19" .XX.XXXXXXXXoXXXXoXXXo ",
20" .XXoXXXXXXXXoXXXXoXXXo ",
21" .XXXooXXXXXXoXXXXoXXXo ",
22" .XXXXXoXXXXXoXXXXoXXXo ",
23" .XXXXXXoXXXXoXXXXoXXXo ",
24" .XXXXXXXooXXoooXXoXXXo ",
25" .XXXXXXXXXoXoXXoXoXXXo ",
26" .XXXXXXXXXXooXXXooXXXo ",
27" .XXXXXXXXXXXXXXXXXXXXo ",
28" .XXXXXXXXXXXXXXXXXXXXo ",
29" .XXXXXXXXXXXXXXXXXXXXo ",
30" .ooooooooooooooooooooo ",
31" "};
32
33/* arch-tag: 2bdb6c7f-8ddb-4110-b8ee-ffc3f06d1aa9 */
diff --git a/etc/images/mpc/stop.xpm b/etc/images/mpc/stop.xpm
new file mode 100644
index 00000000000..d5e4d517d0b
--- /dev/null
+++ b/etc/images/mpc/stop.xpm
@@ -0,0 +1,33 @@
1/* XPM */
2static char * stop_xpm[] = {
3"24 24 4 1",
4" c None",
5". s light1 c grey90",
6"X s main c grey70",
7"o s shadow c grey50",
8" ",
9" ...................... ",
10" .XXXXXXXXXXXXXXXXXXXXo ",
11" .XXXXXXXXXXXXXXXXXXXXo ",
12" .XXXXXXXXXXXXXXXXXXXXo ",
13" .XXX..............XXXo ",
14" .XXX.XXXXXXXXXXXXoXXXo ",
15" .XXX.XXXXXXXXXXXXoXXXo ",
16" .XXX.XXXXXXXXXXXXoXXXo ",
17" .XXX.XXXXXXXXXXXXoXXXo ",
18" .XXX.XXXXXXXXXXXXoXXXo ",
19" .XXX.XXXXXXXXXXXXoXXXo ",
20" .XXX.XXXXXXXXXXXXoXXXo ",
21" .XXX.XXXXXXXXXXXXoXXXo ",
22" .XXX.XXXXXXXXXXXXoXXXo ",
23" .XXX.XXXXXXXXXXXXoXXXo ",
24" .XXX.XXXXXXXXXXXXoXXXo ",
25" .XXX.XXXXXXXXXXXXoXXXo ",
26" .XXX.oooooooooooooXXXo ",
27" .XXXXXXXXXXXXXXXXXXXXo ",
28" .XXXXXXXXXXXXXXXXXXXXo ",
29" .XXXXXXXXXXXXXXXXXXXXo ",
30" .ooooooooooooooooooooo ",
31" "};
32
33/* arch-tag: 184ad626-ea69-40ae-839a-f5b5929ebb93 */
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index 573101a1f73..4864e5ef848 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,7 @@
12009-12-01 Stefan Monnier <monnier@iro.umontreal.ca>
2
3 * mpc.el: New file.
4
12009-12-01 Glenn Morris <rgm@gnu.org> 52009-12-01 Glenn Morris <rgm@gnu.org>
2 6
3 * window.el (window-to-use): Define for compiler. 7 * window.el (window-to-use): Define for compiler.
diff --git a/lisp/mpc.el b/lisp/mpc.el
new file mode 100644
index 00000000000..256f9a966a0
--- /dev/null
+++ b/lisp/mpc.el
@@ -0,0 +1,2601 @@
1;;; mpc.el --- A client for the Music Player Daemon -*- coding: utf-8 -*-
2
3;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
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
45;; - display/set `repeat' and `random' state (and maybe also `crossfade').
46;; - allow multiple *mpc* sessions in the same Emacs to control different mpds.
47;; - look for .folder.png (freedesktop) or folder.jpg (XP) as well.
48;; - fetch album covers and lyrics from the web?
49;; - improve MPC-Status: better volume control, add a way to show/hide the
50;; rest, plus add the buttons currently in the toolbar.
51;; - improve mpc-songs-mode's header-line column-headings so they can be
52;; dragged to resize.
53;; - allow selecting several entries by drag-mouse.
54;; - poll less often
55;; - use the `idle' command
56;; - do the time-ticking locally (and sync every once in a while)
57;; - look at the end of play time to make sure we notice the end
58;; as soon as possible
59;; - better volume widget.
60;; - add synthesized tags.
61;; e.g. pseudo-artist = artist + composer + performer.
62;; e.g. pseudo-performer = performer or artist
63;; e.g. rewrite artist "Foo bar & baz" to "Foo bar".
64;; e.g. filename regexp -> compilation flag
65;; - window/buffer management.
66;; - menubar, tooltips, ...
67;; - add mpc-describe-song, mpc-describe-album, ...
68;; - add import/export commands (especially export to an MP3 player).
69;; - add a real notion of album (as opposed to just album-name):
70;; if all songs with same album-name have same artist -> it's an album
71;; else it's either several albums or a compilation album (or both),
72;; in which case we could use heuristics or user provided info:
73;; - if the user followed the 1-album = 1-dir idea, then we can group songs
74;; by their directory to create albums.
75;; - if a `compilation' flag is available, and if <=1 of the songs have it
76;; set, then we can group songs by their artist to create albums.
77;; - if two songs have the same track-nb and disk-nb, they're not in the
78;; same album. So from the set of songs with identical album names, we
79;; can get a lower bound on the number of albums involved, and then see
80;; which of those may be non-compilations, etc...
81;; - use a special directory name for compilations.
82;; - ask the web ;-)
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))))
132
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)))
155
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.
166SELECTFUN if non-nil elements aren't compared directly, but instead they
167are passed through SELECTFUN before comparison."
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.
182Contrary to `compare-strings', this tries to get numbers sorted
183numerically 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.
243The format is \"HOST\" or \"HOST:PORT\" where PORT defaults to 6600
244and HOST default to localhost."
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.
356Return 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.
374If CALLBACK is nil, wait for the command to finish before returning,
375otherwise return immediately and call CALLBACK with no argument
376when the command terminates.
377CMD can be a string which is passed as-is to MPD or a list of strings
378which 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.
492Each entry has the form (PROP . FUN) where PROP can be t to mean
493to 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'.
570This is normally used only when quitting MPC.
571Any 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.
625The 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.
796If 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.
808If 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)))
820
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))))))
1059
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.
1338If AVOID-BUF is non-nil, it specifies a buffer which should be ignored
1339when 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))))))
1506
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"))))))))))
1558
1559(defvar mpc--changed-selection)
1560
1561(defun mpc-reorder (&optional nodeactivate)
1562 "Reorder entries based on thre currently active selections.
1563I.e. split the current browser buffer into a first part containing the
1564entries included in the selection, then a separator, and then the entries
1565not included in the selection.
1566Return 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))))
1579
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)))
1667
1668
1669;;; Playlist management ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1670
1671(defvar mpc-songs-playlist nil
1672 "Name of the currently selected playlist, if any.
1673t means the main playlist.")
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
1731 (error "The selected songs aren't part of a playlist."))
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.
1816This 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))))
1928
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)
1957 "Jump to song SONG-FILE, interactively, this is the song at point."
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)))))))
2055
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))))
2247
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 ()
2261 "Pause playing."
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))))
2389
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))
2395
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))
2455
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))
2461
2462
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
generated by cgit v1.2.1 (git 2.18.0) at 2026-04-21 12:28:23 +0000